diff options
Diffstat (limited to 'lisp/emacs-lisp')
63 files changed, 2450 insertions, 2388 deletions
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 86a42b208e7..d383650f4e5 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -1,6 +1,6 @@ ;;; advice.el --- An overloading mechanism for Emacs Lisp functions -*- lexical-binding: t -*- -;; Copyright (C) 1993-1994, 2000-2022 Free Software Foundation, Inc. +;; Copyright (C) 1993-2022 Free Software Foundation, Inc. ;; Author: Hans Chalupsky <hans@cs.buffalo.edu> ;; Maintainer: emacs-devel@gnu.org @@ -23,12 +23,6 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. -;; LCD Archive Entry: -;; advice|Hans Chalupsky|hans@cs.buffalo.edu| -;; Overloading mechanism for Emacs Lisp functions| -;; 1994/08/05 03:42:04|2.14|~/packages/advice.el.Z| - - ;;; Commentary: ;; Advice is documented in the Emacs Lisp Manual. @@ -1060,9 +1054,9 @@ ;; (print "Let's clean up now!")) ;; foo ;; -;; Now `foo's advice is byte-compiled: +;; Now `foo's advice is compiled: ;; -;; (byte-code-function-p 'ad-Advice-foo) +;; (compiled-function-p 'ad-Advice-foo) ;; t ;; ;; (foo 3) @@ -1304,7 +1298,7 @@ ;; constructed during preactivation was used, even though we did not specify ;; the `compile' flag: ;; -;; (byte-code-function-p 'ad-Advice-fum) +;; (compiled-function-p 'ad-Advice-fum) ;; t ;; ;; (fum 2) @@ -1335,7 +1329,7 @@ ;; ;; A new uncompiled advised definition got constructed: ;; -;; (byte-code-function-p 'ad-Advice-fum) +;; (compiled-function-p 'ad-Advice-fum) ;; nil ;; ;; (fum 2) @@ -1586,8 +1580,6 @@ :link '(custom-manual "(elisp)Advising Functions") :group 'lisp) -(defconst ad-version "2.14") - ;;;###autoload (defcustom ad-redefinition-action 'warn "Defines what to do with redefinitions during Advice de/activation. @@ -2124,9 +2116,9 @@ the cache-id will clear the cache." (defsubst ad-compiled-p (definition) "Return non-nil if DEFINITION is a compiled byte-code object." - (or (byte-code-function-p definition) - (and (macrop definition) - (byte-code-function-p (ad-lambdafy definition))))) + (or (compiled-function-p definition) + (and (macrop definition) + (compiled-function-p (ad-lambdafy definition))))) (defsubst ad-compiled-code (compiled-definition) "Return the byte-code object of a COMPILED-DEFINITION." @@ -3256,6 +3248,9 @@ Use only in REAL emergencies." (message "Oops! Left over advised function %S" function) (ad-pop-advised-function function))) +(defconst ad-version "2.14") +(make-obsolete-variable 'ad-version 'emacs-version "29.1") + (provide 'advice) ;;; advice.el ends here diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el deleted file mode 100644 index eed88b6faf4..00000000000 --- a/lisp/emacs-lisp/autoload.el +++ /dev/null @@ -1,915 +0,0 @@ -;;; autoload.el --- maintain autoloads in loaddefs.el -*- lexical-binding: t -*- - -;; Copyright (C) 1991-1997, 2001-2022 Free Software Foundation, Inc. - -;; Author: Roland McGrath <roland@gnu.org> -;; Keywords: maint -;; Package: emacs - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This code helps GNU Emacs maintainers keep the loaddefs.el file up to -;; date. It interprets magic cookies of the form ";;;###autoload" in -;; Lisp source files in various useful ways. To learn more, read the -;; source; if you're going to use this, you'd better be able to. - -;; The functions in this file have been largely superseded by -;; loaddefs-gen.el. - -;;; Code: - -(require 'lisp-mode) ;for `doc-string-elt' properties. -(require 'lisp-mnt) -(require 'cl-lib) -(require 'loaddefs-gen) - -;; This feels like it should be a defconst, but MH-E sets it to -;; ";;;###mh-autoload" for the autoloads that are to go into mh-loaddefs.el. -(defvar generate-autoload-cookie ";;;###autoload" - "Magic comment indicating the following form should be autoloaded. -Used by \\[update-file-autoloads]. This string should be -meaningless to Lisp (e.g., a comment). - -This string is used: - -\;;;###autoload -\(defun function-to-be-autoloaded () ...) - -If this string appears alone on a line, the following form will be -read and an autoload made for it. If there is further text on the line, -that text will be copied verbatim to `generated-autoload-file'.") - -(defvar autoload-excludes nil - "If non-nil, list of absolute file names not to scan for autoloads.") - -(defconst generate-autoload-section-header "\f\n;;;### " - "String that marks the form at the start of a new file's autoload section.") - -(defconst generate-autoload-section-trailer "\n;;;***\n" - "String which indicates the end of the section of autoloads for a file.") - -(defconst generate-autoload-section-continuation ";;;;;; " - "String to add on each continuation of the section header form.") - -;; In some ways it would be nicer to use a value that is recognizably -;; not a time-value, eg t, but that can cause issues if an older Emacs -;; that does not expect non-time-values loads the file. -(defconst autoload--non-timestamp '(0 0 0 0) - "Value to insert when `autoload-timestamps' is nil.") - -(defvar autoload-timestamps nil ; experimental, see bug#22213 - "Non-nil means insert a timestamp for each input file into the output. -We use these in incremental updates of the output file to decide -if we need to rescan an input file. If you set this to nil, -then we use the timestamp of the output file instead. As a result: - - for fixed inputs, the output will be the same every time - - incremental updates of the output file might not be correct if: - i) the timestamp of the output file cannot be trusted (at least - relative to that of the input files) - ii) any of the input files can be modified during the time it takes - to create the output - iii) only a subset of the input files are scanned - These issues are unlikely to happen in practice, and would arguably - represent bugs in the build system. Item iii) will happen if you - use a command like `update-file-autoloads', though, since it only - checks a single input file.") - -(defvar autoload-modified-buffers) ;Dynamically scoped var. - -(defalias 'make-autoload #'loaddefs-generate--make-autoload) - -;; Forms which have doc-strings which should be printed specially. -;; A doc-string-elt property of ELT says that (nth ELT FORM) is -;; the doc-string in FORM. -;; Those properties are now set in lisp-mode.el. - -(defun autoload-find-generated-file (file) - "Visit the autoload file for the current buffer, and return its buffer." - (let ((enable-local-variables :safe) - (enable-local-eval nil) - (find-file-hook nil) - (delay-mode-hooks t)) - ;; We used to use `raw-text' to read this file, but this causes - ;; problems when the file contains non-ASCII characters. - (with-current-buffer (find-file-noselect - (autoload-ensure-file-writeable file)) - (if (zerop (buffer-size)) (insert (autoload-rubric file nil t))) - (current-buffer)))) - -(defun autoload-generated-file (outfile) - "Return OUTFILE as an absolute name. -If `generated-autoload-file' is bound locally in the current -buffer, that is used instead, and it is expanded using the -default directory; otherwise, `source-directory'/lisp is used." - (expand-file-name (if (local-variable-p 'generated-autoload-file) - generated-autoload-file - outfile) - ;; File-local settings of generated-autoload-file should - ;; be interpreted relative to the file's location, - ;; of course. - (if (not (local-variable-p 'generated-autoload-file)) - (expand-file-name "lisp" source-directory)))) - -(defun autoload-read-section-header () - "Read a section header form. -Since continuation lines have been marked as comments, -we must copy the text of the form and remove those comment -markers before we call `read'." - (save-match-data - (let ((beginning (point)) - string) - (forward-line 1) - (while (looking-at generate-autoload-section-continuation) - (forward-line 1)) - (setq string (buffer-substring beginning (point))) - (with-current-buffer (get-buffer-create " *autoload*") - (erase-buffer) - (insert string) - (goto-char (point-min)) - (while (search-forward generate-autoload-section-continuation nil t) - (replace-match " ")) - (goto-char (point-min)) - (read (current-buffer)))))) - -(defvar autoload-print-form-outbuf nil - "Buffer which gets the output of `autoload-print-form'.") - -(defun autoload-print-form (form) - "Print FORM such that `make-docfile' will find the docstrings. -The variable `autoload-print-form-outbuf' specifies the buffer to -put the output in." - (cond - ;; If the form is a sequence, recurse. - ((eq (car form) 'progn) (mapcar #'autoload-print-form (cdr form))) - ;; Symbols at the toplevel are meaningless. - ((symbolp form) nil) - (t - (let ((doc-string-elt (function-get (car-safe form) 'doc-string-elt)) - (outbuf autoload-print-form-outbuf)) - (if (and (numberp doc-string-elt) (stringp (nth doc-string-elt form))) - ;; We need to hack the printing because the - ;; doc-string must be printed specially for - ;; make-docfile (sigh). - (let* ((p (nthcdr (1- doc-string-elt) form)) - (elt (cdr p))) - (setcdr p nil) - (princ "\n(" outbuf) - (let ((print-escape-newlines t) - (print-escape-control-characters t) - (print-quoted t) - (print-escape-nonascii t)) - (dolist (elt form) - (prin1 elt outbuf) - (princ " " outbuf))) - (princ "\"\\\n" outbuf) - (let ((begin (with-current-buffer outbuf (point)))) - (princ (substring (prin1-to-string (car elt)) 1) - outbuf) - ;; Insert a backslash before each ( that - ;; appears at the beginning of a line in - ;; the doc string. - (with-current-buffer outbuf - (save-excursion - (while (re-search-backward "\n[[(]" begin t) - (forward-char 1) - (insert "\\")))) - (if (null (cdr elt)) - (princ ")" outbuf) - (princ " " outbuf) - (princ (substring (prin1-to-string (cdr elt)) 1) - outbuf)) - (terpri outbuf))) - (let ((print-escape-newlines t) - (print-escape-control-characters t) - (print-quoted t) - (print-escape-nonascii t)) - (print form outbuf))))))) - -(defalias 'autoload-rubric #'loaddefs-generate--rubric) - -(defvar autoload-ensure-writable nil - "Non-nil means `autoload-find-generated-file' makes existing file writable.") -;; Just in case someone tries to get you to overwrite a file that you -;; don't want to. -;;;###autoload -(put 'autoload-ensure-writable 'risky-local-variable t) - -(defun autoload-ensure-file-writeable (file) - ;; Probably pointless, but replaces the old AUTOGEN_VCS in lisp/Makefile, - ;; which was designed to handle CVSREAD=1 and equivalent. - (and autoload-ensure-writable - (let ((modes (file-modes file))) - (if (and modes (zerop (logand modes #o0200))) - ;; Ignore any errors here, and let subsequent attempts - ;; to write the file raise any real error. - (ignore-errors (set-file-modes file (logior modes #o0200)))))) - file) - -(defun autoload-insert-section-header (outbuf autoloads load-name file time) - "Insert into buffer OUTBUF the section-header line for FILE. -The header line lists the file name, its \"load name\", its autoloads, -and the time the FILE was last updated (the time is inserted only -if `autoload-timestamps' is non-nil, otherwise a fixed fake time is inserted)." - ;; (cl-assert ;Make sure we don't insert it in the middle of another section. - ;; (save-excursion - ;; (or (not (re-search-backward - ;; (concat "\\(" - ;; (regexp-quote generate-autoload-section-header) - ;; "\\)\\|\\(" - ;; (regexp-quote generate-autoload-section-trailer) - ;; "\\)") - ;; nil t)) - ;; (match-end 2)))) - (insert generate-autoload-section-header) - (prin1 `(autoloads ,autoloads ,load-name ,file ,time) - outbuf) - (terpri outbuf) - ;; Break that line at spaces, to avoid very long lines. - ;; Make each sub-line into a comment. - (with-current-buffer outbuf - (save-excursion - (forward-line -1) - (while (not (eolp)) - (move-to-column 64) - (skip-chars-forward "^ \n") - (or (eolp) - (insert "\n" generate-autoload-section-continuation)))))) - -(defun autoload-find-file (file) - "Fetch FILE and put it in a temp buffer. Return the buffer." - ;; It is faster to avoid visiting the file. - (setq file (expand-file-name file)) - (with-current-buffer (get-buffer-create " *autoload-file*") - (kill-all-local-variables) - (erase-buffer) - (setq buffer-undo-list t - buffer-read-only nil) - (delay-mode-hooks (emacs-lisp-mode)) - (setq default-directory (file-name-directory file)) - (insert-file-contents file nil) - (let ((enable-local-variables :safe) - (enable-local-eval nil)) - (hack-local-variables)) - (current-buffer))) - -(defalias 'autoload-insert-section-header - #'loaddefs-generate--insert-section-header) - -(defvar no-update-autoloads nil - "File local variable to prevent scanning this file for autoload cookies.") - -(defalias 'autoload-file-load-name #'loaddefs-generate--file-load-name) - -(defun generate-file-autoloads (file) - "Insert at point a loaddefs autoload section for FILE. -Autoloads are generated for defuns and defmacros in FILE -marked by `generate-autoload-cookie' (which see). -If FILE is being visited in a buffer, the contents of the buffer -are used. -Return non-nil in the case where no autoloads were added at point." - (interactive "fGenerate autoloads for file: ") - (let ((autoload-modified-buffers nil)) - (autoload-generate-file-autoloads file (current-buffer) buffer-file-name) - autoload-modified-buffers)) - -(defconst autoload-def-prefixes-max-entries 5 - "Target length of the list of definition prefixes per file. -If set too small, the prefixes will be too generic (i.e. they'll use little -memory, we'll end up looking in too many files when we need a particular -prefix), and if set too large, they will be too specific (i.e. they will -cost more memory use).") - -(defconst autoload-def-prefixes-max-length 12 - "Target size of definition prefixes. -Don't try to split prefixes that are already longer than that.") - -(defalias 'autoload--make-defs-autoload #'loaddefs-generate--make-prefixes) - -(defun autoload--setup-output (otherbuf outbuf absfile load-name output-file) - (let ((outbuf - (or (if otherbuf - ;; A file-local setting of - ;; autoload-generated-file says we - ;; should ignore OUTBUF. - nil - outbuf) - (autoload-find-destination absfile load-name output-file) - ;; The file has autoload cookies, but they're - ;; already up-to-date. If OUTFILE is nil, the - ;; entries are in the expected OUTBUF, - ;; otherwise they're elsewhere. - (throw 'done otherbuf)))) - (with-current-buffer outbuf - (point-marker)))) - -(defun autoload--print-cookie-text (output-start load-name file) - (let ((standard-output (marker-buffer output-start))) - (search-forward generate-autoload-cookie) - (skip-chars-forward " \t") - (if (eolp) - (condition-case-unless-debug err - ;; Read the next form and make an autoload. - (let* ((form (prog1 (read (current-buffer)) - (or (bolp) (forward-line 1)))) - (autoload (make-autoload form load-name))) - (if autoload - nil - (setq autoload form)) - (let ((autoload-print-form-outbuf - standard-output)) - (autoload-print-form autoload))) - (error - (message "Autoload cookie error in %s:%s %S" - file (count-lines (point-min) (point)) err))) - - ;; Copy the rest of the line to the output. - (princ (buffer-substring - (progn - ;; Back up over whitespace, to preserve it. - (skip-chars-backward " \f\t") - (if (= (char-after (1+ (point))) ? ) - ;; Eat one space. - (forward-char 1)) - (point)) - (progn (forward-line 1) (point))))))) - -(defvar autoload-builtin-package-versions nil) - -(defun autoload-generate-file-autoloads (file &optional outbuf outfile) - "Insert an autoload section for FILE in the appropriate buffer. -Autoloads are generated for defuns and defmacros in FILE -marked by `generate-autoload-cookie' (which see). - -If FILE is being visited in a buffer, the contents of the buffer are used. -OUTBUF is the buffer in which the autoload statements should be inserted. - -If OUTBUF is nil, the output will go to OUTFILE, unless there's a -buffer-local setting of `generated-autoload-file' in FILE. - -Return non-nil if and only if FILE adds no autoloads to OUTFILE -\(or OUTBUF if OUTFILE is nil). The actual return value is -FILE's modification time." - ;; Include the file name in any error messages - (condition-case err - (let (load-name - (print-length nil) - (print-level nil) - (float-output-format nil) - (visited (get-file-buffer file)) - (otherbuf nil) - (absfile (expand-file-name file)) - (defs '()) - ;; nil until we found a cookie. - output-start) - (when - (catch 'done - (with-current-buffer (or visited - ;; It is faster to avoid visiting the file. - (autoload-find-file file)) - ;; Obey the no-update-autoloads file local variable. - (unless no-update-autoloads - (or noninteractive (message "Generating autoloads for %s..." file)) - (setq load-name - (if (stringp generated-autoload-load-name) - generated-autoload-load-name - (autoload-file-load-name absfile outfile))) - ;; FIXME? Comparing file-names for equality with just equal - ;; is fragile, eg if one has an automounter prefix and one - ;; does not, but both refer to the same physical file. - (when (and outfile - (not outbuf) - (not - (if (memq system-type '(ms-dos windows-nt)) - (equal (downcase outfile) - (downcase (autoload-generated-file - outfile))) - (equal outfile (autoload-generated-file - outfile))))) - (setq otherbuf t)) - (save-excursion - (save-restriction - (widen) - (when autoload-builtin-package-versions - (let ((version (lm-header "version")) - package) - (and version - (setq version (ignore-errors (version-to-list version))) - (setq package (or (lm-header "package") - (file-name-sans-extension - (file-name-nondirectory file)))) - (setq output-start (autoload--setup-output - otherbuf outbuf absfile - load-name outfile)) - (let ((standard-output (marker-buffer output-start)) - (print-quoted t)) - (princ `(push (purecopy - ',(cons (intern package) version)) - package--builtin-versions)) - (princ "\n"))))) - - ;; Do not insert autoload entries for excluded files. - (unless (member absfile autoload-excludes) - (goto-char (point-min)) - (while (not (eobp)) - (skip-chars-forward " \t\n\f") - (cond - ((looking-at (regexp-quote generate-autoload-cookie)) - ;; If not done yet, figure out where to insert this text. - (unless output-start - (setq output-start (autoload--setup-output - otherbuf outbuf absfile - load-name outfile))) - (autoload--print-cookie-text output-start load-name file)) - ((= (following-char) ?\;) - ;; Don't read the comment. - (forward-line 1)) - (t - ;; Avoid (defvar <foo>) by requiring a trailing space. - ;; Also, ignore this prefix business - ;; for ;;;###tramp-autoload and friends. - (when (and (equal generate-autoload-cookie ";;;###autoload") - (looking-at "(\\(def[^ ]+\\) ['(]*\\([^' ()\"\n]+\\)[\n \t]") - (not (member - (match-string 1) - autoload-ignored-definitions))) - (push (match-string-no-properties 2) defs)) - (forward-sexp 1) - (forward-line 1))))))) - - (when (and autoload-compute-prefixes defs) - ;; This output needs to always go in the main loaddefs.el, - ;; regardless of generated-autoload-file. - ;; FIXME: the files that don't have autoload cookies but - ;; do have definitions end up listed twice in loaddefs.el: - ;; once for their register-definition-prefixes and once in - ;; the list of "files without any autoloads". - (let ((form (autoload--make-defs-autoload defs load-name))) - (cond - ((null form)) ;All defs obey the default rule, yay! - ((not otherbuf) - (unless output-start - (setq output-start (autoload--setup-output - nil outbuf absfile load-name outfile))) - (let ((autoload-print-form-outbuf - (marker-buffer output-start))) - (autoload-print-form form))) - (t - (let* ((other-output-start - ;; To force the output to go to the main loaddefs.el - ;; rather than to generated-autoload-file, - ;; there are two cases: if outbuf is non-nil, - ;; then passing otherbuf=nil is enough, but if - ;; outbuf is nil, that won't cut it, so we - ;; locally bind generated-autoload-file. - (autoload--setup-output nil outbuf absfile load-name - outfile)) - (autoload-print-form-outbuf - (marker-buffer other-output-start))) - (autoload-print-form form) - (with-current-buffer (marker-buffer other-output-start) - (save-excursion - ;; Insert the section-header line which lists - ;; the file name and which functions are in it, etc. - (goto-char other-output-start) - (let ((relfile (file-relative-name absfile))) - (autoload-insert-section-header - (marker-buffer other-output-start) - "actual autoloads are elsewhere" load-name relfile - (if autoload-timestamps - (file-attribute-modification-time - (file-attributes absfile)) - autoload--non-timestamp)) - (insert ";;; Generated autoloads from " relfile "\n"))) - (insert generate-autoload-section-trailer))))))) - - (when output-start - (let ((secondary-autoloads-file-buf - (if otherbuf (current-buffer)))) - (with-current-buffer (marker-buffer output-start) - (cl-assert (> (point) output-start)) - (save-excursion - ;; Insert the section-header line which lists the file name - ;; and which functions are in it, etc. - (goto-char output-start) - (let ((relfile (file-relative-name absfile))) - (autoload-insert-section-header - (marker-buffer output-start) - () load-name relfile - (if secondary-autoloads-file-buf - ;; MD5 checksums are much better because they do not - ;; change unless the file changes (so they'll be - ;; equal on two different systems and will change - ;; less often than time-stamps, thus leading to fewer - ;; unneeded changes causing spurious conflicts), but - ;; using time-stamps is a very useful optimization, - ;; so we use time-stamps for the main autoloads file - ;; (loaddefs.el) where we have special ways to - ;; circumvent the "random change problem", and MD5 - ;; checksum in secondary autoload files where we do - ;; not need the time-stamp optimization because it is - ;; already provided by the primary autoloads file. - (md5 secondary-autoloads-file-buf - ;; We'd really want to just use - ;; `emacs-internal' instead. - nil nil 'emacs-mule-unix) - (if autoload-timestamps - (file-attribute-modification-time - (file-attributes relfile)) - autoload--non-timestamp))) - (insert ";;; Generated autoloads from " relfile "\n"))) - (insert generate-autoload-section-trailer)))) - (or noninteractive - (message "Generating autoloads for %s...done" file))) - (or visited - ;; We created this buffer, so we should kill it. - (kill-buffer (current-buffer)))) - (or (not output-start) - ;; If the entries were added to some other buffer, then the file - ;; doesn't add entries to OUTFILE. - otherbuf)) - (file-attribute-modification-time (file-attributes absfile)))) - (error - ;; Probably unbalanced parens in forward-sexp. In that case, the - ;; condition is scan-error, and the signal data includes point - ;; where the error was found; we'd like to convert that to - ;; line:col, but line-number-at-pos gets the wrong line in batch - ;; mode for some reason. - ;; - ;; At least this gets the file name in the error message; the - ;; developer can use goto-char to get to the error position. - (error "%s:0:0: error: %s: %s" file (car err) (cdr err))) - )) - -;; For parallel builds, to stop another process reading a half-written file. -(defun autoload--save-buffer () - "Save current buffer to its file, atomically." - ;; Similar to byte-compile-file. - (let* ((version-control 'never) - (tempfile (make-temp-file buffer-file-name)) - (default-modes (default-file-modes)) - (temp-modes (logand default-modes #o600)) - (desired-modes (logand default-modes - (or (file-modes buffer-file-name) #o666))) - (kill-emacs-hook - (cons (lambda () (ignore-errors (delete-file tempfile))) - kill-emacs-hook))) - (unless (= temp-modes desired-modes) - (set-file-modes tempfile desired-modes 'nofollow)) - (write-region (point-min) (point-max) tempfile nil 1) - (backup-buffer) - (rename-file tempfile buffer-file-name t)) - (set-buffer-modified-p nil) - (set-visited-file-modtime) - (or noninteractive (message "Wrote %s" buffer-file-name))) - -(defun autoload-save-buffers () - (while autoload-modified-buffers - (with-current-buffer (pop autoload-modified-buffers) - (autoload--save-buffer)))) - -;; FIXME This command should be deprecated. -;; See https://debbugs.gnu.org/22213#41 -;;;###autoload -(defun update-file-autoloads (file &optional save-after outfile) - "Update the autoloads for FILE. -If prefix arg SAVE-AFTER is non-nil, save the buffer too. - -If FILE binds `generated-autoload-file' as a file-local variable, -autoloads are written into that file. Otherwise, the autoloads -file is determined by OUTFILE. If called interactively, prompt -for OUTFILE; if called from Lisp with OUTFILE nil, use the -existing value of `generated-autoload-file'. - -Return FILE if there was no autoload cookie in it, else nil." - (interactive (list (read-file-name "Update autoloads for file: ") - current-prefix-arg - (read-file-name "Write autoload definitions to file: "))) - (setq outfile (or outfile generated-autoload-file)) - (let* ((autoload-modified-buffers nil) - ;; We need this only if the output file handles more than one input. - ;; See https://debbugs.gnu.org/22213#38 and subsequent. - (autoload-timestamps t) - (no-autoloads (autoload-generate-file-autoloads - file nil - (if (local-variable-p 'generated-autoload-file) - generated-autoload-file - outfile)))) - (if autoload-modified-buffers - (if save-after (autoload-save-buffers)) - (if (called-interactively-p 'interactive) - (message "Autoload section for %s is up to date." file))) - (if no-autoloads file))) - -(defun autoload-find-destination (file load-name output-file) - "Find the destination point of the current buffer's autoloads. -FILE is the file name of the current buffer. -LOAD-NAME is the name as it appears in the output. -Returns a buffer whose point is placed at the requested location. -Returns nil if the file's autoloads are up-to-date, otherwise -removes any prior now out-of-date autoload entries." - (catch 'up-to-date - (let* ((buf (current-buffer)) - (existing-buffer (if buffer-file-name buf)) - (output-file (autoload-generated-file output-file)) - (output-time (if (file-exists-p output-file) - (file-attribute-modification-time - (file-attributes output-file)))) - (found nil)) - (with-current-buffer (autoload-find-generated-file output-file) - ;; This is to make generated-autoload-file have Unix EOLs, so - ;; that it is portable to all platforms. - (or (eq 0 (coding-system-eol-type buffer-file-coding-system)) - (set-buffer-file-coding-system 'unix)) - (or (> (buffer-size) 0) - (error "Autoloads file %s lacks boilerplate" buffer-file-name)) - (or (file-writable-p buffer-file-name) - (error "Autoloads file %s is not writable" buffer-file-name)) - (widen) - (goto-char (point-min)) - ;; Look for the section for LOAD-NAME. - (while (and (not found) - (search-forward generate-autoload-section-header nil t)) - (let ((form (autoload-read-section-header))) - (cond ((string= (nth 2 form) load-name) - ;; We found the section for this file. - ;; Check if it is up to date. - (let ((begin (match-beginning 0)) - (last-time (nth 4 form)) - (file-time (file-attribute-modification-time - (file-attributes file)))) - (if (and (or (null existing-buffer) - (not (buffer-modified-p existing-buffer))) - (cond - ;; FIXME? Arguably we should throw a - ;; user error, or some kind of warning, - ;; if we were called from update-file-autoloads, - ;; which can update only a single input file. - ;; It's not appropriate to use the output - ;; file modtime in such a case, - ;; if there are multiple input files - ;; contributing to the output. - ((and output-time - (member last-time - (list t autoload--non-timestamp))) - (not (time-less-p output-time file-time))) - ;; last-time is the time-stamp (specifying - ;; the last time we looked at the file) and - ;; the file hasn't been changed since. - ((listp last-time) - (not (time-less-p last-time file-time))) - ;; last-time is an MD5 checksum instead. - ((stringp last-time) - (equal last-time - (md5 buf nil nil 'emacs-mule))))) - (throw 'up-to-date nil) - (autoload-remove-section begin) - (setq found t)))) - ((string< load-name (nth 2 form)) - ;; We've come to a section alphabetically later than - ;; LOAD-NAME. We assume the file is in order and so - ;; there must be no section for LOAD-NAME. We will - ;; insert one before the section here. - (goto-char (match-beginning 0)) - (setq found t))))) - (or found - (progn - ;; No later sections in the file. Put before the last page. - (goto-char (point-max)) - (search-backward "\f" nil t))) - (unless (memq (current-buffer) autoload-modified-buffers) - (push (current-buffer) autoload-modified-buffers)) - (current-buffer))))) - -(defun autoload-remove-section (begin) - (goto-char begin) - (search-forward generate-autoload-section-trailer) - (delete-region begin (point))) - -;;;###autoload -(defun update-directory-autoloads (&rest dirs) - "Update autoload definitions for Lisp files in the directories DIRS. -In an interactive call, you must give one argument, the name of a -single directory. In a call from Lisp, you can supply multiple -directories as separate arguments, but this usage is discouraged. - -The function does NOT recursively descend into subdirectories of the -directory or directories specified. - -In an interactive call, prompt for a default output file for the -autoload definitions. When called from Lisp, use the existing -value of `generated-autoload-file'. If any Lisp file binds -`generated-autoload-file' as a file-local variable, write its -autoloads into the specified file instead." - (declare (obsolete make-directory-autoloads "28.1")) - (interactive "DUpdate autoloads from directory: ") - (make-directory-autoloads - dirs - (if (called-interactively-p 'interactive) - (read-file-name "Write autoload definitions to file: ") - generated-autoload-file))) - -;;;###autoload -(defun make-directory-autoloads (dir output-file) - "Update autoload definitions for Lisp files in the directories DIRS. -DIR can be either a single directory or a list of -directories. (The latter usage is discouraged.) - -The autoloads will be written to OUTPUT-FILE. If any Lisp file -binds `generated-autoload-file' as a file-local variable, write -its autoloads into the specified file instead. - -The function does NOT recursively descend into subdirectories of the -directory or directories specified." - (interactive "DUpdate autoloads from directory: \nFWrite to file: ") - (let* ((files-re (let ((tmp nil)) - (dolist (suf (get-load-suffixes)) - ;; We don't use module-file-suffix below because - ;; we don't want to depend on whether Emacs was - ;; built with or without modules support, nor - ;; what is the suffix for the underlying OS. - (unless (string-match "\\.\\(elc\\|so\\|dll\\)" suf) - (push suf tmp))) - (concat "\\`[^=.].*" (regexp-opt tmp t) "\\'"))) - (files (apply #'nconc - (mapcar (lambda (d) - (directory-files (expand-file-name d) - t files-re)) - (if (consp dir) dir (list dir))))) - (done ()) ;Files processed; to remove duplicates. - (changed nil) ;Non-nil if some change occurred. - (last-time) - ;; Files with no autoload cookies or whose autoloads go to other - ;; files because of file-local autoload-generated-file settings. - (no-autoloads nil) - ;; Ensure that we don't do odd things when putting the doc - ;; strings into the autoloads file. - (left-margin 0) - (autoload-modified-buffers nil) - (output-time - (and (file-exists-p output-file) - (file-attribute-modification-time - (file-attributes output-file))))) - - (with-current-buffer (autoload-find-generated-file output-file) - (save-excursion - ;; Canonicalize file names and remove the autoload file itself. - (setq files (delete (file-relative-name buffer-file-name) - (mapcar #'file-relative-name files))) - - (goto-char (point-min)) - (while (search-forward generate-autoload-section-header nil t) - (let* ((form (autoload-read-section-header)) - (file (nth 3 form))) - (cond ((and (consp file) (stringp (car file))) - ;; This is a list of files that have no autoload cookies. - ;; There shouldn't be more than one such entry. - ;; Remove the obsolete section. - (autoload-remove-section (match-beginning 0)) - (setq last-time (nth 4 form)) - (if (member last-time (list t autoload--non-timestamp)) - (setq last-time output-time)) - (dolist (file file) - (let ((file-time (file-attribute-modification-time - (file-attributes file)))) - (when (and file-time - (not (time-less-p last-time file-time))) - ;; file unchanged - (push file no-autoloads) - (setq files (delete file files)))))) - ((not (stringp file))) - ((or (not (file-exists-p file)) - ;; Remove duplicates as well, just in case. - (member file done)) - ;; Remove the obsolete section. - (setq changed t) - (autoload-remove-section (match-beginning 0))) - ((not (time-less-p (let ((oldtime (nth 4 form))) - (if (member oldtime - (list - t autoload--non-timestamp)) - output-time - oldtime)) - (file-attribute-modification-time - (file-attributes file)))) - ;; File hasn't changed. - nil) - (t - (setq changed t) - (autoload-remove-section (match-beginning 0)) - (if (autoload-generate-file-autoloads - ;; Passing `current-buffer' makes it insert at point. - file (current-buffer) buffer-file-name) - (push file no-autoloads)))) - (push file done) - (setq files (delete file files))))) - ;; Elements remaining in FILES have no existing autoload sections yet. - (let ((no-autoloads-time (or last-time '(0 0 0 0))) - (progress (make-progress-reporter - (byte-compile-info - (concat "Scraping files for " - (file-relative-name output-file))) - 0 (length files) nil 10)) - (file-count 0) - file-time) - (dolist (file files) - (progress-reporter-update progress (setq file-count (1+ file-count))) - (cond - ;; Passing nil as second argument forces - ;; autoload-generate-file-autoloads to look for the right - ;; spot where to insert each autoloads section. - ((setq file-time - (autoload-generate-file-autoloads file nil buffer-file-name)) - (push file no-autoloads) - (if (time-less-p no-autoloads-time file-time) - (setq no-autoloads-time file-time))) - (t (setq changed t)))) - (progress-reporter-done progress) - - (when no-autoloads - ;; Sort them for better readability. - (setq no-autoloads (sort no-autoloads 'string<)) - ;; Add the `no-autoloads' section. - (goto-char (point-max)) - (search-backward "\f" nil t) - (autoload-insert-section-header - (current-buffer) nil nil - ;; Filter out the other loaddefs files, because it makes - ;; the list unstable (and leads to spurious changes in - ;; ldefs-boot.el) since the loaddef files can be created in - ;; any order. - (seq-filter (lambda (file) - (not (string-match-p "[/-]loaddefs.el" file))) - no-autoloads) - (if autoload-timestamps - no-autoloads-time - autoload--non-timestamp)) - (insert generate-autoload-section-trailer))) - - ;; Don't modify the file if its content has not been changed, so `make' - ;; dependencies don't trigger unnecessarily. - (if (not changed) - (set-buffer-modified-p nil) - (autoload--save-buffer)) - - ;; In case autoload entries were added to other files because of - ;; file-local autoload-generated-file settings. - (autoload-save-buffers)))) - -(defun batch-update-autoloads--summary (strings) - (let ((message "")) - (while strings - (when (> (length (concat message " " (car strings))) 64) - (byte-compile-info (concat message " ...") t "SCRAPE") - (setq message "")) - (setq message (if (zerop (length message)) - (car strings) - (concat message " " (car strings)))) - (setq strings (cdr strings))) - (when (> (length message) 0) - (byte-compile-info message t "SCRAPE")))) - -;;;###autoload -(defun batch-update-autoloads () - "Update loaddefs.el autoloads in batch mode. -Calls `update-directory-autoloads' on the command line arguments. -Definitions are written to `generated-autoload-file' (which -should be non-nil)." - ;; For use during the Emacs build process only. - ;; Exclude those files that are preloaded on ALL platforms. - ;; These are the ones in loadup.el where "(load" is at the start - ;; of the line (crude, but it works). - (unless autoload-excludes - (let ((default-directory (file-name-directory generated-autoload-file)) - file) - (when (file-readable-p "loadup.el") - (with-temp-buffer - (insert-file-contents "loadup.el") - (while (re-search-forward "^(load \"\\([^\"]+\\)\"" nil t) - (setq file (match-string 1)) - (or (string-match "\\.el\\'" file) - (setq file (format "%s.el" file))) - (or (string-match "\\`site-" file) - (push (expand-file-name file) autoload-excludes))))))) - (let ((args command-line-args-left)) - (batch-update-autoloads--summary args) - (setq command-line-args-left nil) - (make-directory-autoloads args generated-autoload-file))) - -(provide 'autoload) - -;;; autoload.el ends here diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el index 3231877a30c..70473770d16 100644 --- a/lisp/emacs-lisp/backtrace.el +++ b/lisp/emacs-lisp/backtrace.el @@ -58,7 +58,8 @@ Backtrace mode will attempt to abbreviate printing of backtrace frames by setting `print-level' and `print-length' to make them shorter than this, but success is not guaranteed. If set to nil or zero, backtrace mode will not abbreviate the forms it prints." - :type 'integer + :type '(choice natnum + (const :value nil :tag "Don't abbreviate")) :group 'backtrace :version "27.1") @@ -199,63 +200,63 @@ functions returns non-nil. When adding a function to this hook, you should also set the :source-available flag for the backtrace frames where the source code location is known.") -(defvar backtrace-mode-map - (let ((map (copy-keymap special-mode-map))) - (set-keymap-parent map button-buffer-map) - (define-key map "n" 'backtrace-forward-frame) - (define-key map "p" 'backtrace-backward-frame) - (define-key map "v" 'backtrace-toggle-locals) - (define-key map "#" 'backtrace-toggle-print-circle) - (define-key map ":" 'backtrace-toggle-print-gensym) - (define-key map "s" 'backtrace-goto-source) - (define-key map "\C-m" 'backtrace-help-follow-symbol) - (define-key map "+" 'backtrace-multi-line) - (define-key map "-" 'backtrace-single-line) - (define-key map "." 'backtrace-expand-ellipses) - (define-key map [follow-link] 'mouse-face) - (define-key map [mouse-2] 'mouse-select-window) - (easy-menu-define nil map "" - '("Backtrace" - ["Next Frame" backtrace-forward-frame - :help "Move cursor forwards to the start of a backtrace frame"] - ["Previous Frame" backtrace-backward-frame - :help "Move cursor backwards to the start of a backtrace frame"] - "--" - ["Show Variables" backtrace-toggle-locals - :style toggle - :active (backtrace-get-index) - :selected (plist-get (backtrace-get-view) :show-locals) - :help "Show or hide the local variables for the frame at point"] - ["Show Circular Structures" backtrace-toggle-print-circle - :style toggle - :active (backtrace-get-index) - :selected (plist-get (backtrace-get-view) :print-circle) - :help - "Condense or expand shared or circular structures in the frame at point"] - ["Show Uninterned Symbols" backtrace-toggle-print-gensym - :style toggle - :active (backtrace-get-index) - :selected (plist-get (backtrace-get-view) :print-gensym) - :help - "Toggle unique printing of uninterned symbols in the frame at point"] - ["Expand \"...\"s" backtrace-expand-ellipses - :help "Expand all the abbreviated forms in the current frame"] - ["Show on Multiple Lines" backtrace-multi-line - :help "Use line breaks and indentation to make a form more readable"] - ["Show on Single Line" backtrace-single-line] - "--" - ["Go to Source" backtrace-goto-source - :active (and (backtrace-get-index) - (plist-get (backtrace-frame-flags - (nth (backtrace-get-index) backtrace-frames)) - :source-available)) - :help "Show the source code for the current frame"] - ["Help for Symbol" backtrace-help-follow-symbol - :help "Show help for symbol at point"] - ["Describe Backtrace Mode" describe-mode - :help "Display documentation for backtrace-mode"])) - map) - "Local keymap for `backtrace-mode' buffers.") +(defvar-keymap backtrace-mode-map + :doc "Local keymap for `backtrace-mode' buffers." + :parent (make-composed-keymap special-mode-map + button-buffer-map) + "n" #'backtrace-forward-frame + "p" #'backtrace-backward-frame + "v" #'backtrace-toggle-locals + "#" #'backtrace-toggle-print-circle + ":" #'backtrace-toggle-print-gensym + "s" #'backtrace-goto-source + "RET" #'backtrace-help-follow-symbol + "+" #'backtrace-multi-line + "-" #'backtrace-single-line + "." #'backtrace-expand-ellipses + "<follow-link>" 'mouse-face + "<mouse-2>" #'mouse-select-window + + :menu + '("Backtrace" + ["Next Frame" backtrace-forward-frame + :help "Move cursor forwards to the start of a backtrace frame"] + ["Previous Frame" backtrace-backward-frame + :help "Move cursor backwards to the start of a backtrace frame"] + "--" + ["Show Variables" backtrace-toggle-locals + :style toggle + :active (backtrace-get-index) + :selected (plist-get (backtrace-get-view) :show-locals) + :help "Show or hide the local variables for the frame at point"] + ["Show Circular Structures" backtrace-toggle-print-circle + :style toggle + :active (backtrace-get-index) + :selected (plist-get (backtrace-get-view) :print-circle) + :help + "Condense or expand shared or circular structures in the frame at point"] + ["Show Uninterned Symbols" backtrace-toggle-print-gensym + :style toggle + :active (backtrace-get-index) + :selected (plist-get (backtrace-get-view) :print-gensym) + :help + "Toggle unique printing of uninterned symbols in the frame at point"] + ["Expand \"...\"s" backtrace-expand-ellipses + :help "Expand all the abbreviated forms in the current frame"] + ["Show on Multiple Lines" backtrace-multi-line + :help "Use line breaks and indentation to make a form more readable"] + ["Show on Single Line" backtrace-single-line] + "--" + ["Go to Source" backtrace-goto-source + :active (and (backtrace-get-index) + (plist-get (backtrace-frame-flags + (nth (backtrace-get-index) backtrace-frames)) + :source-available)) + :help "Show the source code for the current frame"] + ["Help for Symbol" backtrace-help-follow-symbol + :help "Show help for symbol at point"] + ["Describe Backtrace Mode" describe-mode + :help "Display documentation for backtrace-mode"])) (defconst backtrace--flags-width 2 "Width in characters of the flags for a backtrace frame.") @@ -590,7 +591,7 @@ content of the sexp." (begin (previous-single-property-change end 'backtrace-form nil (point-min)))) (unless tag - (when (or (= end (point-max)) (> end (point-at-eol))) + (when (or (= end (point-max)) (> end (line-end-position))) (user-error "No form here to reformat")) (goto-char end) (setq pos end diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 9ba89a5e3fe..0ecac3d52aa 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -440,17 +440,26 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (aset bindat-raw (+ bindat-idx i) (aref v i))) (setq bindat-idx (+ bindat-idx len)))) -(defun bindat--pack-strz (v) +(defun bindat--pack-strz (len v) (let* ((v (string-to-unibyte v)) - (len (length v))) - (dotimes (i len) - (when (= (aref v i) 0) - ;; Alternatively we could pretend that this was the end of - ;; the string and stop packing, but then bindat-length would - ;; need to scan the input string looking for a null byte. - (error "Null byte encountered in input strz string")) - (aset bindat-raw (+ bindat-idx i) (aref v i))) - (setq bindat-idx (+ bindat-idx len 1)))) + (vlen (length v))) + ;; Explicitly write a null terminator (if there's room) in case + ;; the user provided a pre-allocated string to `bindat-pack' that + ;; wasn't already zeroed. + (when (or (null len) (< vlen len)) + (aset bindat-raw (+ bindat-idx vlen) 0)) + (if len + ;; When len is specified, behave the same as the str type + ;; (except for the null terminator possibly written above). + (bindat--pack-str len v) + (dotimes (i vlen) + (when (= (aref v i) 0) + ;; Alternatively we could pretend that this was the end of + ;; the string and stop packing, but then bindat-length would + ;; need to scan the input string looking for a null byte. + (error "Null byte encountered in input strz string")) + (aset bindat-raw (+ bindat-idx i) (aref v i))) + (setq bindat-idx (+ bindat-idx vlen 1))))) (defun bindat--pack-bits (len v) (let ((bnum (1- (* 8 len))) j m) @@ -479,7 +488,8 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." ('u24r (bindat--pack-u24r v)) ('u32r (bindat--pack-u32r v)) ('bits (bindat--pack-bits len v)) - ((or 'str 'strz) (bindat--pack-str len v)) + ('str (bindat--pack-str len v)) + ('strz (bindat--pack-strz len v)) ('vec (let ((l (length v)) (vlen 1)) (if (consp vectype) @@ -696,18 +706,7 @@ is the name of a variable that will hold the value we need to pack.") ((numberp len) len) ;; General expression support. (t `(or ,len (1+ (length ,val))))))) - (`(pack . ,args) - ;; When len is specified, behave the same as the str type since we don't - ;; actually add the terminating zero anyway (because we rely on the fact - ;; that `bindat-raw' was presumably initialized with all-zeroes before we - ;; started). - (cond ; Same optimizations as 'length above. - ((null len) `(bindat--pack-strz . ,args)) - ((numberp len) `(bindat--pack-str ,len . ,args)) - (t (macroexp-let2 nil len len - `(if ,len - (bindat--pack-str ,len . ,args) - (bindat--pack-strz . ,args)))))))) + (`(pack . ,args) `(bindat--pack-strz ,len . ,args)))) (cl-defmethod bindat--type (op (_ (eql 'bits)) len) (bindat--pcase op diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index fc49e88f8ee..27b0d33d3ef 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -171,7 +171,7 @@ Earlier variables shadow later ones with the same name.") (if (eq fn localfn) ;; From the same file => same mode. (macroexp--unfold-lambda `(,fn ,@(cdr form))) - ;; Since we are called from inside the optimiser, we need to make + ;; Since we are called from inside the optimizer, we need to make ;; sure not to propagate lexvar values. (let ((byte-optimize--lexvars nil) ;; Silence all compilation warnings: the useful ones should @@ -204,7 +204,7 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") This indicates the loop discovery phase.") (defvar byte-optimize--dynamic-vars nil - "List of variables declared as dynamic during optimisation.") + "List of variables declared as dynamic during optimization.") (defvar byte-optimize--aliased-vars nil "List of variables which may be aliased by other lexical variables. @@ -315,7 +315,7 @@ for speeding up processing.") (`(cond . ,clauses) ;; FIXME: The condition in the first clause is always executed, and ;; clause bodies are mutually exclusive -- use this for improved - ;; optimisation (see comment about `if' below). + ;; optimization (see comment about `if' below). (cons fn (mapcar (lambda (clause) (if (consp clause) @@ -364,9 +364,9 @@ for speeding up processing.") ;; FIXME: We have to traverse the expressions in left-to-right ;; order (because that is the order of evaluation and variable ;; mutations must be found prior to their use), but doing so we miss - ;; some optimisation opportunities: + ;; some optimization opportunities: ;; consider (and A B) in a for-effect context, where B => nil. - ;; Then A could be optimised in a for-effect context too. + ;; Then A could be optimized in a for-effect context too. (let ((tail exps) (args nil)) (while tail @@ -380,19 +380,19 @@ for speeding up processing.") ;; FIXME: If the loop condition is statically nil after substitution ;; of surrounding variables then we can eliminate the whole loop, ;; even if those variables are mutated inside the loop. - ;; We currently don't perform this important optimisation. + ;; We currently don't perform this important optimization. (let* ((byte-optimize--vars-outside-loop byte-optimize--lexvars) (condition-body (if byte-optimize--inhibit-outside-loop-constprop ;; We are already inside the discovery phase of an outer ;; loop so there is no need for traversing this loop twice. (cons exp exps) - ;; Discovery phase: run optimisation without substitution + ;; Discovery phase: run optimization without substitution ;; of variables bound outside this loop. (let ((byte-optimize--inhibit-outside-loop-constprop t)) (cons (byte-optimize-form exp nil) (byte-optimize-body exps t))))) - ;; Optimise again, this time with constprop enabled (unless + ;; Optimize again, this time with constprop enabled (unless ;; we are in discovery of an outer loop), ;; as mutated variables have been marked as non-substitutable. (condition (byte-optimize-form (car condition-body) nil)) @@ -406,7 +406,7 @@ for speeding up processing.") (`(function . ,_) ;; This forms is compiled as constant or by breaking out ;; all the subexpressions and compiling them separately. - form) + (and (not for-effect) form)) (`(condition-case ,var ,exp . ,clauses) `(,fn ,var ;Not evaluated. @@ -422,15 +422,13 @@ for speeding up processing.") (byte-optimize-body (cdr clause) for-effect)))) clauses))) - (`(unwind-protect ,exp :fun-body ,f) - ;; The unwinding part of an unwind-protect is compiled (and thus - ;; optimized) as a top-level form, but run the optimizer for it here - ;; anyway for lexical variable usage and substitution. But the - ;; protected part has the same for-effect status as the - ;; unwind-protect itself. (The unwinding part is always for effect, - ;; but that isn't handled properly yet.) - (let ((bodyform (byte-optimize-form exp for-effect))) - `(,fn ,bodyform :fun-body ,(byte-optimize-form f nil)))) + ;; `unwind-protect' is a special form which here takes the shape + ;; (unwind-protect EXPR :fun-body UNWIND-FUN). + ;; We can treat it as if it were a plain function at this point, + ;; although there are specific optimizations possible. + ;; In particular, the return value of UNWIND-FUN is never used + ;; so its body should really be compiled for-effect, but we + ;; don't do that right now. (`(catch ,tag . ,exps) `(,fn ,(byte-optimize-form tag nil) @@ -438,13 +436,15 @@ for speeding up processing.") ;; Needed as long as we run byte-optimize-form after cconv. (`(internal-make-closure . ,_) + (and (not for-effect) + (progn ;; Look up free vars and mark them to be kept, so that they - ;; won't be optimised away. + ;; won't be optimized away. (dolist (var (caddr form)) (let ((lexvar (assq var byte-optimize--lexvars))) (when lexvar (setcar (cdr lexvar) t)))) - form) + form))) (`((lambda . ,_) . ,_) (let ((newform (macroexp--unfold-lambda form))) @@ -513,7 +513,7 @@ for speeding up processing.") (defun byte-optimize-one-form (form &optional for-effect) "The source-level pass of the optimizer." - ;; Make optimiser aware of lexical arguments. + ;; Make optimizer aware of lexical arguments. (let ((byte-optimize--lexvars (mapcar (lambda (v) (list (car v) t)) byte-compile--lexical-environment))) @@ -525,7 +525,7 @@ for speeding up processing.") ;; First, optimize all sub-forms of this one. (setq form (byte-optimize-form-code-walker form for-effect)) - ;; If a form-specific optimiser is available, run it and start over + ;; If a form-specific optimizer is available, run it and start over ;; until a fixpoint has been reached. (and (consp form) (symbolp (car form)) @@ -722,35 +722,108 @@ for speeding up processing.") ;; something not EQ to its argument if and ONLY if it has made a change. ;; This implies that you cannot simply destructively modify the list; ;; you must return something not EQ to it if you make an optimization. -;; -;; It is now safe to optimize code such that it introduces new bindings. -(defsubst byte-compile-trueconstp (form) +(defsubst byte-opt--bool-value-form (form) + "The form in FORM that yields its boolean value, possibly FORM itself." + (while (let ((head (car-safe form))) + (cond ((memq head '( progn inline save-excursion save-restriction + save-current-buffer)) + (setq form (car (last (cdr form)))) + t) + ((memq head '(let let*)) + (setq form (car (last (cddr form)))) + t) + ((memq head '( prog1 unwind-protect copy-sequence identity + reverse nreverse sort)) + (setq form (nth 1 form)) + t) + ((memq head '(mapc setq setcar setcdr puthash)) + (setq form (nth 2 form)) + t) + ((memq head '(aset put function-put)) + (setq form (nth 3 form)) + t)))) + form) + +(defun byte-compile-trueconstp (form) "Return non-nil if FORM always evaluates to a non-nil value." - (while (eq (car-safe form) 'progn) - (setq form (car (last (cdr form))))) + (setq form (byte-opt--bool-value-form form)) (cond ((consp form) - (pcase (car form) - ('quote (cadr form)) - ;; Can't use recursion in a defsubst. - ;; (`progn (byte-compile-trueconstp (car (last (cdr form))))) - )) + (let ((head (car form))) + ;; FIXME: Lots of other expressions are statically non-nil. + (cond ((memq head '(quote function)) (cadr form)) + ((eq head 'list) (cdr form)) + ((memq head + ;; FIXME: Replace this list with a function property? + '( length safe-length cons lambda + string unibyte-string make-string concat + format format-message + substring substring-no-properties string-replace + replace-regexp-in-string symbol-name make-symbol + compare-strings string-distance + mapconcat + vector make-vector vconcat make-record record + regexp-quote regexp-opt + buffer-string buffer-substring + buffer-substring-no-properties + current-buffer buffer-size get-buffer-create + point point-min point-max buffer-end count-lines + following-char preceding-char get-byte max-char + region-beginning region-end + line-beginning-position line-end-position + pos-bol pos-eol + + - * / % 1+ 1- min max abs mod expt logb + logand logior logxor lognot ash logcount + floor ceiling round truncate + sqrt sin cos tan asin acos atan exp log copysign + ffloor fceiling fround ftruncate float + ldexp frexp + number-to-string string-to-number + int-to-string char-to-string + prin1-to-string read-from-string + byte-to-string string-to-vector string-to-char + capitalize upcase downcase + propertize + string-as-multibyte string-as-unibyte + string-to-multibyte string-to-unibyte + string-make-multibyte string-make-unibyte + string-width char-width + make-hash-table hash-table-count + unibyte-char-to-multibyte multibyte-char-to-unibyte + sxhash sxhash-equal sxhash-eq sxhash-eql + sxhash-equal-including-properties + make-marker copy-marker point-marker mark-marker + kbd key-description + always)) + t) + ((eq head 'if) + (and (byte-compile-trueconstp (nth 2 form)) + (byte-compile-trueconstp (car (last (cdddr form)))))) + ((memq head '(not null)) + (byte-compile-nilconstp (cadr form))) + ((eq head 'or) + (and (cdr form) + (byte-compile-trueconstp (car (last (cdr form))))))))) ((not (symbolp form))) ((eq form t)) ((keywordp form)))) -(defsubst byte-compile-nilconstp (form) +(defun byte-compile-nilconstp (form) "Return non-nil if FORM always evaluates to a nil value." - (while (eq (car-safe form) 'progn) - (setq form (car (last (cdr form))))) - (cond ((consp form) - (pcase (car form) - ('quote (null (cadr form))) - ;; Can't use recursion in a defsubst. - ;; (`progn (byte-compile-nilconstp (car (last (cdr form))))) - )) - ((not (symbolp form)) nil) - ((null form)))) + (setq form (byte-opt--bool-value-form form)) + (or (not form) ; assume (quote nil) always being normalised to nil + (and (consp form) + (let ((head (car form))) + ;; FIXME: There are many other expressions that are statically nil. + (cond ((memq head '(while ignore)) t) + ((eq head 'if) + (and (byte-compile-nilconstp (nth 2 form)) + (byte-compile-nilconstp (car (last (cdddr form)))))) + ((memq head '(not null)) + (byte-compile-trueconstp (cadr form))) + ((eq head 'and) + (and (cdr form) + (byte-compile-nilconstp (car (last (cdr form))))))))))) ;; If the function is being called with constant integer args, ;; evaluate as much as possible at compile-time. This optimizer @@ -921,7 +994,7 @@ for speeding up processing.") (defun byte-optimize--fixnump (o) "Return whether O is guaranteed to be a fixnum in all Emacsen. See Info node `(elisp) Integer Basics'." - (and (fixnump o) (<= -536870912 o 536870911))) + (and (integerp o) (<= -536870912 o 536870911))) (defun byte-optimize-equal (form) ;; Replace `equal' or `eql' with `eq' if at least one arg is a @@ -1077,35 +1150,91 @@ See Info node `(elisp) Integer Basics'." (nth 1 form))) (defun byte-optimize-and (form) - ;; Simplify if less than 2 args. - ;; if there is a literal nil in the args to `and', throw it and following - ;; forms away, and surround the `and' with (progn ... nil). - (cond ((null (cdr form))) - ((memq nil form) - (list 'progn - (byte-optimize-and - (prog1 (setq form (copy-sequence form)) - (while (nth 1 form) - (setq form (cdr form))) - (setcdr form nil))) - nil)) - ((null (cdr (cdr form))) - (nth 1 form)) - ((byte-optimize-constant-args form)))) + (let ((seq nil) + (new-args nil) + (nil-result nil) + (args (cdr form))) + (while + (and args + (let ((arg (car args))) + (cond + (seq ; previous arg was always-true + (push arg seq) + (unless (and (cdr args) (byte-compile-trueconstp arg)) + (push `(progn . ,(nreverse seq)) new-args) + (setq seq nil)) + t) + ((and (cdr args) (byte-compile-trueconstp arg)) + ;; Always-true arg: evaluate unconditionally. + (push arg seq) + t) + ((and arg (not (byte-compile-nilconstp arg))) + (push arg new-args) + t) + (t + ;; Throw away the remaining args; this one is always false. + (setq nil-result t) + (when arg + (push arg new-args)) ; keep possible side-effects + nil)))) + (setq args (cdr args))) + + (setq new-args (nreverse new-args)) + (if (equal new-args (cdr form)) + ;; Input is unchanged: keep original form, and don't represent + ;; a nil result explicitly because that would lead to infinite + ;; growth when the optimiser is iterated. + (setq nil-result nil) + (setq form (cons (car form) new-args))) + + (let ((new-form + (pcase form + ;; (and (progn ... X) ...) -> (progn ... (and X ...)) + (`(,head (progn . ,forms) . ,rest) + `(progn ,@(butlast forms) (,head ,(car (last forms)) . ,rest))) + (`(,_) t) ; (and) -> t + (`(,_ ,arg) arg) ; (and X) -> X + (_ (byte-optimize-constant-args form))))) + (if nil-result + `(progn ,new-form nil) + new-form)))) (defun byte-optimize-or (form) - ;; Throw away nil's, and simplify if less than 2 args. - ;; If there is a literal non-nil constant in the args to `or', throw away all - ;; following forms. - (setq form (remq nil form)) - (let ((rest form)) - (while (cdr (setq rest (cdr rest))) - (if (byte-compile-trueconstp (car rest)) - (setq form (copy-sequence form) - rest (setcdr (memq (car rest) form) nil)))) - (if (cdr (cdr form)) - (byte-optimize-constant-args form) - (nth 1 form)))) + (let ((seq nil) + (new-args nil) + (args (remq nil (cdr form)))) ; Discard nil arguments. + (while + (and args + (let ((arg (car args))) + (cond + (seq ; previous arg was always-false + (push arg seq) + (unless (and (cdr args) (byte-compile-nilconstp arg)) + (push `(progn . ,(nreverse seq)) new-args) + (setq seq nil)) + t) + ((and (cdr args) (byte-compile-nilconstp arg)) + ;; Always-false arg: evaluate unconditionally. + (push arg seq) + t) + (t + (push arg new-args) + ;; If this arg is always true, throw away the remaining args. + (not (byte-compile-trueconstp arg)))))) + (setq args (cdr args))) + + (setq new-args (nreverse new-args)) + ;; Keep original form unless the arguments changed. + (unless (equal new-args (cdr form)) + (setq form (cons (car form) new-args))) + + (pcase form + ;; (or (progn ... X) ...) -> (progn ... (or X ...)) + (`(,head (progn . ,forms) . ,rest) + `(progn ,@(butlast forms) (,head ,(car (last forms)) . ,rest))) + (`(,_) nil) ; (or) -> nil + (`(,_ ,arg) arg) ; (or X) -> X + (_ (byte-optimize-constant-args form))))) (defun byte-optimize-cond (form) ;; if any clauses have a literal nil as their test, throw them away. @@ -1142,55 +1271,79 @@ See Info node `(elisp) Integer Basics'." (and clauses form))) form)) +(defsubst byte-opt--negate (form) + "Negate FORM, avoiding double negation if already negated." + (if (and (consp form) (memq (car form) '(not null))) + (cadr form) + `(not ,form))) + (defun byte-optimize-if (form) - ;; (if (progn <insts> <test>) <rest>) ==> (progn <insts> (if <test> <rest>)) - ;; (if <true-constant> <then> <else...>) ==> <then> - ;; (if <false-constant> <then> <else...>) ==> (progn <else...>) - ;; (if <test> nil <else...>) ==> (if (not <test>) (progn <else...>)) - ;; (if <test> <then> nil) ==> (if <test> <then>) - (let ((clause (nth 1 form))) - (cond ((and (eq (car-safe clause) 'progn) - (proper-list-p clause)) - (if (null (cddr clause)) - ;; A trivial `progn'. - (byte-optimize-if `(,(car form) ,(cadr clause) ,@(nthcdr 2 form))) - (nconc (butlast clause) - (list - (byte-optimize-if - `(,(car form) ,(car (last clause)) ,@(nthcdr 2 form))))))) - ((byte-compile-trueconstp clause) - `(progn ,clause ,(nth 2 form))) - ((byte-compile-nilconstp clause) - `(progn ,clause ,@(nthcdr 3 form))) - ((nth 2 form) - (if (equal '(nil) (nthcdr 3 form)) - (list (car form) clause (nth 2 form)) - form)) - ((or (nth 3 form) (nthcdr 4 form)) - (list (car form) - ;; Don't make a double negative; - ;; instead, take away the one that is there. - (if (and (consp clause) (memq (car clause) '(not null)) - (= (length clause) 2)) ; (not xxxx) or (not (xxxx)) - (nth 1 clause) - (list 'not clause)) - (if (nthcdr 4 form) - (cons 'progn (nthcdr 3 form)) - (nth 3 form)))) - (t - (list 'progn clause nil))))) + (let ((condition (nth 1 form)) + (then (nth 2 form)) + (else (nthcdr 3 form))) + (cond + ;; (if (progn ... X) ...) -> (progn ... (if X ...)) + ((eq (car-safe condition) 'progn) + (nconc (butlast condition) + (list + (byte-optimize-if + `(,(car form) ,(car (last condition)) ,@(nthcdr 2 form)))))) + ;; (if TRUE THEN ...) -> (progn TRUE THEN) + ((byte-compile-trueconstp condition) + `(progn ,condition ,then)) + ;; (if FALSE THEN ELSE...) -> (progn FALSE ELSE...) + ((byte-compile-nilconstp condition) + (if else + `(progn ,condition ,@else) + condition)) + ;; (if X nil t) -> (not X) + ((and (eq then nil) (eq else '(t))) + `(not ,condition)) + ;; (if X t [nil]) -> (not (not X)) + ((and (eq then t) (or (null else) (eq else '(nil)))) + `(not ,(byte-opt--negate condition))) + ;; (if VAR VAR X...) -> (or VAR (progn X...)) + ((and (symbolp condition) (eq condition then)) + `(or ,then ,(if (cdr else) + `(progn . ,else) + (car else)))) + ;; (if X THEN nil) -> (if X THEN) + (then + (if (equal else '(nil)) + (list (car form) condition then) + form)) + ;; (if X nil ELSE...) -> (if (not X) (progn ELSE...)) + ((or (car else) (cdr else)) + (list (car form) (byte-opt--negate condition) + (if (cdr else) + `(progn . ,else) + (car else)))) + ;; (if X nil nil) -> (progn X nil) + (t + (list 'progn condition nil))))) (defun byte-optimize-while (form) - (when (< (length form) 2) - (byte-compile-warn-x form "too few arguments for `while'")) - (if (nth 1 form) - form)) + (let ((condition (nth 1 form))) + (if (byte-compile-nilconstp condition) + condition + form))) + +(defun byte-optimize-not (form) + (and (= (length form) 2) + (let ((arg (nth 1 form))) + (cond ((null arg) t) + ((macroexp-const-p arg) nil) + ((byte-compile-nilconstp arg) `(progn ,arg t)) + ((byte-compile-trueconstp arg) `(progn ,arg nil)) + (t form))))) (put 'and 'byte-optimizer #'byte-optimize-and) (put 'or 'byte-optimizer #'byte-optimize-or) (put 'cond 'byte-optimizer #'byte-optimize-cond) (put 'if 'byte-optimizer #'byte-optimize-if) (put 'while 'byte-optimizer #'byte-optimize-while) +(put 'not 'byte-optimizer #'byte-optimize-not) +(put 'null 'byte-optimizer #'byte-optimize-not) ;; byte-compile-negation-optimizer lives in bytecomp.el (put '/= 'byte-optimizer #'byte-compile-negation-optimizer) @@ -1207,25 +1360,26 @@ See Info node `(elisp) Integer Basics'." form))) (defun byte-optimize-apply (form) - ;; If the last arg is a literal constant, turn this into a funcall. - ;; The funcall optimizer can then transform (funcall 'foo ...) -> (foo ...). - (if (= (length form) 2) - ;; single-argument `apply' is not worth optimizing (bug#40968) - form - (let ((fn (nth 1 form)) - (last (nth (1- (length form)) form))) ; I think this really is fastest - (or (if (or (null last) - (eq (car-safe last) 'quote)) - (if (listp (nth 1 last)) - (let ((butlast (nreverse (cdr (reverse (cdr (cdr form))))))) - (nconc (list 'funcall fn) butlast - (mapcar (lambda (x) (list 'quote x)) (nth 1 last)))) + (let ((len (length form))) + (if (>= len 2) + (let ((fn (nth 1 form)) + (last (nth (1- len) form))) + (cond + ;; (apply F ... '(X Y ...)) -> (funcall F ... 'X 'Y ...) + ((or (null last) + (eq (car-safe last) 'quote)) + (let ((last-value (nth 1 last))) + (if (listp last-value) + `(funcall ,fn ,@(butlast (cddr form)) + ,@(mapcar (lambda (x) (list 'quote x)) last-value)) (byte-compile-warn-x - last - "last arg to apply can't be a literal atom: `%s'" - last) - nil)) - form)))) + last "last arg to apply can't be a literal atom: `%s'" last) + nil))) + ;; (apply F ... (list X Y ...)) -> (funcall F ... X Y ...) + ((eq (car-safe last) 'list) + `(funcall ,fn ,@(butlast (cddr form)) ,@(cdr last))) + (t form))) + form))) (put 'funcall 'byte-optimizer #'byte-optimize-funcall) (put 'apply 'byte-optimizer #'byte-optimize-apply) @@ -1281,15 +1435,99 @@ See Info node `(elisp) Integer Basics'." (put 'cons 'byte-optimizer #'byte-optimize-cons) (defun byte-optimize-cons (form) - ;; (cons X nil) => (list X) - (if (and (= (safe-length form) 3) - (null (nth 2 form))) - `(list ,(nth 1 form)) - form)) + (let ((tail (nth 2 form))) + (cond + ;; (cons X nil) => (list X) + ((null tail) `(list ,(nth 1 form))) + ;; (cons X (list YS...)) -> (list X YS...) + ((and (consp tail) (eq (car tail) 'list)) + `(,(car tail) ,(nth 1 form) . ,(cdr tail))) + (t form)))) + +(put 'list 'byte-optimizer #'byte-optimize-list) +(defun byte-optimize-list (form) + ;; (list) -> nil + (and (cdr form) form)) + +(put 'append 'byte-optimizer #'byte-optimize-append) +(defun byte-optimize-append (form) + ;; There is (probably) too much code relying on `append' to return a + ;; new list for us to do full constant-folding; these transformations + ;; preserve the allocation semantics. + (and (cdr form) ; (append) -> nil + (named-let loop ((args (cdr form)) (newargs nil)) + (let ((arg (car args)) + (prev (car newargs))) + (cond + ;; Flatten nested `append' forms. + ((and (consp arg) (eq (car arg) 'append)) + (loop (append (cdr arg) (cdr args)) newargs)) + + ;; Merge consecutive `list' forms. + ((and (consp arg) (eq (car arg) 'list) + newargs (consp prev) (eq (car prev) 'list)) + (loop (cons (cons (car prev) (append (cdr prev) (cdr arg))) + (cdr args)) + (cdr newargs))) + + ;; non-terminal arg + ((cdr args) + (cond + ((macroexp-const-p arg) + ;; constant arg + (let ((val (eval arg))) + (cond + ;; Elide empty arguments (nil, empty string, etc). + ((zerop (length val)) + (loop (cdr args) newargs)) + ;; Merge consecutive constants. + ((and newargs (macroexp-const-p prev)) + (loop (cdr args) + (cons + (list 'quote + (append (eval prev) val nil)) + (cdr newargs)))) + (t (loop (cdr args) (cons arg newargs)))))) + + ;; (list CONSTANTS...) -> '(CONSTANTS...) + ((and (consp arg) (eq (car arg) 'list) + (not (memq nil (mapcar #'macroexp-const-p (cdr arg))))) + (loop (cons (list 'quote (eval arg)) (cdr args)) newargs)) + + (t (loop (cdr args) (cons arg newargs))))) + + ;; At this point, `arg' is the last (tail) argument. + + ;; (append X) -> X + ((null newargs) arg) + + ;; (append (list Xs...) nil) -> (list Xs...) + ((and (null arg) + newargs (null (cdr newargs)) + (consp prev) (eq (car prev) 'list)) + prev) + + ;; (append '(X) Y) -> (cons 'X Y) + ;; (append (list X) Y) -> (cons X Y) + ((and newargs (null (cdr newargs)) + (consp prev) + (cond ((eq (car prev) 'quote) + (and (consp (cadr prev)) + (= (length (cadr prev)) 1))) + ((eq (car prev) 'list) + (= (length (cdr prev)) 1)))) + (list 'cons (if (eq (car prev) 'quote) + (macroexp-quote (caadr prev)) + (cadr prev)) + arg)) + + (t + (let ((new-form (cons 'append (nreverse (cons arg newargs))))) + (if (equal new-form form) + form + new-form)))))))) ;; Fixme: delete-char -> delete-region (byte-coded) -;; optimize string-as-unibyte, string-as-multibyte, string-make-unibyte, -;; string-make-multibyte for constant args. (put 'set 'byte-optimizer #'byte-optimize-set) (defun byte-optimize-set (form) @@ -1354,28 +1592,27 @@ See Info node `(elisp) Integer Basics'." keymap-parent lax-plist-get ldexp length length< length> length= - line-beginning-position line-end-position + line-beginning-position line-end-position pos-bol pos-eol local-variable-if-set-p local-variable-p locale-info log log10 logand logb logcount logior lognot logxor lsh make-byte-code make-list make-string make-symbol mark marker-buffer max match-beginning match-end member memq memql min minibuffer-selected-window minibuffer-window mod multibyte-char-to-unibyte next-window nth nthcdr number-to-string - parse-colon-path plist-get plist-member + parse-colon-path prefix-numeric-value previous-window prin1-to-string propertize degrees-to-radians radians-to-degrees rassq rassoc read-from-string regexp-opt regexp-quote region-beginning region-end reverse round sin sqrt string string< string= string-equal string-lessp - string> string-greaterp string-empty-p - string-prefix-p string-suffix-p string-blank-p + string> string-greaterp string-empty-p string-blank-p string-search string-to-char string-to-number string-to-syntax substring sxhash sxhash-equal sxhash-eq sxhash-eql symbol-function symbol-name symbol-plist symbol-value string-make-unibyte string-make-multibyte string-as-multibyte string-as-unibyte string-to-multibyte - tan time-convert truncate + take tan time-convert truncate unibyte-char-to-multibyte upcase user-full-name user-login-name user-original-login-name custom-variable-p vconcat @@ -1388,7 +1625,7 @@ See Info node `(elisp) Integer Basics'." 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-prev-sibling window-redisplay-end-trigger window-scroll-bars + window-prev-sibling 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 window-width zerop)) @@ -1416,7 +1653,7 @@ See Info node `(elisp) Integer Basics'." natnump nlistp not null number-or-marker-p numberp one-window-p overlayp point point-marker point-min point-max preceding-char primary-charset - processp + processp proper-list-p recent-keys recursion-depth safe-length selected-frame selected-window sequencep standard-case-table standard-syntax-table stringp subrp symbolp @@ -1461,7 +1698,7 @@ See Info node `(elisp) Integer Basics'." floor ceiling round truncate ffloor fceiling fround ftruncate string= string-equal string< string-lessp string> string-greaterp - string-empty-p string-blank-p string-prefix-p string-suffix-p + string-empty-p string-blank-p string-search consp atom listp nlistp proper-list-p sequencep arrayp vectorp stringp bool-vector-p hash-table-p @@ -1476,14 +1713,14 @@ See Info node `(elisp) Integer Basics'." ;; arguments. This is pure enough for the purposes of ;; constant folding, but not necessarily for all kinds of ;; code motion. - car cdr car-safe cdr-safe nth nthcdr last + car cdr car-safe cdr-safe nth nthcdr last take equal length safe-length memq memql member ;; `assoc' and `assoc-default' are excluded since they are ;; impure if the test function is (consider `string-match'). assq rassq rassoc - plist-get lax-plist-get plist-member + lax-plist-get aref elt base64-decode-string base64-encode-string base64url-encode-string bool-vector-subsetp @@ -1664,10 +1901,10 @@ See Info node `(elisp) Integer Basics'." byte-goto-if-not-nil-else-pop)) (defconst byte-after-unbind-ops - '(byte-constant byte-dup + '(byte-constant byte-dup byte-stack-ref byte-stack-set byte-discard byte-symbolp byte-consp byte-stringp byte-listp byte-numberp byte-integerp byte-eq byte-not - byte-cons byte-list1 byte-list2 ; byte-list3 byte-list4 + byte-cons byte-list1 byte-list2 byte-list3 byte-list4 byte-listN byte-interactive-p) ;; How about other side-effect-free-ops? Is it safe to move an ;; error invocation (such as from nth) out of an unwind-protect? @@ -1679,7 +1916,8 @@ See Info node `(elisp) Integer Basics'." (defconst byte-compile-side-effect-and-error-free-ops '(byte-constant byte-dup byte-symbolp byte-consp byte-stringp byte-listp byte-integerp byte-numberp byte-eq byte-equal byte-not byte-car-safe - byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max + byte-cdr-safe byte-cons byte-list1 byte-list2 byte-list3 byte-list4 + byte-listN byte-point byte-point-max byte-point-min byte-following-char byte-preceding-char byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp byte-current-buffer byte-stack-ref)) @@ -2030,13 +2268,15 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (setcar (cdr rest) lap0) (setq keep-going t)) ;; - ;; varbind-X unbind-N --> discard unbind-(N-1) - ;; save-excursion unbind-N --> unbind-(N-1) - ;; save-restriction unbind-N --> unbind-(N-1) + ;; varbind-X unbind-N --> discard unbind-(N-1) + ;; save-excursion unbind-N --> unbind-(N-1) + ;; save-restriction unbind-N --> unbind-(N-1) + ;; save-current-buffer unbind-N --> unbind-(N-1) ;; ((and (eq 'byte-unbind (car lap1)) (memq (car lap0) '(byte-varbind byte-save-excursion - byte-save-restriction)) + byte-save-restriction + byte-save-current-buffer)) (< 0 (cdr lap1))) (if (zerop (setcdr lap1 (1- (cdr lap1)))) (delq lap1 rest)) @@ -2060,9 +2300,9 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ((and (memq (car lap0) byte-goto-ops) (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap)))) '(byte-goto byte-return))) - (cond ((and (not (eq tmp lap0)) - (or (eq (car lap0) 'byte-goto) - (eq (car tmp) 'byte-goto))) + (cond ((and (or (eq (car lap0) 'byte-goto) + (eq (car tmp) 'byte-goto)) + (not (eq (cdr tmp) (cdr lap0)))) (byte-compile-log-lap " %s [%s]\t-->\t%s" (car lap0) tmp tmp) (if (eq (car tmp) 'byte-return) @@ -2392,8 +2632,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; itself, compile some of its most used recursive functions (at load time). ;; (eval-when-compile - (or (byte-code-function-p (symbol-function 'byte-optimize-form)) - (subr-native-elisp-p (symbol-function 'byte-optimize-form)) + (or (compiled-function-p (symbol-function 'byte-optimize-form)) (assq 'byte-code (symbol-function 'byte-optimize-form)) (let ((byte-optimize nil) (byte-compile-warnings nil)) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 92c2699c6e3..9a56ba0f7ad 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -166,7 +166,7 @@ The return value of this function is not used." (defalias 'byte-run--set-obsolete #'(lambda (f _args new-name when) (list 'make-obsolete - (list 'quote f) (list 'quote new-name) (list 'quote when)))) + (list 'quote f) (list 'quote new-name) when))) (defalias 'byte-run--set-interactive-only #'(lambda (f _args instead) @@ -210,12 +210,16 @@ The return value of this function is not used." (defalias 'byte-run--set-doc-string #'(lambda (f _args pos) (list 'function-put (list 'quote f) - ''doc-string-elt (list 'quote pos)))) + ''doc-string-elt (if (numberp pos) + pos + (list 'quote pos))))) (defalias 'byte-run--set-indent #'(lambda (f _args val) (list 'function-put (list 'quote f) - ''lisp-indent-function (list 'quote val)))) + ''lisp-indent-function (if (numberp val) + val + (list 'quote val))))) (defalias 'byte-run--set-speed #'(lambda (f _args val) @@ -232,6 +236,20 @@ The return value of this function is not used." (list 'function-put (list 'quote f) ''command-modes (list 'quote val)))) +(defalias 'byte-run--set-interactive-args + #'(lambda (f args &rest val) + (setq args (remove '&optional (remove '&rest args))) + (list 'function-put (list 'quote f) + ''interactive-args + (list + 'quote + (mapcar + (lambda (elem) + (cons + (seq-position args (car elem)) + (cadr elem))) + val))))) + ;; Add any new entries to info node `(elisp)Declare Form'. (defvar defun-declarations-alist (list @@ -251,7 +269,8 @@ If `error-free', drop calls even if `byte-compile-delete-errors' is nil.") (list 'indent #'byte-run--set-indent) (list 'speed #'byte-run--set-speed) (list 'completion #'byte-run--set-completion) - (list 'modes #'byte-run--set-modes)) + (list 'modes #'byte-run--set-modes) + (list 'interactive-args #'byte-run--set-interactive-args)) "List associating function properties to their macro expansion. Each element of the list takes the form (PROP FUN) where FUN is a function. For each (PROP . VALUES) in a function's declaration, @@ -272,6 +291,75 @@ This is used by `declare'.") (list 'function-put (list 'quote name) ''no-font-lock-keyword (list 'quote val)))) +(defalias 'byte-run--parse-body + #'(lambda (body allow-interactive) + "Decompose BODY into (DOCSTRING DECLARE INTERACTIVE BODY-REST WARNINGS)." + (let* ((top body) + (docstring nil) + (declare-form nil) + (interactive-form nil) + (warnings nil) + (warn #'(lambda (msg form) + (push (macroexp-warn-and-return msg nil nil t form) + warnings)))) + (while + (and body + (let* ((form (car body)) + (head (car-safe form))) + (cond + ((or (and (stringp form) (cdr body)) + (eq head :documentation)) + (cond + (docstring (funcall warn "More than one doc string" top)) + (declare-form + (funcall warn "Doc string after `declare'" declare-form)) + (interactive-form + (funcall warn "Doc string after `interactive'" + interactive-form)) + (t (setq docstring form))) + t) + ((eq head 'declare) + (cond + (declare-form + (funcall warn "More than one `declare' form" form)) + (interactive-form + (funcall warn "`declare' after `interactive'" form)) + (t (setq declare-form form))) + t) + ((eq head 'interactive) + (cond + ((not allow-interactive) + (funcall warn "No `interactive' form allowed here" form)) + (interactive-form + (funcall warn "More than one `interactive' form" form)) + (t (setq interactive-form form))) + t)))) + (setq body (cdr body))) + (list docstring declare-form interactive-form body warnings)))) + +(defalias 'byte-run--parse-declarations + #'(lambda (name arglist clauses construct declarations-alist) + (let* ((cl-decls nil) + (actions + (mapcar + #'(lambda (x) + (let ((f (cdr (assq (car x) declarations-alist)))) + (cond + (f (apply (car f) name arglist (cdr x))) + ;; Yuck!! + ((and (featurep 'cl) + (memq (car x) ;C.f. cl--do-proclaim. + '(special inline notinline optimize warn))) + (push (list 'declare x) cl-decls) + nil) + (t + (macroexp-warn-and-return + (format-message "Unknown %s property `%S'" + construct (car x)) + nil nil nil (car x)))))) + clauses))) + (cons actions cl-decls)))) + (defvar macro-declarations-alist (cons (list 'debug #'byte-run--set-debug) @@ -289,7 +377,7 @@ This is used by `declare'.") (defalias 'defmacro (cons 'macro - #'(lambda (name arglist &optional docstring &rest body) + #'(lambda (name arglist &rest body) "Define NAME as a macro. When the macro is called, as in (NAME ARGS...), the function (lambda ARGLIST BODY...) is applied to @@ -300,116 +388,73 @@ DECLS is a list of elements of the form (PROP . VALUES). These are interpreted according to `macro-declarations-alist'. The return value is undefined. -\(fn NAME ARGLIST &optional DOCSTRING DECL &rest BODY)" - ;; We can't just have `decl' as an &optional argument, because we need - ;; to distinguish - ;; (defmacro foo (arg) (bar) nil) - ;; from - ;; (defmacro foo (arg) (bar)). - (let ((decls (cond - ((eq (car-safe docstring) 'declare) - (prog1 (cdr docstring) (setq docstring nil))) - ((and (stringp docstring) - (eq (car-safe (car body)) 'declare)) - (prog1 (cdr (car body)) (setq body (cdr body))))))) - (if docstring (setq body (cons docstring body)) - (if (null body) (setq body '(nil)))) - ;; Can't use backquote because it's not defined yet! - (let* ((fun (list 'function (cons 'lambda (cons arglist body)))) - (def (list 'defalias - (list 'quote name) - (list 'cons ''macro fun))) - (declarations - (mapcar - #'(lambda (x) - (let ((f (cdr (assq (car x) macro-declarations-alist)))) - (if f (apply (car f) name arglist (cdr x)) - (macroexp-warn-and-return - (format-message - "Unknown macro property %S in %S" - (car x) name) - nil nil nil (car x))))) - decls))) - ;; Refresh font-lock if this is a new macro, or it is an - ;; existing macro whose 'no-font-lock-keyword declaration - ;; has changed. - (if (and - ;; If lisp-mode hasn't been loaded, there's no reason - ;; to flush. - (fboundp 'lisp--el-font-lock-flush-elisp-buffers) - (or (not (fboundp name)) ;; new macro - (and (fboundp name) ;; existing macro - (member `(function-put ',name 'no-font-lock-keyword - ',(get name 'no-font-lock-keyword)) - declarations)))) - (lisp--el-font-lock-flush-elisp-buffers)) - (if declarations - (cons 'prog1 (cons def declarations)) +\(fn NAME ARGLIST [DOCSTRING] [DECL] BODY...)" + (let* ((parse (byte-run--parse-body body nil)) + (docstring (nth 0 parse)) + (declare-form (nth 1 parse)) + (body (nth 3 parse)) + (warnings (nth 4 parse)) + (declarations + (and declare-form (byte-run--parse-declarations + name arglist (cdr declare-form) 'macro + macro-declarations-alist)))) + (setq body (nconc warnings body)) + (setq body (nconc (cdr declarations) body)) + (if docstring + (setq body (cons docstring body))) + (if (null body) + (setq body '(nil))) + (let* ((fun (list 'function (cons 'lambda (cons arglist body)))) + (def (list 'defalias + (list 'quote name) + (list 'cons ''macro fun)))) + (if declarations + (cons 'prog1 (cons def (car declarations))) def)))))) ;; Now that we defined defmacro we can use it! -(defmacro defun (name arglist &optional docstring &rest body) +(defmacro defun (name arglist &rest body) "Define NAME as a function. -The definition is (lambda ARGLIST [DOCSTRING] BODY...). -See also the function `interactive'. +The definition is (lambda ARGLIST [DOCSTRING] [INTERACTIVE] BODY...). DECL is a declaration, optional, of the form (declare DECLS...) where DECLS is a list of elements of the form (PROP . VALUES). These are interpreted according to `defun-declarations-alist'. +INTERACTIVE is an optional `interactive' specification. The return value is undefined. -\(fn NAME ARGLIST &optional DOCSTRING DECL &rest BODY)" - ;; We can't just have `decl' as an &optional argument, because we need - ;; to distinguish - ;; (defun foo (arg) (toto) nil) - ;; from - ;; (defun foo (arg) (toto)). +\(fn NAME ARGLIST [DOCSTRING] [DECL] [INTERACTIVE] BODY...)" (declare (doc-string 3) (indent 2)) (or name (error "Cannot define '%s' as a function" name)) (if (null (and (listp arglist) (null (delq t (mapcar #'symbolp arglist))))) (error "Malformed arglist: %s" arglist)) - (let ((decls (cond - ((eq (car-safe docstring) 'declare) - (prog1 (cdr docstring) (setq docstring nil))) - ((and (stringp docstring) - (eq (car-safe (car body)) 'declare)) - (prog1 (cdr (car body)) (setq body (cdr body))))))) - (if docstring (setq body (cons docstring body)) - (if (null body) (setq body '(nil)))) - (let ((declarations - (mapcar - #'(lambda (x) - (let ((f (cdr (assq (car x) defun-declarations-alist)))) - (cond - (f (apply (car f) name arglist (cdr x))) - ;; Yuck!! - ((and (featurep 'cl) - (memq (car x) ;C.f. cl-do-proclaim. - '(special inline notinline optimize warn))) - (push (list 'declare x) - (if (stringp docstring) - (if (eq (car-safe (cadr body)) 'interactive) - (cddr body) - (cdr body)) - (if (eq (car-safe (car body)) 'interactive) - (cdr body) - body))) - nil) - (t - (macroexp-warn-and-return - (format-message "Unknown defun property `%S' in %S" - (car x) name) - nil nil nil (car x)))))) - decls)) - (def (list 'defalias + (let* ((parse (byte-run--parse-body body t)) + (docstring (nth 0 parse)) + (declare-form (nth 1 parse)) + (interactive-form (nth 2 parse)) + (body (nth 3 parse)) + (warnings (nth 4 parse)) + (declarations + (and declare-form (byte-run--parse-declarations + name arglist (cdr declare-form) 'defun + defun-declarations-alist)))) + (setq body (nconc warnings body)) + (setq body (nconc (cdr declarations) body)) + (if interactive-form + (setq body (cons interactive-form body))) + (if docstring + (setq body (cons docstring body))) + (if (null body) + (setq body '(nil))) + (let ((def (list 'defalias (list 'quote name) (list 'function (cons 'lambda (cons arglist body)))))) (if declarations - (cons 'prog1 (cons def declarations)) - def)))) + (cons 'prog1 (cons def (car declarations))) + def)))) ;; Redefined in byte-opt.el. @@ -523,7 +568,6 @@ ACCESS-TYPE if non-nil should specify the kind of access that will trigger (purecopy (list current-name access-type when))) obsolete-name) - (defmacro define-obsolete-variable-alias ( obsolete-name current-name when &optional docstring) "Make OBSOLETE-NAME a variable alias for CURRENT-NAME and mark it obsolete. @@ -642,7 +686,7 @@ types. The types that can be suppressed with this macro are `suspicious'. For the `mapcar' case, only the `mapcar' function can be used in -the symbol list. For `suspicious', only `set-buffer' can be used." +the symbol list. For `suspicious', only `set-buffer' and `lsh' can be used." ;; Note: during compilation, this definition is overridden by the one in ;; byte-compile-initial-macro-environment. (declare (debug (sexp body)) (indent 1)) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index d28ec0be16d..a16486dc31c 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -244,11 +244,6 @@ the functions you loaded will not be able to run.") (make-obsolete-variable 'byte-compile-dynamic "not worthwhile any more." "27.1") ;;;###autoload(put 'byte-compile-dynamic 'safe-local-variable 'booleanp) -(defvar byte-compile-disable-print-circle nil - "If non-nil, disable `print-circle' on printing a byte-compiled code.") -(make-obsolete-variable 'byte-compile-disable-print-circle nil "24.1") -;;;###autoload(put 'byte-compile-disable-print-circle 'safe-local-variable 'booleanp) - (defcustom byte-compile-dynamic-docstrings t "If non-nil, compile doc strings for lazy access. We bury the doc strings of functions and variables inside comments in @@ -299,10 +294,10 @@ The information is logged to `byte-compile-log-buffer'." '(redefine callargs free-vars unresolved obsolete noruntime interactive-only make-local mapcar constants suspicious lexical lexical-dynamic - docstrings not-unused) + docstrings docstrings-non-ascii-quotes not-unused) "The list of warning types used when `byte-compile-warnings' is t.") (defcustom byte-compile-warnings t - "List of warnings that the byte-compiler should issue (t for all). + "List of warnings that the byte-compiler should issue (t for almost all). Elements of the list may be: @@ -327,15 +322,28 @@ Elements of the list may be: `byte-compile-docstring-max-column' or `fill-column' characters, whichever is bigger) or have other stylistic issues. + docstrings-non-ascii-quotes docstrings that have non-ASCII quotes. + This depends on the `docstrings' warning type. suspicious constructs that usually don't do what the coder wanted. If the list begins with `not', then the remaining elements specify warnings to -suppress. For example, (not mapcar) will suppress warnings about mapcar." +suppress. For example, (not mapcar) will suppress warnings about mapcar. + +The t value means \"all non experimental warning types\", and +excludes the types in `byte-compile--emacs-build-warning-types'. +A value of `all' really means all." :type `(choice (const :tag "All" t) (set :menu-tag "Some" ,@(mapcar (lambda (x) `(const ,x)) byte-compile-warning-types)))) +(defconst byte-compile--emacs-build-warning-types + '(docstrings-non-ascii-quotes) + "List of warning types that are only enabled during Emacs builds. +This is typically either warning types that are being phased in +(but shouldn't be enabled for packages yet), or that are only relevant +for the Emacs build itself.") + (defvar byte-compile--suppressed-warnings nil "Dynamically bound by `with-suppressed-warnings' to suppress warnings.") @@ -354,10 +362,15 @@ suppress. For example, (not mapcar) will suppress warnings about mapcar." (memq symbol (cdr elem))) (setq suppress t))) (and (not suppress) - (or (eq byte-compile-warnings t) - (if (eq (car byte-compile-warnings) 'not) - (not (memq warning byte-compile-warnings)) - (memq warning byte-compile-warnings)))))) + ;; During an Emacs build, we want all warnings. + (or (eq byte-compile-warnings 'all) + ;; If t, we want almost all the warnings, but not the + ;; ones that are Emacs build specific. + (and (not (memq warning byte-compile--emacs-build-warning-types)) + (or (eq byte-compile-warnings t) + (if (eq (car byte-compile-warnings) 'not) + (not (memq warning byte-compile-warnings)) + (memq warning byte-compile-warnings)))))))) ;;;###autoload (defun byte-compile-disable-warning (warning) @@ -663,10 +676,13 @@ Each element is (INDEX . VALUE)") (put 'byte-stack+-info 'tmp-compile-time-value nil))) -;; These opcodes are special in that they pack their argument into the -;; opcode word. -;; +;; The following opcodes (1-47) use the 3 lowest bits for an immediate +;; argument. + (byte-defop 0 1 byte-stack-ref "for stack reference") +;; Code 0 is actually unused but reserved as invalid code for detecting +;; corrupted bytecode. Codes 1-7 are stack-ref. + (byte-defop 8 1 byte-varref "for variable reference") (byte-defop 16 -1 byte-varset "for setting a variable") (byte-defop 24 -1 byte-varbind "for binding a variable") @@ -674,11 +690,9 @@ Each element is (INDEX . VALUE)") (byte-defop 40 0 byte-unbind "for unbinding special bindings") ;; codes 8-47 are consumed by the preceding opcodes -;; New (in Emacs-24.4) bytecodes for more efficient handling of non-local exits -;; (especially useful in lexical-binding code). (byte-defop 48 0 byte-pophandler) -(byte-defop 50 -1 byte-pushcatch) (byte-defop 49 -1 byte-pushconditioncase) +(byte-defop 50 -1 byte-pushcatch) ;; unused: 51-55 @@ -701,9 +715,9 @@ Each element is (INDEX . VALUE)") (byte-defop 72 -1 byte-aref) (byte-defop 73 -2 byte-aset) (byte-defop 74 0 byte-symbol-value) -(byte-defop 75 0 byte-symbol-function) ; this was commented out +(byte-defop 75 0 byte-symbol-function) (byte-defop 76 -1 byte-set) -(byte-defop 77 -1 byte-fset) ; this was commented out +(byte-defop 77 -1 byte-fset) (byte-defop 78 -1 byte-get) (byte-defop 79 -2 byte-substring) (byte-defop 80 -1 byte-concat2) @@ -721,8 +735,9 @@ Each element is (INDEX . VALUE)") (byte-defop 92 -1 byte-plus) (byte-defop 93 -1 byte-max) (byte-defop 94 -1 byte-min) -(byte-defop 95 -1 byte-mult) ; v19 only +(byte-defop 95 -1 byte-mult) (byte-defop 96 1 byte-point) +(byte-defop 97 0 byte-save-current-buffer-OBSOLETE) ; unused since v20 (byte-defop 98 0 byte-goto-char) (byte-defop 99 0 byte-insert) (byte-defop 100 1 byte-point-max) @@ -744,7 +759,6 @@ Each element is (INDEX . VALUE)") (byte-defop 115 0 byte-set-mark-OBSOLETE) (byte-defop 116 1 byte-interactive-p-OBSOLETE) -;; These ops are new to v19 (byte-defop 117 0 byte-forward-char) (byte-defop 118 0 byte-forward-word) (byte-defop 119 -1 byte-skip-chars-forward) @@ -801,7 +815,6 @@ the unwind-action") ;; unused: 146 -;; these ops are new to v19 (byte-defop 147 -2 byte-set-marker) (byte-defop 148 0 byte-match-beginning) (byte-defop 149 0 byte-match-end) @@ -833,6 +846,8 @@ the unwind-action") (byte-defop 178 -1 byte-stack-set) ; Stack offset in following one byte. (byte-defop 179 -1 byte-stack-set2) ; Stack offset in following two bytes. +;; unused: 180-181 + ;; If (following one byte & 0x80) == 0 ;; discard (following one byte & 0x7F) stack entries ;; else @@ -848,10 +863,11 @@ the unwind-action") "to take a hash table and a value from the stack, and jump to the address the value maps to, if any.") -;; unused: 182-191 +;; unused: 184-191 (byte-defop 192 1 byte-constant "for reference to a constant") -;; codes 193-255 are consumed by byte-constant. +;; Codes 193-255 are consumed by `byte-constant', which uses the 6 +;; lowest bits for an immediate argument. (defconst byte-constant-limit 64 "Exclusive maximum index usable in the `byte-constant' opcode.") @@ -1104,10 +1120,8 @@ message buffer `default-directory'." :type '(repeat (choice (const :tag "Default" nil) (string :tag "Directory")))) -(defvar emacs-lisp-compilation-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "g" 'emacs-lisp-compilation-recompile) - map)) +(defvar-keymap emacs-lisp-compilation-mode-map + "g" #'emacs-lisp-compilation-recompile) (defvar emacs-lisp-compilation--current-file nil) @@ -1147,7 +1161,7 @@ message buffer `default-directory'." ;; Log something that isn't a warning. (defun byte-compile-log-1 (string) - (with-current-buffer byte-compile-log-buffer + (with-current-buffer (get-buffer-create byte-compile-log-buffer) (let ((inhibit-read-only t)) (goto-char (point-max)) (byte-compile-warning-prefix nil nil) @@ -1156,18 +1170,6 @@ message buffer `default-directory'." (t (insert (format "%s\n" string))))))) -;; copied from gnus-util.el -(defsubst byte-compile-delete-first (elt list) - (if (eq (car list) elt) - (cdr list) - (let ((total list)) - (while (and (cdr list) - (not (eq (cadr list) elt))) - (setq list (cdr list))) - (when (cdr list) - (setcdr list (cddr list))) - total))) - (defvar byte-compile-last-warned-form nil) (defvar byte-compile-last-logged-file nil) (defvar byte-compile-root-dir nil @@ -1228,13 +1230,13 @@ Order is by depth-first search." load-file-name dir))) (t ""))) (offset (byte-compile--warning-source-offset)) - (pos (if (and byte-compile-current-file - (or offset (not symbols-with-pos-enabled))) + (pos (if (and byte-compile-current-file offset) (with-current-buffer byte-compile-current-buffer (let (new-l new-c) (save-excursion (goto-char offset) - (setq new-l (1+ (count-lines (point-min) (point-at-bol))) + (setq new-l (1+ (count-lines (point-min) + (line-beginning-position))) new-c (1+ (current-column))) (format "%d:%d:" new-l new-c)))) "")) @@ -1354,16 +1356,23 @@ FORMAT and ARGS are as in `byte-compile-warn'." (let ((byte-compile-form-stack (cons arg byte-compile-form-stack))) (apply #'byte-compile-warn format args))) -(defun byte-compile-warn-obsolete (symbol) - "Warn that SYMBOL (a variable or function) is obsolete." +;;;###autoload +(defun byte-compile-warn-obsolete (symbol type) + "Warn that SYMBOL (a variable, function or generalized variable) is obsolete. +TYPE is a string that say which one of these three types it is." (when (byte-compile-warning-enabled-p 'obsolete symbol) - (let* ((funcp (get symbol 'byte-obsolete-info)) - (msg (macroexp--obsolete-warning - symbol - (or funcp (get symbol 'byte-obsolete-variable)) - (if funcp "function" "variable")))) - (unless (and funcp (memq symbol byte-compile-not-obsolete-funcs)) - (byte-compile-warn-x symbol "%s" msg))))) + (byte-compile-warn-x + symbol "%s" + (macroexp--obsolete-warning + symbol + (pcase type + ("function" + (get symbol 'byte-obsolete-info)) + ("variable" + (get symbol 'byte-obsolete-variable)) + ("generalized variable" + (get symbol 'byte-obsolete-generalized-variable))) + type)))) (defun byte-compile-report-error (error-info &optional fill) "Report Lisp error in compilation. @@ -1394,7 +1403,7 @@ when printing the error message." (or (symbolp (symbol-function fn)) (consp (symbol-function fn)) (and (not macro-p) - (byte-code-function-p (symbol-function fn))))) + (compiled-function-p (symbol-function fn))))) (setq fn (symbol-function fn))) (let ((advertised (gethash (if (and (symbolp fn) (fboundp fn)) ;; Could be a subr. @@ -1406,7 +1415,7 @@ when printing the error message." (if macro-p `(macro lambda ,advertised) `(lambda ,advertised))) - ((and (not macro-p) (byte-code-function-p fn)) fn) + ((and (not macro-p) (compiled-function-p fn)) fn) ((not (consp fn)) nil) ((eq 'macro (car fn)) (cdr fn)) (macro-p nil) @@ -1467,8 +1476,8 @@ when printing the error message." (defun byte-compile-function-warn (f nargs def) (when (and (get f 'byte-obsolete-info) - (byte-compile-warning-enabled-p 'obsolete f)) - (byte-compile-warn-obsolete f)) + (not (memq f byte-compile-not-obsolete-funcs))) + (byte-compile-warn-obsolete f "function")) ;; Check to see if the function will be available at runtime ;; and/or remember its arity if it's unknown. @@ -1721,8 +1730,8 @@ The byte-compiler will emit a warning for documentation strings containing lines wider than this. If `fill-column' has a larger value, it will override this variable." :group 'bytecomp - :type 'integer - :safe #'integerp + :type 'natnum + :safe #'natnump :version "28.1") (define-obsolete-function-alias 'byte-compile-docstring-length-warn @@ -1739,7 +1748,8 @@ It is too wide if it has any lines longer than the largest of (pcase (car form) ((or 'autoload 'custom-declare-variable 'defalias 'defconst 'define-abbrev-table - 'defvar 'defvaralias) + 'defvar 'defvaralias + 'custom-declare-face) (setq kind (nth 0 form)) (setq name (nth 1 form)) (setq docs (nth 3 form))) @@ -1758,10 +1768,17 @@ It is too wide if it has any lines longer than the largest of kind name col)) ;; There's a "naked" ' character before a symbol/list, so it ;; should probably be quoted with \=. - (when (string-match-p "\\( \"\\|[ \t]\\|^\\)'[a-z(]" docs) + (when (string-match-p "\\( [\"#]\\|[ \t]\\|^\\)'[a-z(]" docs) (byte-compile-warn-x name "%s%sdocstring has wrong usage of unescaped single quotes (use \\= or different quoting)" - kind name))))) + kind name)) + ;; There's a "Unicode quote" in the string -- it should probably + ;; be an ASCII one instead. + (when (byte-compile-warning-enabled-p 'docstrings-non-ascii-quotes) + (when (string-match-p "\\( \"\\|[ \t]\\|^\\)[‘’]" docs) + (byte-compile-warn-x + name "%s%sdocstring has wrong usage of \"fancy\" single quotation marks" + kind name)))))) form) ;; If we have compiled any calls to functions which are not known to be @@ -2064,10 +2081,12 @@ If compilation is needed, this functions returns the result of The output file's name is generated by passing FILENAME to the function `byte-compile-dest-file' (which see). The value is non-nil if there were no errors, nil if errors. +If the file sets the file variable `no-byte-compile', it is not +compiled, any existing output file is removed, and the return +value is `no-byte-compile'. See also `emacs-lisp-byte-compile-and-load'." (declare (advertised-calling-convention (filename) "28.1")) -;; (interactive "fByte compile file: \nP") (interactive (let ((file buffer-file-name) (file-dir nil)) @@ -2393,8 +2412,8 @@ Call from the source buffer." (defun byte-compile-output-file-form (form) ;; Write the given form to the output buffer, being careful of docstrings - ;; in defvar, defvaralias, defconst, autoload and - ;; custom-declare-variable because make-docfile is so amazingly stupid. + ;; (for `byte-compile-dynamic-docstrings') in defvar, defvaralias, + ;; defconst, autoload, and custom-declare-variable. ;; defalias calls are output directly by byte-compile-file-form-defmumble; ;; it does not pay to first build the defalias in defmumble and then parse ;; it here. @@ -2408,8 +2427,7 @@ Call from the source buffer." (print-level nil) (print-quoted t) (print-gensym t) - (print-circle ; Handle circular data structures. - (not byte-compile-disable-print-circle))) + (print-circle t)) ; Handle circular data structures. (if (and (memq (car-safe form) '(defvar defvaralias defconst autoload custom-declare-variable)) (stringp (nth 3 form))) @@ -2441,21 +2459,9 @@ list that represents a doc string reference. (let (position (print-symbols-bare t)) ; Possibly redundant binding. ;; Insert the doc string, and make it a comment with #@LENGTH. - (and (>= (nth 1 info) 0) - dynamic-docstrings - (progn - ;; Make the doc string start at beginning of line - ;; for make-docfile's sake. - (insert "\n") - (setq position - (byte-compile-output-as-comment - (nth (nth 1 info) form) nil)) - ;; If the doc string starts with * (a user variable), - ;; negate POSITION. - (if (and (stringp (nth (nth 1 info) form)) - (> (length (nth (nth 1 info) form)) 0) - (eq (aref (nth (nth 1 info) form) 0) ?*)) - (setq position (- position))))) + (when (and (>= (nth 1 info) 0) dynamic-docstrings) + (setq position (byte-compile-output-as-comment + (nth (nth 1 info) form) nil))) (let ((print-continuous-numbering t) print-number-table @@ -2467,8 +2473,7 @@ list that represents a doc string reference. (print-level nil) (print-quoted t) (print-gensym t) - (print-circle ; Handle circular data structures. - (not byte-compile-disable-print-circle))) + (print-circle t)) ; Handle circular data structures. (if preface (progn ;; FIXME: We don't handle uninterned names correctly. @@ -2521,13 +2526,12 @@ list that represents a doc string reference. (defun byte-compile-keep-pending (form &optional handler) (if (memq byte-optimize '(t source)) (setq form (byte-optimize-one-form form t))) + ;; To avoid consing up monstrously large forms at load time, we split + ;; the output regularly. + (when (nthcdr 300 byte-compile-output) + (byte-compile-flush-pending)) (if handler (let ((byte-compile--for-effect t)) - ;; To avoid consing up monstrously large forms at load time, we split - ;; the output regularly. - (and (memq (car-safe form) '(fset defalias)) - (nthcdr 300 byte-compile-output) - (byte-compile-flush-pending)) (funcall handler form) (if byte-compile--for-effect (byte-compile-discard))) @@ -2584,8 +2588,8 @@ list that represents a doc string reference. (t (byte-compile-keep-pending form))))) -;; Functions and variables with doc strings must be output separately, -;; so make-docfile can recognize them. Most other things can be output +;; Functions and variables with doc strings must be output specially, +;; for `byte-compile-dynamic-docstrings'. Most other things can be output ;; as byte-code. (put 'autoload 'byte-hunk-handler 'byte-compile-file-form-autoload) @@ -2682,11 +2686,10 @@ list that represents a doc string reference. (byte-compile-keep-pending form)) (put 'custom-declare-variable 'byte-hunk-handler - 'byte-compile-file-form-custom-declare-variable) -(defun byte-compile-file-form-custom-declare-variable (form) - (when (byte-compile-warning-enabled-p 'callargs) - (byte-compile-nogroup-warn form)) - (byte-compile-file-form-defvar-function form)) + 'byte-compile-file-form-defvar-function) + +(put 'custom-declare-face 'byte-hunk-handler + 'byte-compile-docstring-style-warn) (put 'require 'byte-hunk-handler 'byte-compile-file-form-require) (defun byte-compile-file-form-require (form) @@ -2951,11 +2954,11 @@ If FORM is a lambda or a macro, byte-compile it as a function." (setq fun (cdr fun))) (prog1 (cond - ;; Up until Emacs-24.1, byte-compile silently did nothing when asked to - ;; compile something invalid. So let's tune down the complaint from an - ;; error to a simple message for the known case where signaling an error - ;; causes problems. - ((byte-code-function-p fun) + ;; Up until Emacs-24.1, byte-compile silently did nothing + ;; when asked to compile something invalid. So let's tone + ;; down the complaint from an error to a simple message for + ;; the known case where signaling an error causes problems. + ((compiled-function-p fun) (message "Function %s is already compiled" (if (symbolp form) form "provided")) fun) @@ -3532,7 +3535,7 @@ lambda-expression." (byte-compile-out-tag endtag))) (defun byte-compile-unfold-bcf (form) - "Inline call to byte-code-functions." + "Inline call to byte-code function." (let* ((byte-compile-bound-variables byte-compile-bound-variables) (fun (car form)) (fargs (aref fun 0)) @@ -3609,7 +3612,7 @@ lambda-expression." ('set (not (eq access-type 'reference))) ('get (eq access-type 'reference)) (_ t)))) - (byte-compile-warn-obsolete var)))) + (byte-compile-warn-obsolete var "variable")))) (defsubst byte-compile-dynamic-variable-op (base-op var) (let ((tmp (assq var byte-compile-variables))) @@ -3753,7 +3756,6 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (put 'byte-insertN 'byte-opcode-invert 'insert) (byte-defop-compiler point 0) -;;(byte-defop-compiler mark 0) ;; obsolete (byte-defop-compiler point-max 0) (byte-defop-compiler point-min 0) (byte-defop-compiler following-char 0) @@ -3764,8 +3766,6 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-defop-compiler bolp 0) (byte-defop-compiler bobp 0) (byte-defop-compiler current-buffer 0) -;;(byte-defop-compiler read-char 0) ;; obsolete -;; (byte-defop-compiler interactive-p 0) ;; Obsolete. (byte-defop-compiler widen 0) (byte-defop-compiler end-of-line 0-1) (byte-defop-compiler forward-char 0-1) @@ -3786,7 +3786,6 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-defop-compiler goto-char 1) (byte-defop-compiler char-after 0-1) (byte-defop-compiler set-buffer 1) -;;(byte-defop-compiler set-mark 1) ;; obsolete (byte-defop-compiler forward-word 0-1) (byte-defop-compiler char-syntax 1) (byte-defop-compiler nreverse 1) @@ -3839,7 +3838,6 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-defop-compiler (+ byte-plus) byte-compile-variadic-numeric) (byte-defop-compiler (* byte-mult) byte-compile-variadic-numeric) -;;####(byte-defop-compiler move-to-column 1) (byte-defop-compiler-1 interactive byte-compile-noop) @@ -4223,7 +4221,7 @@ This function is never called when `lexical-binding' is nil." (byte-defop-compiler-1 quote) (defun byte-compile-setq (form) - (cl-assert (= (length form) 3)) ; normalised in macroexp + (cl-assert (= (length form) 3)) ; normalized in macroexp (let ((var (nth 1 form)) (expr (nth 2 form))) (byte-compile-form expr) @@ -4794,8 +4792,6 @@ binding slots have been popped." (byte-defop-compiler-1 save-excursion) (byte-defop-compiler-1 save-current-buffer) (byte-defop-compiler-1 save-restriction) -;; (byte-defop-compiler-1 save-window-excursion) ;Obsolete: now a macro. -;; (byte-defop-compiler-1 with-output-to-temp-buffer) ;Obsolete: now a macro. (defun byte-compile-catch (form) (byte-compile-form (car (cdr form))) @@ -4992,7 +4988,7 @@ binding slots have been popped." ;; ;; FIXME: we also use this hunk-handler to implement the function's ;; dynamic docstring feature (via byte-compile-file-form-defmumble). - ;; We should actually implement it (more elegantly) in + ;; We should probably actually implement it (more elegantly) in ;; byte-compile-lambda so it applies to all lambdas. We did it here ;; so the resulting .elc format was recognizable by make-docfile, ;; but since then we stopped using DOC for the docstrings of @@ -5266,11 +5262,13 @@ invoked interactively." ((not (consp f)) "<malformed function>") ((eq 'macro (car f)) - (if (or (byte-code-function-p (cdr f)) + (if (or (compiled-function-p (cdr f)) + ;; FIXME: Can this still happen? (assq 'byte-code (cdr (cdr (cdr f))))) " <compiled macro>" " <macro>")) ((assq 'byte-code (cdr (cdr f))) + ;; FIXME: Can this still happen? "<compiled lambda>") ((eq 'lambda (car f)) "<function>") @@ -5519,9 +5517,7 @@ and corresponding effects." ;; itself, compile some of its most used recursive functions (at load time). ;; (eval-when-compile - (or (byte-code-function-p (symbol-function 'byte-compile-form)) - (subr-native-elisp-p (symbol-function 'byte-compile-form)) - (assq 'byte-code (symbol-function 'byte-compile-form)) + (or (compiled-function-p (symbol-function 'byte-compile-form)) (let ((byte-optimize nil) ; do it fast (byte-compile-warnings nil)) (mapc (lambda (x) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index eca1123899c..7f95fa94fa1 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -267,8 +267,7 @@ Returns a form where all lambdas don't have any free variables." (define-inline cconv--var-classification (binder form) (inline-quote - (alist-get (cons ,binder ,form) cconv-var-classification - nil nil #'equal))) + (cdr (assoc (cons ,binder ,form) cconv-var-classification)))) (defun cconv--convert-funcbody (funargs funcbody env parentform) "Run `cconv-convert' on FUNCBODY, the forms of a lambda expression. diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el index 29fbcce7734..9ff893b75b6 100644 --- a/lisp/emacs-lisp/chart.el +++ b/lisp/emacs-lisp/chart.el @@ -63,8 +63,7 @@ (eval-when-compile (require 'cl-generic)) ;;; Code: -(define-obsolete-variable-alias 'chart-map 'chart-mode-map "24.1") -(defvar chart-mode-map (make-sparse-keymap) "Keymap used in chart mode.") +(defvar-keymap chart-mode-map :doc "Keymap used in chart mode.") (defvar-local chart-local-object nil "Local variable containing the locally displayed chart object.") @@ -113,7 +112,7 @@ too much in text characters anyways.") (set-face-foreground nf "black") (if (and chart-face-use-pixmaps pl) (condition-case nil - (set-face-background-pixmap nf (car pl)) + (set-face-stipple nf (car pl)) (error (message "Cannot set background pixmap %s" (car pl))))) (push nf faces) (setq cl (cdr cl) @@ -527,9 +526,9 @@ cons cells of the form (NAME . NUM). See `sort' for more details." (defun chart-zap-chars (n) "Zap up to N chars without deleting EOLs." (if (not (eobp)) - (if (< n (- (point-at-eol) (point))) + (if (< n (- (line-end-position) (point))) (delete-char n) - (delete-region (point) (point-at-eol))))) + (delete-region (point) (line-end-position))))) (defun chart-display-label (label dir zone start end &optional face) "Display LABEL in direction DIR in column/row ZONE between START and END. diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 5700afbb03e..a5ab3a50ff2 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -1,6 +1,6 @@ ;;; checkdoc.el --- check documentation strings for style requirements -*- lexical-binding:t -*- -;; Copyright (C) 1997-1998, 2001-2022 Free Software Foundation, Inc. +;; Copyright (C) 1997-2022 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Old-Version: 0.6.2 @@ -165,7 +165,7 @@ (require 'cl-lib) (require 'help-mode) ;; for help-xref-info-regexp (require 'thingatpt) ;; for handy thing-at-point-looking-at -(require 'lisp-mode) ;; for lisp-mode-symbol-regexp +(require 'lisp-mode) ;; for lisp-mode-symbol regexp (eval-when-compile (require 'dired)) ;; for dired-map-over-marks (require 'lisp-mnt) @@ -248,7 +248,7 @@ with these words enabled." ;;;###autoload(put 'checkdoc-spellcheck-documentation-flag 'safe-local-variable #'booleanp) (defvar checkdoc-ispell-lisp-words - '("alist" "emacs" "etags" "keymap" "paren" "regexp" "sexp" "xemacs") + '("alist" "emacs" "etags" "keymap" "paren" "regexp" "sexp") "List of words that are correct when spell-checking Lisp documentation.") ;;;###autoload(put 'checkdoc-ispell-list-words 'safe-local-variable #'checkdoc-list-of-strings-p) @@ -1279,38 +1279,30 @@ TEXT, START, END and UNFIXABLE conform to ;;; Minor Mode specification ;; -(defvar checkdoc-minor-mode-map - (let ((map (make-sparse-keymap)) - (pmap (make-sparse-keymap))) - ;; Override some bindings - (define-key map "\C-\M-x" #'checkdoc-eval-defun) - (define-key map "\C-x`" #'checkdoc-continue) - (define-key map [menu-bar emacs-lisp eval-buffer] - #'checkdoc-eval-current-buffer) - ;; Add some new bindings under C-c ? - (define-key pmap "x" #'checkdoc-defun) - (define-key pmap "X" #'checkdoc-ispell-defun) - (define-key pmap "`" #'checkdoc-continue) - (define-key pmap "~" #'checkdoc-ispell-continue) - (define-key pmap "s" #'checkdoc-start) - (define-key pmap "S" #'checkdoc-ispell-start) - (define-key pmap "d" #'checkdoc) - (define-key pmap "D" #'checkdoc-ispell) - (define-key pmap "b" #'checkdoc-current-buffer) - (define-key pmap "B" #'checkdoc-ispell-current-buffer) - (define-key pmap "e" #'checkdoc-eval-current-buffer) - (define-key pmap "m" #'checkdoc-message-text) - (define-key pmap "M" #'checkdoc-ispell-message-text) - (define-key pmap "c" #'checkdoc-comments) - (define-key pmap "C" #'checkdoc-ispell-comments) - (define-key pmap " " #'checkdoc-rogue-spaces) - - ;; bind our submap into map - (define-key map "\C-c?" pmap) - map) - "Keymap used to override evaluation key-bindings for documentation checking.") - -;; Add in a menubar with easy-menu +(defvar-keymap checkdoc-minor-mode-map + :doc "Keymap used to override evaluation key-bindings for documentation checking." + ;; Override some bindings + "C-M-x" #'checkdoc-eval-defun + "C-x `" #'checkdoc-continue + "<menu-bar> <emacs-lisp> <eval-buffer>" #'checkdoc-eval-current-buffer + + ;; Add some new bindings under C-c ? + "C-c ? x" #'checkdoc-defun + "C-c ? X" #'checkdoc-ispell-defun + "C-c ? `" #'checkdoc-continue + "C-c ? ~" #'checkdoc-ispell-continue + "C-c ? s" #'checkdoc-start + "C-c ? S" #'checkdoc-ispell-start + "C-c ? d" #'checkdoc + "C-c ? D" #'checkdoc-ispell + "C-c ? b" #'checkdoc-current-buffer + "C-c ? B" #'checkdoc-ispell-current-buffer + "C-c ? e" #'checkdoc-eval-current-buffer + "C-c ? m" #'checkdoc-message-text + "C-c ? M" #'checkdoc-ispell-message-text + "C-c ? c" #'checkdoc-comments + "C-c ? C" #'checkdoc-ispell-comments + "C-c ? SPC" #'checkdoc-rogue-spaces) (easy-menu-define nil checkdoc-minor-mode-map "Checkdoc Minor Mode Menu." @@ -1365,23 +1357,6 @@ checking of documentation strings. checkdoc-common-verbs-wrong-voice "\\|") "\\)\\>")))) -;; Profiler says this is not yet faster than just calling assoc -;;(defun checkdoc-word-in-alist-vector (word vector) -;; "Check to see if WORD is in the car of an element of VECTOR. -;;VECTOR must be sorted. The CDR should be a replacement. Since the -;;word list is getting bigger, it is time for a quick bisecting search." -;; (let ((max (length vector)) (min 0) i -;; (found nil) (fw nil)) -;; (setq i (/ max 2)) -;; (while (and (not found) (/= min max)) -;; (setq fw (car (aref vector i))) -;; (cond ((string= word fw) (setq found (cdr (aref vector i)))) -;; ((string< word fw) (setq max i)) -;; (t (setq min i))) -;; (setq i (/ (+ max min) 2)) -;; ) -;; found)) - ;;; Checking engines ;; (defun checkdoc-this-string-valid (&optional take-notes) @@ -2007,6 +1982,7 @@ from the comment." (let ((defun (looking-at "(\\(?:cl-\\)?def\\(un\\|macro\\|subst\\|advice\\|generic\\|method\\)")) (is-advice (looking-at "(defadvice")) + (defun-depth (ppss-depth (syntax-ppss))) (lst nil) (ret nil) (oo (make-vector 3 0))) ;substitute obarray for `read' @@ -2022,11 +1998,17 @@ from the comment." (setq ret (cons nil ret)) ;; Interactive (save-excursion - (setq ret (cons - (re-search-forward "^\\s-*(interactive" - (save-excursion (end-of-defun) (point)) - t) - ret))) + (push (and (re-search-forward "^\\s-*(interactive" + (save-excursion + (end-of-defun) + (point)) + t) + ;; Disregard `interactive' from other parts of + ;; the function. + (= (ppss-depth (syntax-ppss)) + (+ defun-depth 2)) + (point)) + ret)) (skip-chars-forward " \t\n") (let ((bss (buffer-substring (point) (save-excursion (forward-sexp 1) (point)))) @@ -2250,7 +2232,6 @@ nil." (progn (ispell-set-spellchecker-params) ; Initialize variables and dict alists. (ispell-accept-buffer-local-defs) ; Use the correct dictionary. - ;; This code copied in part from ispell.el Emacs 19.34 (dolist (w checkdoc-ispell-lisp-words) (process-send-string ispell-process (concat "@" w "\n")))) (error (setq checkdoc-spellcheck-documentation-flag nil))))) @@ -2361,8 +2342,6 @@ News agents may remove it" ;;; Comment checking engine ;; -(defvar generate-autoload-cookie) - (defun checkdoc-file-comments-engine () "Return a message list if this file does not match the Emacs standard. This checks for style only, such as the first line, Commentary:, @@ -2597,13 +2576,13 @@ The correct format is \"Foo\" or \"some-symbol: Foo\". See also (unless (let ((case-fold-search nil)) (looking-at (rx (or upper-case "%s")))) ;; A defined Lisp symbol is always okay. - (unless (and (looking-at (rx (group (regexp lisp-mode-symbol-regexp)))) + (unless (and (looking-at (rx (group lisp-mode-symbol))) (or (fboundp (intern (match-string 1))) (boundp (intern (match-string 1))))) ;; Other Lisp symbols are sometimes okay. (rx-let ((c (? "\\\n"))) ; `c' is for a continued line (let ((case-fold-search nil) - (some-symbol (rx (regexp lisp-mode-symbol-regexp) + (some-symbol (rx lisp-mode-symbol c ":" c (+ (any " \t\n")))) (lowercase-str (rx c (group (any "a-z") (+ wordchar))))) (if (looking-at some-symbol) @@ -2628,7 +2607,7 @@ a space as a style error." (checkdoc-autofix-ask-replace (match-beginning 0) (match-end 0) (format-message - "`y-or-n-p' argument should end with \"? \". Fix?") + "`y-or-n-p' argument should end with \"?\". Fix?") "?\"" t)) nil (checkdoc-create-error @@ -2863,8 +2842,6 @@ function called to create the messages." (custom-add-option 'emacs-lisp-mode-hook 'checkdoc-minor-mode) -;; Obsolete - (define-obsolete-function-alias 'checkdoc-run-hooks #'run-hook-with-args-until-success "28.1") (defvar checkdoc-version "0.6.2" diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 8e38df43c87..607810ee141 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -71,8 +71,7 @@ numbers of different types (float vs. integer), and also compares strings case-insensitively." (cond ((eq x y) t) ((stringp x) - (and (stringp y) (= (length x) (length y)) - (eq (compare-strings x nil nil y nil nil t) t))) + (and (stringp y) (string-equal-ignore-case x y))) ((numberp x) (and (numberp y) (= x y))) ((consp x) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 200af057cd7..0560ddda268 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -659,13 +659,35 @@ The set of acceptable TYPEs (also called \"specializers\") is defined ;; which it depends needs to be usable before cl-generic is loaded, ;; which imposes a significant burden on the bootstrap. (if (consp (lambda (x) (+ x 1))) - (lambda (exp) (eval exp t)) #'byte-compile)) + (lambda (exp) (eval exp t)) + ;; But do byte-compile the dispatchers once bootstrap is passed: + ;; the performance difference is substantial (like a 5x speedup on + ;; the `eieio' elisp-benchmark)). + ;; To avoid loading the byte-compiler during the final preload, + ;; see `cl--generic-prefill-dispatchers'. + #'byte-compile)) (defun cl--generic-get-dispatcher (dispatch) (with-memoization ;; We need `copy-sequence` here because this `dispatch' object might be ;; modified by side-effect in `cl-generic-define-method' (bug#46722). (gethash (copy-sequence dispatch) cl--generic-dispatchers) + + (when (and purify-flag ;FIXME: Is this a reliable test of the final dump? + (eq cl--generic-compiler #'byte-compile)) + ;; We don't want to preload the byte-compiler!! + (error + "Missing cl-generic dispatcher in the prefilled cache! +Missing for: %S +You might need to add: %S" + (mapcar (lambda (x) (if (cl--generic-generalizer-p x) + (cl--generic-generalizer-name x) + x)) + dispatch) + `(cl--generic-prefill-dispatchers + ,@(delq nil (mapcar #'cl--generic-prefill-generalizer-sample + dispatch))))) + ;; (message "cl--generic-get-dispatcher (%S)" dispatch) (let* ((dispatch-arg (car dispatch)) (generalizers (cdr dispatch)) @@ -708,9 +730,6 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (funcall cl--generic-compiler `(lambda (generic dispatches-left methods) - ;; FIXME: We should find a way to expand `with-memoize' once - ;; and forall so we don't need `subr-x' when we get here. - (eval-when-compile (require 'subr-x)) (let ((method-cache (make-hash-table :test #'eql))) (lambda (,@fixedargs &rest args) (let ,bindings @@ -933,6 +952,20 @@ those methods.") (if (eq specializer t) (list cl--generic-t-generalizer) (error "Unknown specializer %S" specializer))) +(defun cl--generic-prefill-generalizer-sample (x) + "Return an example specializer." + (if (not (cl--generic-generalizer-p x)) + x + (pcase (cl--generic-generalizer-name x) + ('cl--generic-t-generalizer nil) + ('cl--generic-head-generalizer '(head 'x)) + ('cl--generic-eql-generalizer '(eql 'x)) + ('cl--generic-struct-generalizer 'cl--generic) + ('cl--generic-typeof-generalizer 'integer) + ('cl--generic-derived-generalizer '(derived-mode c-mode)) + ('cl--generic-oclosure-generalizer 'oclosure) + (_ x)))) + (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, @@ -1330,6 +1363,7 @@ See the full list and their hierarchy in `cl--typeof-types'." (cl-call-next-method))) (cl--generic-prefill-dispatchers 0 integer) +(cl--generic-prefill-dispatchers 1 integer) (cl--generic-prefill-dispatchers 0 cl--generic-generalizer integer) ;;; Dispatch on major mode. @@ -1378,7 +1412,7 @@ Used internally for the (major-mode MODE) context specializers." (when (cl-typep class 'oclosure--class) (oclosure--class-allparents class))))) -(cl-generic-define-generalizer cl-generic--oclosure-generalizer +(cl-generic-define-generalizer cl--generic-oclosure-generalizer ;; Give slightly higher priority than the struct specializer, so that ;; for a generic function with methods dispatching structs and on OClosures, ;; we first try `oclosure-type' before `type-of' since `type-of' will return @@ -1395,7 +1429,7 @@ Used internally for the (major-mode MODE) context specializers." ;; take place without requiring cl-lib. (let ((class (cl--find-class type))) (and (cl-typep class 'oclosure--class) - (list cl-generic--oclosure-generalizer)))) + (list cl--generic-oclosure-generalizer)))) (cl-call-next-method))) (cl--generic-prefill-dispatchers 0 oclosure) diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el index 213eecf88d4..fe7e4506d7c 100644 --- a/lisp/emacs-lisp/cl-indent.el +++ b/lisp/emacs-lisp/cl-indent.el @@ -378,10 +378,9 @@ instead." function) (setq tentative-defun t)) ((string-match - (eval-when-compile - (concat "\\`\\(" - (regexp-opt '("with" "without" "do")) - "\\)-")) + (concat "\\`\\(" + (regexp-opt '("with" "without" "do")) + "\\)-") function) (setq method '(&lambda &body)))))) ;; backwards compatibility. Bletch. diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 3f40ab07605..a54fa21fa96 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -372,8 +372,8 @@ SEQ, this is like `mapcar'. With several, it is like the Common Lisp (cl--defalias 'cl-second 'cadr) (cl--defalias 'cl-rest 'cdr) -(cl--defalias 'cl-third 'cl-caddr "Return the third element of the list X.") -(cl--defalias 'cl-fourth 'cl-cadddr "Return the fourth element of the list X.") +(cl--defalias 'cl-third #'caddr "Return the third element of the list X.") +(cl--defalias 'cl-fourth #'cadddr "Return the fourth element of the list X.") (defsubst cl-fifth (x) "Return the fifth element of the list X." diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 10043ba2807..80ca43c902a 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -527,7 +527,7 @@ its argument list allows full Common Lisp conventions." (while (and (eq (car args) '&aux) (pop args)) (while (and args (not (memq (car args) cl--lambda-list-keywords))) (if (consp (car args)) - (if (and cl--bind-enquote (cl-cadar args)) + (if (and cl--bind-enquote (cadar args)) (cl--do-arglist (caar args) `',(cadr (pop args))) (cl--do-arglist (caar args) (cadr (pop args)))) @@ -612,7 +612,7 @@ its argument list allows full Common Lisp conventions." (if (eq ?_ (aref name 0)) (setq name (substring name 1))) (intern (format ":%s" name))))) - (varg (if (consp (car arg)) (cl-cadar arg) (car arg))) + (varg (if (consp (car arg)) (cadar arg) (car arg))) (def (if (cdr arg) (cadr arg) ;; The ordering between those two or clauses is ;; irrelevant, since in practice only one of the two @@ -1339,7 +1339,7 @@ For more details, see Info node `(cl)Loop Facility'. (temp-idx (if (eq (car cl--loop-args) 'using) (if (and (= (length (cadr cl--loop-args)) 2) - (eq (cl-caadr cl--loop-args) 'index)) + (eq (caadr cl--loop-args) 'index)) (cadr (cl--pop2 cl--loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-idx--")))) @@ -1370,8 +1370,8 @@ For more details, see Info node `(cl)Loop Facility'. (other (if (eq (car cl--loop-args) 'using) (if (and (= (length (cadr cl--loop-args)) 2) - (memq (cl-caadr cl--loop-args) hash-types) - (not (eq (cl-caadr cl--loop-args) word))) + (memq (caadr cl--loop-args) hash-types) + (not (eq (caadr cl--loop-args) word))) (cadr (cl--pop2 cl--loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-var--")))) @@ -1433,8 +1433,8 @@ For more details, see Info node `(cl)Loop Facility'. (other (if (eq (car cl--loop-args) 'using) (if (and (= (length (cadr cl--loop-args)) 2) - (memq (cl-caadr cl--loop-args) key-types) - (not (eq (cl-caadr cl--loop-args) word))) + (memq (caadr cl--loop-args) key-types) + (not (eq (caadr cl--loop-args) word))) (cadr (cl--pop2 cl--loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-var--")))) @@ -1656,7 +1656,7 @@ If BODY is `setq', then use SPECS for assignments rather than for bindings." (let ((temps nil) (new nil)) (when par (let ((p specs)) - (while (and p (or (symbolp (car-safe (car p))) (null (cl-cadar p)))) + (while (and p (or (symbolp (car-safe (car p))) (null (cadar p)))) (setq p (cdr p))) (when p (setq par nil) @@ -1731,7 +1731,7 @@ such that COMBO is equivalent to (and . CLAUSES)." (setq clauses (cons (nconc (butlast (car clauses)) (if (eq (car-safe (cadr clauses)) 'progn) - (cl-cdadr clauses) + (cdadr clauses) (list (cadr clauses)))) (cddr clauses))) ;; A final (progn ,@A t) is moved outside of the `and'. @@ -2559,12 +2559,13 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). (push x macro-declarations-alist) (push x defun-declarations-alist))) +;;;###cl-autoload (defun cl--optimize (f _args &rest qualities) "Serve `cl-optimize' in function declarations. Example: -(defun foo (x) - (declare (cl-optimize (speed 3) (safety 0))) - x)" + (defun foo (x) + (declare (cl-optimize (speed 3) (safety 0))) + x)" ;; FIXME this should make use of `cl--declare-stack' but I suspect ;; this mechanism should be reviewed first. (cl-loop for (qly val) in qualities @@ -2612,7 +2613,7 @@ Example: ((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings)) (while (setq spec (cdr spec)) (if (consp (car spec)) - (if (eq (cl-cadar spec) 0) + (if (eq (cadar spec) 0) (byte-compile-disable-warning (caar spec)) (byte-compile-enable-warning (caar spec))))))) nil) @@ -3092,9 +3093,9 @@ To see the documentation for a defined struct type, use (t `(and (consp cl-x) (memq (nth ,pos cl-x) ,tag-symbol)))))) pred-check (and pred-form (> safety 0) - (if (and (eq (cl-caadr pred-form) 'vectorp) + (if (and (eq (caadr pred-form) 'vectorp) (= safety 1)) - (cons 'and (cl-cdddr pred-form)) + (cons 'and (cdddr pred-form)) `(,predicate cl-x)))) (when pred-form (push `(,defsym ,predicate (cl-x) @@ -3335,10 +3336,12 @@ the form NAME which is a shorthand for (NAME NAME)." :around #'cl--pcase-mutually-exclusive-p)) +;;;###cl-autoload (defun cl-struct-sequence-type (struct-type) "Return the sequence used to build STRUCT-TYPE. -STRUCT-TYPE is a symbol naming a struct type. Return `record', -`vector', or `list' if STRUCT-TYPE is a struct type, nil otherwise." +STRUCT-TYPE is a symbol naming a struct type. Return values are +either `vector', `list' or nil (and the latter indicates a +`record' struct type." (declare (side-effect-free t) (pure t)) (cl--struct-class-type (cl--struct-get-class struct-type))) @@ -3373,6 +3376,7 @@ slots skipped by :initial-offset may appear in the list." (define-error 'cl-struct-unknown-slot "struct has no slot") +;;;###cl-autoload (defun cl-struct-slot-offset (struct-type slot-name) "Return the offset of slot SLOT-NAME in STRUCT-TYPE. The returned zero-based slot index is relative to the start of @@ -3407,7 +3411,7 @@ Of course, we really can't know that for sure, so it's just a heuristic." (character . natnump) (char-table . char-table-p) (command . commandp) - (compiled-function . byte-code-function-p) + (compiled-function . compiled-function-p) (hash-table . hash-table-p) (cons . consp) (fixnum . fixnump) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 627bfc8516a..dbe20f92028 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -149,7 +149,7 @@ supertypes from the most specific to least specific.") (while (recordp parent) (add-to-list (cl--struct-class-children-sym parent) tag) ;; Only register ourselves as a child of the leftmost parent since structs - ;; can only only have one parent. + ;; can only have one parent. (setq parent (car (cl--struct-class-parents parent))))) ;;;###autoload diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index 64ae05bf2a0..60e204eaf51 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -139,6 +139,10 @@ only case where FUNCTION is called with fewer than two arguments. If SEQ contains exactly one element and no :INITIAL-VALUE is specified, then return that element and FUNCTION is not called. +If :FROM-END is non-nil, the reduction occurs from the back of +the SEQ moving forward, and the order of arguments to the +FUNCTION is also reversed. + \n(fn FUNCTION SEQ [KEYWORD VALUE]...)" (cl--parsing-keywords (:from-end (:start 0) :end :initial-value :key) () (or (listp cl-seq) (setq cl-seq (append cl-seq nil))) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 6451e34c42f..8cff06a383a 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -37,16 +37,12 @@ (require 'cl-lib) -(defconst comp--typeof-types (mapcar (lambda (x) - (append x '(t))) - cl--typeof-types) +(defconst comp--typeof-builtin-types (mapcar (lambda (x) + (append x '(t))) + cl--typeof-types) ;; TODO can we just add t in `cl--typeof-types'? "Like `cl--typeof-types' but with t as common supertype.") -(defconst comp--all-builtin-types - (append cl--all-builtin-types '(t)) - "Likewise like `cl--all-builtin-types' but with t as common supertype.") - (cl-defstruct (comp-cstr (:constructor comp-type-to-cstr (type &aux (null (eq type 'null)) @@ -234,7 +230,7 @@ Return them as multiple value." (cl-loop named outer with found = nil - for l in comp--typeof-types + for l in comp--typeof-builtin-types do (cl-loop for x in l for i from (length l) downto 0 @@ -277,7 +273,7 @@ Return them as multiple value." (cl-loop with types = (apply #'append typesets) with res = '() - for lane in comp--typeof-types + for lane in comp--typeof-builtin-types do (cl-loop with last = nil for x in lane diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 53803b38184..e10443588e4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -45,7 +45,9 @@ (defcustom native-comp-speed 2 "Optimization level for native compilation, a number between -1 and 3. - -1 functions are kept in bytecode form and no native compilation is performed. + -1 functions are kept in bytecode form and no native compilation is performed + (but *.eln files are still produced, and include the compiled code in + bytecode form). 0 native compilation is performed with no optimizations. 1 light optimizations. 2 max optimization level fully adherent to the language semantic. @@ -63,7 +65,7 @@ This is intended for debugging the compiler itself. 2 emit debug symbols and dump pseudo C code. 3 emit debug symbols and dump: pseudo C code, GCC intermediate passes and libgccjit log file." - :type 'integer + :type 'natnum :safe #'natnump :version "28.1") @@ -74,7 +76,7 @@ This is intended for debugging the compiler itself. 1 final LIMPLE is logged. 2 LAP, final LIMPLE, and some pass info are logged. 3 max verbosity." - :type 'integer + :type 'natnum :risky t :version "28.1") @@ -111,7 +113,7 @@ during bootstrap." "Default number of subprocesses used for async native compilation. Value of zero means to use half the number of the CPU's execution units, or one if there's just one execution unit." - :type 'integer + :type 'natnum :risky t :version "28.1") @@ -302,7 +304,7 @@ Useful to hook into pass checkers.") (bool-vector-subsetp (function (bool-vector bool-vector) boolean)) (boundp (function (symbol) boolean)) (buffer-end (function ((or number marker)) integer)) - (buffer-file-name (function (&optional buffer) string)) + (buffer-file-name (function (&optional buffer) (or string null))) (buffer-list (function (&optional frame) list)) (buffer-local-variables (function (&optional buffer) list)) (buffer-modified-p (function (&optional buffer) boolean)) @@ -319,8 +321,8 @@ Useful to hook into pass checkers.") (cdr (function (list) t)) (cdr-safe (function (t) t)) (ceiling (function (number &optional number) integer)) - (char-after (function (&optional (or marker integer)) fixnum)) - (char-before (function (&optional (or marker integer)) fixnum)) + (char-after (function (&optional (or marker integer)) (or fixnum null))) + (char-before (function (&optional (or marker integer)) (or fixnum null))) (char-equal (function (integer integer) boolean)) (char-or-string-p (function (t) boolean)) (char-to-string (function (fixnum) string)) @@ -342,14 +344,21 @@ Useful to hook into pass checkers.") (current-buffer (function () buffer)) (current-global-map (function () cons)) (current-indentation (function () integer)) - (current-local-map (function () cons)) - (current-minor-mode-maps (function () cons)) + (current-local-map (function () (or cons null))) + (current-minor-mode-maps (function () (or cons null))) (current-time (function () cons)) - (current-time-string (function (&optional string boolean) string)) - (current-time-zone (function (&optional string boolean) cons)) + (current-time-string (function (&optional (or number list) + (or symbol string cons integer)) + string)) + (current-time-zone (function (&optional (or number list) + (or symbol string cons integer)) + cons)) (custom-variable-p (function (symbol) boolean)) (decode-char (function (cons t) (or fixnum null))) - (decode-time (function (&optional string symbol symbol) cons)) + (decode-time (function (&optional (or number list) + (or symbol string cons integer) + symbol) + cons)) (default-boundp (function (symbol) boolean)) (default-value (function (symbol) t)) (degrees-to-radians (function (number) float)) @@ -381,12 +390,14 @@ Useful to hook into pass checkers.") (file-writable-p (function (string) boolean)) (fixnump (function (t) boolean)) (float (function (number) float)) - (float-time (function (&optional cons) float)) + (float-time (function (&optional (or number list)) float)) (floatp (function (t) boolean)) (floor (function (number &optional number) integer)) (following-char (function () fixnum)) (format (function (string &rest t) string)) - (format-time-string (function (string &optional cons symbol) string)) + (format-time-string (function (string &optional (or number list) + (or symbol string cons integer)) + string)) (frame-first-window (function ((or frame window)) window)) (frame-root-window (function (&optional (or frame window)) window)) (frame-selected-window (function (&optional (or frame window)) window)) @@ -398,8 +409,8 @@ Useful to hook into pass checkers.") (get-buffer (function ((or buffer string)) (or buffer null))) (get-buffer-window (function (&optional (or buffer string) (or symbol (integer 0 0))) (or null window))) (get-file-buffer (function (string) (or null buffer))) - (get-largest-window (function (&optional t t t) window)) - (get-lru-window (function (&optional t t t) window)) + (get-largest-window (function (&optional t t t) (or window null))) + (get-lru-window (function (&optional t t t) (or window null))) (getenv (function (string &optional frame) (or null string))) (gethash (function (t hash-table &optional t) t)) (hash-table-count (function (hash-table) integer)) @@ -448,7 +459,7 @@ Useful to hook into pass checkers.") (make-symbol (function (string) symbol)) (mark (function (&optional t) (or integer null))) (mark-marker (function () marker)) - (marker-buffer (function (marker) buffer)) + (marker-buffer (function (marker) (or buffer null))) (markerp (function (t) boolean)) (max (function ((or number marker) &rest (or number marker)) number)) (max-char (function () fixnum)) @@ -457,7 +468,7 @@ Useful to hook into pass checkers.") (memq (function (t list) list)) (memql (function (t list) list)) (min (function ((or number marker) &rest (or number marker)) number)) - (minibuffer-selected-window (function () window)) + (minibuffer-selected-window (function () (or window null))) (minibuffer-window (function (&optional frame) window)) (mod (function ((or number marker) (or number marker)) (or (integer 0 *) (float 0 *)))) (mouse-movement-p (function (t) boolean)) @@ -475,8 +486,8 @@ Useful to hook into pass checkers.") (one-window-p (function (&optional t t) boolean)) (overlayp (function (t) boolean)) (parse-colon-path (function (string) cons)) - (plist-get (function (list t) t)) - (plist-member (function (list t) list)) + (plist-get (function (list t &optional t) t)) + (plist-member (function (list t &optional t) list)) (point (function () integer)) (point-marker (function () marker)) (point-max (function () integer)) @@ -485,7 +496,7 @@ Useful to hook into pass checkers.") (previous-window (function (&optional window t t) window)) (prin1-to-string (function (t &optional t t) string)) (processp (function (t) boolean)) - (proper-list-p (function (t) integer)) + (proper-list-p (function (t) boolean)) (propertize (function (string &rest t) string)) (radians-to-degrees (function (number) float)) (rassoc (function (t list) list)) @@ -518,7 +529,7 @@ Useful to hook into pass checkers.") (string-to-char (function (string) fixnum)) (string-to-multibyte (function (string) string)) (string-to-number (function (string &optional integer) number)) - (string-to-syntax (function (string) cons)) + (string-to-syntax (function (string) (or cons null))) (string< (function ((or string symbol) (or string symbol)) boolean)) (string= (function ((or string symbol) (or string symbol)) boolean)) (stringp (function (t) boolean)) @@ -540,7 +551,8 @@ Useful to hook into pass checkers.") (this-command-keys-vector (function () vector)) (this-single-command-keys (function () vector)) (this-single-command-raw-keys (function () vector)) - (time-convert (function (t &optional (or boolean integer)) cons)) + (time-convert (function ((or number list) &optional (or symbol integer)) + (or cons number))) (truncate (function (number &optional number) integer)) (type-of (function (t) symbol)) (unibyte-char-to-multibyte (function (fixnum) fixnum)) ;; byte is fixnum @@ -3693,7 +3705,7 @@ Prepare every function for final compilation and drive the C back-end." (file-name-base output) "-") nil ".el"))) (with-temp-file temp-file - (insert ";; -*-coding: nil; -*-\n") + (insert ";; -*-coding: utf-8-emacs-unix; -*-\n") (mapc (lambda (e) (insert (prin1-to-string e))) expr)) @@ -4288,6 +4300,32 @@ of (commands) to run simultaneously." (let ((load (not (not load)))) (native--compile-async files recursively load selector))) +(defun native-compile-prune-cache () + "Remove .eln files that aren't applicable to the current Emacs invocation." + (interactive) + (unless (featurep 'native-compile) + (user-error "This Emacs isn't built with native-compile support")) + (dolist (dir native-comp-eln-load-path) + ;; If a directory is non absolute it is assumed to be relative to + ;; `invocation-directory'. + (setq dir (expand-file-name dir invocation-directory)) + (when (file-exists-p dir) + (dolist (subdir (directory-files dir t)) + (when (and (file-directory-p subdir) + (file-writable-p subdir) + (not (equal (file-name-nondirectory + (directory-file-name subdir)) + comp-native-version-dir))) + (message "Deleting %s..." subdir) + ;; We're being overly cautious here -- there shouldn't be + ;; anything but .eln files in these directories. + (dolist (eln (directory-files subdir t "\\.eln\\(\\.tmp\\)?\\'")) + (when (file-writable-p eln) + (delete-file eln))) + (when (directory-empty-p subdir) + (delete-directory subdir)))))) + (message "Cache cleared")) + (provide 'comp) ;; LocalWords: limplified limplified limplification limplify Limple LIMPLE libgccjit elc eln diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index 8a5c3d3730c..6d4b29b552c 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -77,38 +77,29 @@ ;;; Code: -;; FIXME I don't see that this needs to exist as a separate variable. -;; crm-separator should suffice. -(defconst crm-default-separator "[ \t]*,[ \t]*" - "Default value of `crm-separator'.") +(define-obsolete-variable-alias 'crm-default-separator 'crm-separator "29.1") -(defvar crm-separator crm-default-separator +(defvar crm-separator "[ \t]*,[ \t]*" "Separator regexp used for separating strings in `completing-read-multiple'. -It should be a regexp that does not match the list of completion candidates. -The default value is `crm-default-separator'.") - -(defvar crm-local-completion-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map minibuffer-local-completion-map) - (define-key map [remap minibuffer-complete] #'crm-complete) - (define-key map [remap minibuffer-complete-word] #'crm-complete-word) - (define-key map [remap minibuffer-completion-help] #'crm-completion-help) - map) - "Local keymap for minibuffer multiple input with completion. -Analog of `minibuffer-local-completion-map'.") - -(defvar crm-local-must-match-map - (let ((map (make-sparse-keymap))) - ;; We'd want to have multiple inheritance here. - (set-keymap-parent map minibuffer-local-must-match-map) - (define-key map [remap minibuffer-complete] #'crm-complete) - (define-key map [remap minibuffer-complete-word] #'crm-complete-word) - (define-key map [remap minibuffer-completion-help] #'crm-completion-help) - (define-key map [remap minibuffer-complete-and-exit] - #'crm-complete-and-exit) - map) - "Local keymap for minibuffer multiple input with exact match completion. -Analog of `minibuffer-local-must-match-map' for crm.") +It should be a regexp that does not match the list of completion candidates.") + +(defvar-keymap crm-local-completion-map + :doc "Local keymap for minibuffer multiple input with completion. +Analog of `minibuffer-local-completion-map'." + :parent minibuffer-local-completion-map + "<remap> <minibuffer-complete>" #'crm-complete + "<remap> <minibuffer-complete-word>" #'crm-complete-word + "<remap> <minibuffer-completion-help>" #'crm-completion-help) + +(defvar-keymap crm-local-must-match-map + :doc "Local keymap for minibuffer multiple input with exact match completion. +Analog of `minibuffer-local-must-match-map' for crm." + ;; We'd want to have multiple inheritance here. + :parent minibuffer-local-must-match-map + "<remap> <minibuffer-complete>" #'crm-complete + "<remap> <minibuffer-complete-word>" #'crm-complete-word + "<remap> <minibuffer-completion-help>" #'crm-completion-help + "<remap> <minibuffer-complete-and-exit>" #'crm-complete-and-exit) (defvar crm-completion-table nil "An alist whose elements' cars are strings, or an obarray. diff --git a/lisp/emacs-lisp/debug-early.el b/lisp/emacs-lisp/debug-early.el index 4f1f4b81557..a301c73017e 100644 --- a/lisp/emacs-lisp/debug-early.el +++ b/lisp/emacs-lisp/debug-early.el @@ -45,7 +45,13 @@ of the build process." (let ((print-escape-newlines t) (print-escape-control-characters t) (print-escape-nonascii t) - (prin1 (if (fboundp 'cl-prin1) #'cl-prin1 #'prin1))) + (prin1 (if (and (fboundp 'cl-prin1) + ;; If we're being called while + ;; bootstrapping, we won't be able to load + ;; cl-print. + (require 'cl-print nil t)) + #'cl-prin1 + #'prin1))) (mapbacktrace #'(lambda (evald func args _flags) (let ((args args)) diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index c4929eb2b01..460057b3afd 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -560,52 +560,53 @@ The environment used is the one when entering the activation frame at point." 'backtrace-toggle-locals "28.1") -(defvar debugger-mode-map - (let ((map (make-keymap))) - (set-keymap-parent map backtrace-mode-map) - (define-key map "b" 'debugger-frame) - (define-key map "c" 'debugger-continue) - (define-key map "j" 'debugger-jump) - (define-key map "r" 'debugger-return-value) - (define-key map "u" 'debugger-frame-clear) - (define-key map "d" 'debugger-step-through) - (define-key map "l" 'debugger-list-functions) - (define-key map "q" 'debugger-quit) - (define-key map "e" 'debugger-eval-expression) - (define-key map "R" 'debugger-record-expression) - (define-key map [mouse-2] 'push-button) - (easy-menu-define nil map "" - '("Debugger" - ["Step through" debugger-step-through - :help "Proceed, stepping through subexpressions of this expression"] - ["Continue" debugger-continue - :help "Continue, evaluating this expression without stopping"] - ["Jump" debugger-jump - :help "Continue to exit from this frame, with all debug-on-entry suspended"] - ["Eval Expression..." debugger-eval-expression - :help "Eval an expression, in an environment like that outside the debugger"] - ["Display and Record Expression" debugger-record-expression - :help "Display a variable's value and record it in `*Backtrace-record*' buffer"] - ["Return value..." debugger-return-value - :help "Continue, specifying value to return."] - "--" - ["Debug frame" debugger-frame - :help "Request entry to debugger when this frame exits"] - ["Cancel debug frame" debugger-frame-clear - :help "Do not enter debugger when this frame exits"] - ["List debug on entry functions" debugger-list-functions - :help "Display a list of all the functions now set to debug on entry"] - "--" - ["Next Line" next-line - :help "Move cursor down"] - ["Help for Symbol" backtrace-help-follow-symbol - :help "Show help for symbol at point"] - ["Describe Debugger Mode" describe-mode - :help "Display documentation for debugger-mode"] - "--" - ["Quit" debugger-quit - :help "Quit debugging and return to top level"])) - map)) +(defvar-keymap debugger-mode-map + :full t + :parent backtrace-mode-map + "b" #'debugger-frame + "c" #'debugger-continue + "j" #'debugger-jump + "r" #'debugger-return-value + "u" #'debugger-frame-clear + "d" #'debugger-step-through + "l" #'debugger-list-functions + "q" #'debugger-quit + "e" #'debugger-eval-expression + "R" #'debugger-record-expression + + "<mouse-2>" #'push-button + + :menu + '("Debugger" + ["Step through" debugger-step-through + :help "Proceed, stepping through subexpressions of this expression"] + ["Continue" debugger-continue + :help "Continue, evaluating this expression without stopping"] + ["Jump" debugger-jump + :help "Continue to exit from this frame, with all debug-on-entry suspended"] + ["Eval Expression..." debugger-eval-expression + :help "Eval an expression, in an environment like that outside the debugger"] + ["Display and Record Expression" debugger-record-expression + :help "Display a variable's value and record it in `*Backtrace-record*' buffer"] + ["Return value..." debugger-return-value + :help "Continue, specifying value to return."] + "--" + ["Debug frame" debugger-frame + :help "Request entry to debugger when this frame exits"] + ["Cancel debug frame" debugger-frame-clear + :help "Do not enter debugger when this frame exits"] + ["List debug on entry functions" debugger-list-functions + :help "Display a list of all the functions now set to debug on entry"] + "--" + ["Next Line" next-line + :help "Move cursor down"] + ["Help for Symbol" backtrace-help-follow-symbol + :help "Show help for symbol at point"] + ["Describe Debugger Mode" describe-mode + :help "Display documentation for debugger-mode"] + "--" + ["Quit" debugger-quit + :help "Quit debugging and return to top level"])) (put 'debugger-mode 'mode-class 'special) diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index 8912eb10cc5..260fc3bf470 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -1,10 +1,9 @@ ;;; derived.el --- allow inheritance of major modes -*- lexical-binding: t; -*- ;; (formerly mode-clone.el) -;; Copyright (C) 1993-1994, 1999, 2001-2022 Free Software Foundation, -;; Inc. +;; Copyright (C) 1993-2022 Free Software Foundation, Inc. -;; Author: David Megginson (dmeggins@aix1.uottawa.ca) +;; Author: David Megginson <dmeggins@aix1.uottawa.ca> ;; Maintainer: emacs-devel@gnu.org ;; Keywords: extensions ;; Package: emacs diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 54cac116168..c3a4e9fc7ab 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -408,7 +408,7 @@ or call the function `%s'.")))) No problems result if this variable is not bound. `add-hook' automatically binds it. (This is true for all hook variables.)" modefun))) - ;; Allow using using `M-x customize-variable' on the hook. + ;; Allow using `M-x customize-variable' on the hook. (put ',hook 'custom-type 'hook) (put ',hook 'standard-value (list nil)) @@ -576,7 +576,7 @@ and nil means \"don't use\". There's an implicit nil at the end of the list." mode) :type '(repeat sexp) - :group ,group)) + ,@group)) ;; Autoloading define-globalized-minor-mode autoloads everything ;; up-to-here. diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el index 43ce1872f9b..41e3a197af4 100644 --- a/lisp/emacs-lisp/easymenu.el +++ b/lisp/emacs-lisp/easymenu.el @@ -492,25 +492,11 @@ To implement dynamic menus, either call this from `menu-bar-update-hook' or use a menu filter." (easy-menu-add-item map path (easy-menu-create-menu name items) before)) -(defalias 'easy-menu-remove #'ignore - "Remove MENU from the current menu bar. -Contrary to XEmacs, this is a nop on Emacs since menus are automatically -\(de)activated when the corresponding keymap is (de)activated. - -\(fn MENU)") +(defalias 'easy-menu-remove #'ignore) (make-obsolete 'easy-menu-remove "this was always a no-op in Emacs \ and can be safely removed." "28.1") -(defalias 'easy-menu-add #'ignore - "Add the menu to the menubar. -On Emacs this is a nop, because menus are already automatically -activated when the corresponding keymap is activated. On XEmacs -this is needed to actually add the menu to the current menubar. - -You should call this once the menu and keybindings are set up -completely and menu filter functions can be expected to work. - -\(fn MENU &optional MAP)") +(defalias 'easy-menu-add #'ignore) (make-obsolete 'easy-menu-add "this was always a no-op in Emacs \ and can be safely removed." "28.1") diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 9dc5a1315e5..9de8999fdfd 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -675,7 +675,7 @@ Maybe clear the markers and delete the symbol's edebug property?" (or (and (eq (aref edebug-read-syntax-table (following-char)) 'symbol) (not (= (following-char) ?\;))) - (memq (following-char) '(?\, ?\.))))) + (eq (following-char) ?.)))) 'symbol (aref edebug-read-syntax-table (following-char)))) @@ -864,7 +864,7 @@ marker. The needed data will then come from property (defun edebug-read-special (stream) "Read from STREAM a Lisp object beginning with #. -Turn #'thing into (function thing) and handle the read syntax for +Turn #\\='thing into (function thing) and handle the read syntax for circular objects. Let `read' read everything else." (catch 'return (forward-char 1) @@ -2861,7 +2861,6 @@ See `edebug-behavior-alist' for implementations.") (this-command this-command) (current-prefix-arg nil) - ;; More for Emacs 19 (last-input-event nil) (last-command-event nil) (last-event-frame nil) @@ -3707,46 +3706,64 @@ Return the result of the last expression." (defalias 'edebug-format #'format-message) (defalias 'edebug-message #'message) -(defun edebug-eval-expression (expr) +(defun edebug-eval-expression (expr &optional pp) "Evaluate an expression in the outside environment. If interactive, prompt for the expression. -Print result in minibuffer." - (interactive (list (read--expression "Eval: "))) + +Print result in minibuffer by default, but if PP is non-nil open +a new window and pretty-print the result there. (Interactively, +this is the prefix key.)" + (interactive (list (read--expression "Edebug eval: ") + current-prefix-arg)) (let* ((errored nil) - (result + (value (edebug-outside-excursion - (let ((result (if debug-allow-recursive-debug - (edebug-eval expr) - (condition-case err - (edebug-eval expr) - (error - (setq errored - (format "%s: %s" - (get (car err) 'error-message) - (car (cdr err))))))))) - (unless errored - (values--store-value result) - (concat (edebug-safe-prin1-to-string result) - (eval-expression-print-format result))))))) - (if errored - (message "Error: %s" errored) - (princ result)))) - -(defun edebug-eval-last-sexp (&optional no-truncate) - "Evaluate sexp before point in the outside environment. -Print value in minibuffer. + (if debug-allow-recursive-debug + (edebug-eval expr) + (condition-case err + (edebug-eval expr) + (error + (setq errored + (format "%s: %s" + (get (car err) 'error-message) + (car (cdr err))))))))) + (result + (unless errored + (values--store-value value) + (concat (edebug-safe-prin1-to-string value) + (eval-expression-print-format value))))) + (cond + (errored + (message "Error: %s" errored)) + (pp + (save-selected-window + (pop-to-buffer "*Edebug Results*") + (erase-buffer) + (pp value (current-buffer)) + (goto-char (point-min)) + (lisp-data-mode))) + (t + (princ result))))) -If NO-TRUNCATE is non-nil (or interactively with a prefix -argument of zero), show the full length of the expression, not -limited by `edebug-print-length' or `edebug-print-level'." +(defun edebug-eval-last-sexp (&optional display-type) + "Evaluate sexp before point in the outside environment. +If DISPLAY-TYPE is `pretty-print' (interactively, a non-zero +prefix argument), pretty-print the value in a separate buffer. +Otherwise, print the value in minibuffer. If DISPLAY-TYPE is any +other non-nil value (or interactively with a prefix argument of +zero), show the full length of the expression, not limited by +`edebug-print-length' or `edebug-print-level'." (interactive (list (and current-prefix-arg - (zerop (prefix-numeric-value current-prefix-arg))))) - (if no-truncate - (let ((edebug-print-length nil) - (edebug-print-level nil)) - (edebug-eval-expression (edebug-last-sexp))) - (edebug-eval-expression (edebug-last-sexp)))) + (if (zerop (prefix-numeric-value current-prefix-arg)) + 'no-truncate + 'pretty-print)))) + (if (or (null display-type) + (eq display-type 'pretty-print)) + (edebug-eval-expression (edebug-last-sexp) display-type) + (let ((edebug-print-length nil) + (edebug-print-level nil)) + (edebug-eval-expression (edebug-last-sexp))))) (defun edebug-eval-print-last-sexp (&optional no-truncate) "Evaluate sexp before point in outside environment; insert value. @@ -3791,74 +3808,72 @@ be installed in `emacs-lisp-mode-map'.") ;; The following isn't a GUD binding. (define-key emacs-lisp-mode-map "\C-x\C-a\C-m" 'edebug-set-initial-mode)) -(defvar edebug-mode-map - (let ((map (copy-keymap emacs-lisp-mode-map))) - ;; control - (define-key map " " 'edebug-step-mode) - (define-key map "n" 'edebug-next-mode) - (define-key map "g" 'edebug-go-mode) - (define-key map "G" 'edebug-Go-nonstop-mode) - (define-key map "t" 'edebug-trace-mode) - (define-key map "T" 'edebug-Trace-fast-mode) - (define-key map "c" 'edebug-continue-mode) - (define-key map "C" 'edebug-Continue-fast-mode) - - ;;(define-key map "f" 'edebug-forward) not implemented - (define-key map "f" 'edebug-forward-sexp) - (define-key map "h" 'edebug-goto-here) - - (define-key map "I" 'edebug-instrument-callee) - (define-key map "i" 'edebug-step-in) - (define-key map "o" 'edebug-step-out) - - ;; quitting and stopping - (define-key map "q" 'top-level) - (define-key map "Q" 'edebug-top-level-nonstop) - (define-key map "a" 'abort-recursive-edit) - (define-key map "S" 'edebug-stop) - - ;; breakpoints - (define-key map "b" 'edebug-set-breakpoint) - (define-key map "u" 'edebug-unset-breakpoint) - (define-key map "U" 'edebug-unset-breakpoints) - (define-key map "B" 'edebug-next-breakpoint) - (define-key map "x" 'edebug-set-conditional-breakpoint) - (define-key map "X" 'edebug-set-global-break-condition) - (define-key map "D" 'edebug-toggle-disable-breakpoint) - - ;; evaluation - (define-key map "r" 'edebug-previous-result) - (define-key map "e" 'edebug-eval-expression) - (define-key map "\C-x\C-e" 'edebug-eval-last-sexp) - (define-key map "E" 'edebug-visit-eval-list) - - ;; views - (define-key map "w" 'edebug-where) - (define-key map "v" 'edebug-view-outside) ;; maybe obsolete?? - (define-key map "p" 'edebug-bounce-point) - (define-key map "P" 'edebug-view-outside) ;; same as v - (define-key map "W" 'edebug-toggle-save-windows) - - ;; misc - (define-key map "?" 'edebug-help) - (define-key map "d" 'edebug-pop-to-backtrace) - - (define-key map "-" 'negative-argument) - - ;; statistics - (define-key map "=" 'edebug-temp-display-freq-count) - - ;; GUD bindings - (define-key map "\C-c\C-s" 'edebug-step-mode) - (define-key map "\C-c\C-n" 'edebug-next-mode) - (define-key map "\C-c\C-c" 'edebug-go-mode) - - (define-key map "\C-x " 'edebug-set-breakpoint) - (define-key map "\C-c\C-d" 'edebug-unset-breakpoint) - (define-key map "\C-c\C-t" - (lambda () (interactive) (edebug-set-breakpoint t))) - (define-key map "\C-c\C-l" 'edebug-where) - map)) +(defvar-keymap edebug-mode-map + :parent emacs-lisp-mode-map + ;; control + "SPC" #'edebug-step-mode + "n" #'edebug-next-mode + "g" #'edebug-go-mode + "G" #'edebug-Go-nonstop-mode + "t" #'edebug-trace-mode + "T" #'edebug-Trace-fast-mode + "c" #'edebug-continue-mode + "C" #'edebug-Continue-fast-mode + + ;;"f" #'edebug-forward ; not implemented + "f" #'edebug-forward-sexp + "h" #'edebug-goto-here + + "I" #'edebug-instrument-callee + "i" #'edebug-step-in + "o" #'edebug-step-out + + ;; quitting and stopping + "q" #'top-level + "Q" #'edebug-top-level-nonstop + "a" #'abort-recursive-edit + "S" #'edebug-stop + + ;; breakpoints + "b" #'edebug-set-breakpoint + "u" #'edebug-unset-breakpoint + "U" #'edebug-unset-breakpoints + "B" #'edebug-next-breakpoint + "x" #'edebug-set-conditional-breakpoint + "X" #'edebug-set-global-break-condition + "D" #'edebug-toggle-disable-breakpoint + + ;; evaluation + "r" #'edebug-previous-result + "e" #'edebug-eval-expression + "C-x C-e" #'edebug-eval-last-sexp + "E" #'edebug-visit-eval-list + + ;; views + "w" #'edebug-where + "v" #'edebug-view-outside ; maybe obsolete?? + "p" #'edebug-bounce-point + "P" #'edebug-view-outside ; same as v + "W" #'edebug-toggle-save-windows + + ;; misc + "?" #'edebug-help + "d" #'edebug-pop-to-backtrace + + "-" #'negative-argument + + ;; statistics + "=" #'edebug-temp-display-freq-count + + ;; GUD bindings + "C-c C-s" #'edebug-step-mode + "C-c C-n" #'edebug-next-mode + "C-c C-c" #'edebug-go-mode + + "C-x SPC" #'edebug-set-breakpoint + "C-c C-d" #'edebug-unset-breakpoint + "C-c C-t" (lambda () (interactive) (edebug-set-breakpoint t)) + "C-c C-l" #'edebug-where) ;; Autoloading these global bindings doesn't make sense because ;; they cannot be used anyway unless Edebug is already loaded and active. @@ -3873,38 +3888,35 @@ be installed in `emacs-lisp-mode-map'.") (define-obsolete-variable-alias 'global-edebug-map 'edebug-global-map "28.1") -(defvar edebug-global-map - (let ((map (make-sparse-keymap))) - - (define-key map " " 'edebug-step-mode) - (define-key map "g" 'edebug-go-mode) - (define-key map "G" 'edebug-Go-nonstop-mode) - (define-key map "t" 'edebug-trace-mode) - (define-key map "T" 'edebug-Trace-fast-mode) - (define-key map "c" 'edebug-continue-mode) - (define-key map "C" 'edebug-Continue-fast-mode) - - ;; breakpoints - (define-key map "b" 'edebug-set-breakpoint) - (define-key map "u" 'edebug-unset-breakpoint) - (define-key map "U" 'edebug-unset-breakpoints) - (define-key map "x" 'edebug-set-conditional-breakpoint) - (define-key map "X" 'edebug-set-global-break-condition) - (define-key map "D" 'edebug-toggle-disable-breakpoint) - - ;; views - (define-key map "w" 'edebug-where) - (define-key map "W" 'edebug-toggle-save-windows) - - ;; quitting - (define-key map "q" 'top-level) - (define-key map "Q" 'edebug-top-level-nonstop) - (define-key map "a" 'abort-recursive-edit) - - ;; statistics - (define-key map "=" 'edebug-display-freq-count) - map) - "Global map of edebug commands, available from any buffer.") +(defvar-keymap edebug-global-map + :doc "Global map of edebug commands, available from any buffer." + "SPC" #'edebug-step-mode + "g" #'edebug-go-mode + "G" #'edebug-Go-nonstop-mode + "t" #'edebug-trace-mode + "T" #'edebug-Trace-fast-mode + "c" #'edebug-continue-mode + "C" #'edebug-Continue-fast-mode + + ;; breakpoints + "b" #'edebug-set-breakpoint + "u" #'edebug-unset-breakpoint + "U" #'edebug-unset-breakpoints + "x" #'edebug-set-conditional-breakpoint + "X" #'edebug-set-global-break-condition + "D" #'edebug-toggle-disable-breakpoint + + ;; views + "w" #'edebug-where + "W" #'edebug-toggle-save-windows + + ;; quitting + "q" #'top-level + "Q" #'edebug-top-level-nonstop + "a" #'abort-recursive-edit + + ;; statistics + "=" #'edebug-display-freq-count) (when edebug-global-prefix (global-unset-key edebug-global-prefix) @@ -4075,16 +4087,14 @@ May only be called from within `edebug--recursive-edit'." -(defvar edebug-eval-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map lisp-interaction-mode-map) - (define-key map "\C-c\C-w" 'edebug-where) - (define-key map "\C-c\C-d" 'edebug-delete-eval-item) - (define-key map "\C-c\C-u" 'edebug-update-eval-list) - (define-key map "\C-x\C-e" 'edebug-eval-last-sexp) - (define-key map "\C-j" 'edebug-eval-print-last-sexp) - map) - "Keymap for Edebug Eval mode. Superset of Lisp Interaction mode.") +(defvar-keymap edebug-eval-mode-map + :doc "Keymap for Edebug Eval mode. Superset of Lisp Interaction mode." + :parent lisp-interaction-mode-map + "C-c C-w" #'edebug-where + "C-c C-d" #'edebug-delete-eval-item + "C-c C-u" #'edebug-update-eval-list + "C-x C-e" #'edebug-eval-last-sexp + "C-j" #'edebug-eval-print-last-sexp) (put 'edebug-eval-mode 'mode-class 'special) diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index 4c702deaa95..ef02216411d 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -281,32 +281,26 @@ being pedantic." (unless class (warn "`eieio-persistent-read' called without specifying a class")) (when class (cl-check-type class class)) - (let ((ret nil) - (buffstr nil)) - (unwind-protect - (progn - (with-current-buffer (get-buffer-create " *tmp eieio read*") - (insert-file-contents filename nil nil nil t) - (goto-char (point-min)) - (setq buffstr (buffer-string))) - ;; Do the read in the buffer the read was initialized from - ;; so that any initialize-instance calls that depend on - ;; the current buffer will work. - (setq ret (read buffstr)) - (when (not (child-of-class-p (car ret) 'eieio-persistent)) - (error - "Invalid object: %s is not a subclass of `eieio-persistent'" - (car ret))) - (when (and class - (not (or (eq (car ret) class) ; same class - (and allow-subclass ; subclass - (child-of-class-p (car ret) class))))) - (error - "Invalid object: %s is not an object of class %s nor a subclass" - (car ret) class)) - (setq ret (eieio-persistent-make-instance (car ret) (cdr ret))) - (oset ret file filename)) - (kill-buffer " *tmp eieio read*")) + (let* ((buffstr (with-temp-buffer + (insert-file-contents filename) + (buffer-string))) + ;; Do the read in the buffer the read was initialized from + ;; so that any initialize-instance calls that depend on + ;; the current buffer will work. + (ret (read buffstr))) + (when (not (child-of-class-p (car ret) 'eieio-persistent)) + (error + "Invalid object: %s is not a subclass of `eieio-persistent'" + (car ret))) + (when (and class + (not (or (eq (car ret) class) ; same class + (and allow-subclass ; subclass + (child-of-class-p (car ret) class))))) + (error + "Invalid object: %s is not an object of class %s nor a subclass" + (car ret) class)) + (setq ret (eieio-persistent-make-instance (car ret) (cdr ret))) + (oset ret file filename) ret)) (cl-defgeneric eieio-persistent-make-instance (objclass inputlist) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index d9864e6965d..5e7b5cbfb2f 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -24,15 +24,14 @@ ;;; Commentary: ;; ;; The "core" part of EIEIO is the implementation for the object -;; system (such as eieio-defclass, or eieio-defmethod) but not the -;; base classes for the object system, which are defined in EIEIO. +;; system (such as eieio-defclass-internal, or cl-defmethod) but not +;; the base classes for the object system, which are defined in EIEIO. ;; ;; See the commentary for eieio.el for more about EIEIO itself. ;;; Code: (require 'cl-lib) -(require 'eieio-loaddefs nil t) ;;; ;; A few functions that are better in the official EIEIO src, but diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el index ebb6f2cd8c8..0bec3bb0d59 100644 --- a/lisp/emacs-lisp/eieio-custom.el +++ b/lisp/emacs-lisp/eieio-custom.el @@ -329,11 +329,9 @@ Argument OBJ is the object that has been customized." Optional argument GROUP is the sub-group of slots to display." (eieio-customize-object obj group)) -(defvar eieio-custom-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map widget-keymap) - map) - "Keymap for EIEIO Custom mode.") +(defvar-keymap eieio-custom-mode-map + :doc "Keymap for EIEIO Custom mode." + :parent widget-keymap) (define-derived-mode eieio-custom-mode fundamental-mode "EIEIO Custom" "Major mode for customizing EIEIO objects. @@ -469,8 +467,4 @@ Return the symbol for the group, or nil." (provide 'eieio-custom) -;; Local variables: -;; generated-autoload-file: "eieio-loaddefs.el" -;; End: - ;;; eieio-custom.el ends here diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 72108f807f9..5f67263f177 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -348,8 +348,4 @@ INDENT is the current indentation level." (provide 'eieio-opt) -;; Local variables: -;; generated-autoload-file: "eieio-loaddefs.el" -;; End: - ;;; eieio-opt.el ends here diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 565eaf2d733..984166b593a 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -689,6 +689,7 @@ This class is not stored in the `parent' slot of a class vector." (define-obsolete-function-alias 'standard-class #'eieio-default-superclass "26.1") +;;;###autoload (cl-defgeneric make-instance (class &rest initargs) "Make a new instance of CLASS based on INITARGS. For example: diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 0b8078579cc..6fd89a690dc 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -5,7 +5,7 @@ ;; Author: Noah Friedman <friedman@splode.com> ;; Keywords: extensions ;; Created: 1995-10-06 -;; Version: 1.12.0 +;; Version: 1.13.0 ;; Package-Requires: ((emacs "26.3")) ;; This is a GNU ELPA :core package. Avoid functionality that is not @@ -381,7 +381,6 @@ Also store it in `eldoc-last-message' and return that value." (defun eldoc-display-message-no-interference-p () "Return nil if displaying a message would cause interference." (not (or executing-kbd-macro - (bound-and-true-p edebug-active) ;; The following configuration shows "Matches..." in the ;; echo area when point is after a closing bracket, which ;; conflicts with eldoc. @@ -491,9 +490,9 @@ If INTERACTIVE, display it. Else, return said buffer." (setq-local eldoc--doc-buffer-docs docs) (let ((inhibit-read-only t) (things-reported-on)) - (erase-buffer) (setq buffer-read-only t) + (special-mode) + (erase-buffer) (setq-local nobreak-char-display nil) - (local-set-key "q" 'quit-window) (cl-loop for (docs . rest) on docs for (this-doc . plist) = docs for thing = (plist-get plist :thing) @@ -551,12 +550,13 @@ Helper for `eldoc-display-in-echo-area'." (defun eldoc--echo-area-prefer-doc-buffer-p (truncatedp) "Tell if display in the echo area should be skipped. Helper for `eldoc-display-in-echo-area'. If TRUNCATEDP the -documentation to potentially appear in the echo are is truncated." +documentation to potentially appear in the echo area is +known to be truncated." (and (or (eq eldoc-echo-area-prefer-doc-buffer t) (and truncatedp (eq eldoc-echo-area-prefer-doc-buffer 'maybe))) - (get-buffer-window eldoc--doc-buffer 'visible))) + (get-buffer-window eldoc--doc-buffer t))) (defun eldoc-display-in-echo-area (docs _interactive) "Display DOCS in echo area. @@ -629,8 +629,7 @@ Honor `eldoc-echo-area-use-multiline-p' and "Display DOCS in a dedicated buffer. If INTERACTIVE is t, also display the buffer." (eldoc--format-doc-buffer docs) - (when interactive - (eldoc-doc-buffer))) + (when interactive (eldoc-doc-buffer t))) (defun eldoc-documentation-default () "Show first doc string for item at point. @@ -812,7 +811,7 @@ function passes responsibility to the functions in Other third-party values of `eldoc-documentation-strategy' should not use `eldoc--make-callback'. They must find some alternate way to produce callbacks to feed to -`eldoc-documentation-functions' and should endeavour to display +`eldoc-documentation-functions' and should endeavor to display the docstrings eventually produced, using `eldoc-display-functions'." (let* (;; How many callbacks have been created by the strategy diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el index 385ddb3f414..cbf38e7dd88 100644 --- a/lisp/emacs-lisp/elp.el +++ b/lisp/emacs-lisp/elp.el @@ -111,7 +111,7 @@ ;; provide the functionality or interface that I wanted, so I wrote ;; this. -;; Unlike previous profilers, elp uses Emacs 19's built-in function +;; Unlike previous profilers, elp uses the built-in function ;; current-time to return interval times. This obviates the need for ;; both an external C program and Emacs processes to communicate with ;; such a program, and thus simplifies the package as a whole. @@ -472,13 +472,11 @@ original definition, use \\[elp-restore-function] or \\[elp-restore-all]." (insert atstr)) (insert "\n")))) -(defvar elp-results-symname-map - (let ((map (make-sparse-keymap))) - (define-key map [mouse-2] 'elp-results-jump-to-definition) - (define-key map [follow-link] 'mouse-face) - (define-key map "\C-m" 'elp-results-jump-to-definition) - map) - "Keymap used on the function name column." ) +(defvar-keymap elp-results-symname-map + :doc "Keymap used on the function name column." + "<mouse-2>" #'elp-results-jump-to-definition + "<follow-link>" 'mouse-face + "RET" #'elp-results-jump-to-definition) (defun elp-results-jump-to-definition (&optional event) "Jump to the definition of the function at point." diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index de18adff5b8..4436d0a4b16 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -158,9 +158,6 @@ test for `called-interactively' in the command will fail." (run-hooks 'pre-command-hook) (setq return-value (apply (car command) (cdr command))) (run-hooks 'post-command-hook) - (and (boundp 'deferred-action-list) - deferred-action-list - (run-hooks 'deferred-action-function)) (setq real-last-command (car command) last-command this-command) (when (boundp 'last-repeatable-command) @@ -491,9 +488,13 @@ The same keyword arguments are supported as in (string-match "Apple \\(LLVM\\|[Cc]lang\\)\\|Xcode\\.app" (shell-command-to-string "gcc --version"))) - -(defvar tramp-methods) (defvar tramp-default-host-alist) +(defvar tramp-methods) +(defvar tramp-remote-path) + +;; This should happen on hydra only. +(when (and (featurep 'tramp) (getenv "EMACS_HYDRA_CI")) + (add-to-list 'tramp-remote-path 'tramp-own-remote-path)) ;; If this defconst is used in a test file, `tramp' shall be loaded ;; prior `ert-x'. There is no default value on w32 systems, which diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 82722add42a..047b0069bb9 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -1,6 +1,6 @@ ;;; ert.el --- Emacs Lisp Regression Testing -*- lexical-binding: t -*- -;; Copyright (C) 2007-2008, 2010-2022 Free Software Foundation, Inc. +;; Copyright (C) 2007-2022 Free Software Foundation, Inc. ;; Author: Christian Ohler <ohler@gnu.org> ;; Keywords: lisp, tools @@ -46,14 +46,10 @@ ;; processing further, this is useful for checking the test ;; environment (like availability of features, external binaries, etc). ;; -;; See ERT's info manual as well as the docstrings for more details. -;; To compile the manual, run `makeinfo ert.texinfo' in the ERT -;; directory, then C-u M-x info ert.info in Emacs to view it. -;; -;; To see some examples of tests written in ERT, see its self-tests in -;; ert-tests.el. Some of these are tricky due to the bootstrapping -;; problem of writing tests for a testing tool, others test simple -;; functions and are straightforward. +;; See ERT's Info manual `(ert) Top' as well as the docstrings for +;; more details. To see some examples of tests written in ERT, see +;; the test suite distributed with the Emacs source distribution (in +;; the "test" directory). ;;; Code: @@ -1696,7 +1692,7 @@ test packages depend on each other, it might be helpful.") (string-match-p "^Running 0 tests" logfile-contents)) (insert (format " <testsuite id=\"%s\" name=\"%s\" tests=\"1\" errors=\"1\" failures=\"0\" skipped=\"0\" time=\"0\" timestamp=\"%s\">\n" id test-report - (ert--format-time-iso8601 (current-time)))) + (ert--format-time-iso8601 nil))) (insert (format " <testcase name=\"Test report missing %s\" status=\"error\" time=\"0\">\n" (file-name-nondirectory test-report))) (insert (format " <error message=\"Test report missing %s\" type=\"error\">\n" @@ -1817,8 +1813,7 @@ Ran \\([0-9]+\\) tests, \\([0-9]+\\) results as expected\ (unless (or (null tests) (zerop high)) (message "\nLONG-RUNNING TESTS") (message "------------------") - (setq tests (sort tests (lambda (x y) (> (car x) (car y))))) - (when (< high (length tests)) (setcdr (nthcdr (1- high) tests) nil)) + (setq tests (ntake high (sort tests (lambda (x y) (> (car x) (car y)))))) (message "%s" (mapconcat #'cdr tests "\n"))) ;; More details on hydra and emba, where the logs are harder to get to. (when (and (or (getenv "EMACS_HYDRA_CI") (getenv "EMACS_EMBA_CI")) @@ -2884,8 +2879,14 @@ To be used in the ERT results buffer." nil) (defun ert-test-erts-file (file &optional transform) - "Parse FILE as a file containing before/after parts. -TRANSFORM will be called to get from before to after." + "Parse FILE as a file containing before/after parts (an erts file). + +This function puts the \"before\" section of an .erts file into a +temporary buffer, calls the TRANSFORM function, and then compares +the result with the \"after\" section. + +See Info node `(ert) erts files' for more information on how to +write erts files." (with-temp-buffer (insert-file-contents file) (let ((gen-specs (list (cons 'dummy t) diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index ac84b50b5fc..486d5d08614 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -800,7 +800,10 @@ See `find-function-on-key'." (define-key ctl-x-5-map "K" 'find-function-on-key-other-frame) (define-key ctl-x-map "V" 'find-variable) (define-key ctl-x-4-map "V" 'find-variable-other-window) - (define-key ctl-x-5-map "V" 'find-variable-other-frame)) + (define-key ctl-x-5-map "V" 'find-variable-other-frame) + (define-key ctl-x-map "L" 'find-library) + (define-key ctl-x-4-map "L" 'find-library-other-window) + (define-key ctl-x-5-map "L" 'find-library-other-frame)) (provide 'find-func) diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 7cfa1f2dadc..eaab6439adb 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -92,6 +92,9 @@ DO must return an Elisp expression." (t (let* ((head (car place)) (gf (function-get head 'gv-expander 'autoload))) + (when (and (symbolp head) + (get head 'byte-obsolete-generalized-variable)) + (byte-compile-warn-obsolete head "generalized variable")) (if gf (apply gf do (cdr place)) (let ((me (macroexpand-1 place ;; (append macroexpand-all-environment @@ -166,6 +169,18 @@ arguments as NAME. DO is a function as defined in `gv-get'." ;; (`(expand ,expander) `(gv-define-expand ,name ,expander)) (_ (message "Unknown %s declaration %S" symbol handler) nil)))) +(defun make-obsolete-generalized-variable (obsolete-name current-name when) + "Make byte-compiler warn that generalized variable OBSOLETE-NAME is obsolete. +The warning will say that CURRENT-NAME should be used instead. + +If CURRENT-NAME is a string, that is the `use instead' message. + +WHEN should be a string indicating when the variable was first +made obsolete, for example a date or a release number." + (put obsolete-name 'byte-obsolete-generalized-variable + (purecopy (list current-name when))) + obsolete-name) + ;; Additions for `declare'. We specify the values as named aliases so ;; that `describe-variable' prints something useful; cf. Bug#40491. @@ -392,6 +407,7 @@ The return value is the last VAL in the list. (gv-define-setter buffer-local-value (val var buf) (macroexp-let2 nil v val `(with-current-buffer ,buf (set (make-local-variable ,var) ,v)))) +(make-obsolete-generalized-variable 'buffer-local-value nil "29.1") (gv-define-expander alist-get (lambda (do key alist &optional default remove testfn) @@ -602,7 +618,7 @@ This is like the `*' operator of the C language. REF must have been previously obtained with `gv-ref'." (funcall (car ref))) ;; Don't use `declare' because it seems to introduce circularity problems: -;; Warning: Eager macro-expansion skipped due to cycle: +;; Eager macro-expansion skipped due to cycle: ;; … => (load "gv.el") => (macroexpand-all (defsubst gv-deref …)) => (macroexpand (defun …)) => (load "gv.el") (gv-define-setter gv-deref (v ref) `(funcall (cdr ,ref) ,v)) @@ -618,71 +634,160 @@ REF must have been previously obtained with `gv-ref'." ;; Some Emacs-related place types. (gv-define-simple-setter buffer-file-name set-visited-file-name t) +(make-obsolete-generalized-variable + 'buffer-file-name 'set-visited-file-name "29.1") + (gv-define-setter buffer-modified-p (flag &optional buf) (macroexp-let2 nil buffer `(or ,buf (current-buffer)) `(with-current-buffer ,buffer (set-buffer-modified-p ,flag)))) +(make-obsolete-generalized-variable + 'buffer-modified-p 'set-buffer-modified-p "29.1") + (gv-define-simple-setter buffer-name rename-buffer t) +(make-obsolete-generalized-variable 'buffer-name 'rename-buffer "29.1") + (gv-define-setter buffer-string (store) `(insert (prog1 ,store (erase-buffer)))) +(make-obsolete-generalized-variable 'buffer-string nil "29.1") + (gv-define-simple-setter buffer-substring cl--set-buffer-substring) +(make-obsolete-generalized-variable 'buffer-substring nil "29.1") + (gv-define-simple-setter current-buffer set-buffer) +(make-obsolete-generalized-variable 'current-buffer 'set-buffer "29.1") + (gv-define-simple-setter current-column move-to-column t) +(make-obsolete-generalized-variable 'current-column 'move-to-column "29.1") + (gv-define-simple-setter current-global-map use-global-map t) +(make-obsolete-generalized-variable 'current-global-map 'use-global-map "29.1") + (gv-define-setter current-input-mode (store) `(progn (apply #'set-input-mode ,store) ,store)) +(make-obsolete-generalized-variable 'current-input-mode nil "29.1") + (gv-define-simple-setter current-local-map use-local-map t) +(make-obsolete-generalized-variable 'current-local-map 'use-local-map "29.1") + (gv-define-simple-setter current-window-configuration set-window-configuration t) +(make-obsolete-generalized-variable + 'current-window-configuration 'set-window-configuration "29.1") + (gv-define-simple-setter default-file-modes set-default-file-modes t) +(make-obsolete-generalized-variable + 'default-file-modes 'set-default-file-modes "29.1") + (gv-define-simple-setter documentation-property put) +(make-obsolete-generalized-variable 'documentation-property 'put "29.1") + (gv-define-setter face-background (x f &optional s) `(set-face-background ,f ,x ,s)) (gv-define-setter face-background-pixmap (x f &optional s) - `(set-face-background-pixmap ,f ,x ,s)) + `(set-face-stipple ,f ,x ,s)) +(make-obsolete-generalized-variable 'face-background-pixmap 'face-stipple "29.1") +(gv-define-setter face-stipple (x f &optional s) + `(set-face-stipple ,f ,x ,s)) (gv-define-setter face-font (x f &optional s) `(set-face-font ,f ,x ,s)) (gv-define-setter face-foreground (x f &optional s) `(set-face-foreground ,f ,x ,s)) (gv-define-setter face-underline-p (x f &optional s) `(set-face-underline ,f ,x ,s)) (gv-define-simple-setter file-modes set-file-modes t) + (gv-define-setter frame-height (x &optional frame) `(set-frame-height (or ,frame (selected-frame)) ,x)) +(make-obsolete-generalized-variable 'frame-height 'set-frame-height "29.1") + (gv-define-simple-setter frame-parameters modify-frame-parameters t) (gv-define-simple-setter frame-visible-p cl--set-frame-visible-p) +(make-obsolete-generalized-variable 'frame-visible-p nil "29.1") + (gv-define-setter frame-width (x &optional frame) `(set-frame-width (or ,frame (selected-frame)) ,x)) +(make-obsolete-generalized-variable 'frame-width 'set-frame-width "29.1") + (gv-define-simple-setter getenv setenv t) (gv-define-simple-setter get-register set-register) + (gv-define-simple-setter global-key-binding global-set-key) +(make-obsolete-generalized-variable 'global-key-binding 'global-set-key "29.1") + (gv-define-simple-setter local-key-binding local-set-key) +(make-obsolete-generalized-variable 'local-key-binding 'local-set-key "29.1") + (gv-define-simple-setter mark set-mark t) +(make-obsolete-generalized-variable 'mark 'set-mark "29.1") + (gv-define-simple-setter mark-marker set-mark t) +(make-obsolete-generalized-variable 'mark-marker 'set-mark "29.1") + (gv-define-simple-setter marker-position set-marker t) +(make-obsolete-generalized-variable 'marker-position 'set-marker "29.1") + (gv-define-setter mouse-position (store scr) `(set-mouse-position ,scr (car ,store) (cadr ,store) (cddr ,store))) +(make-obsolete-generalized-variable 'mouse-position 'set-mouse-position "29.1") + (gv-define-simple-setter point goto-char) +(make-obsolete-generalized-variable 'point 'goto-char "29.1") + (gv-define-simple-setter point-marker goto-char t) +(make-obsolete-generalized-variable 'point-marker 'goto-char "29.1") + (gv-define-setter point-max (store) `(progn (narrow-to-region (point-min) ,store) ,store)) +(make-obsolete-generalized-variable 'point-max 'narrow-to-region "29.1") + (gv-define-setter point-min (store) `(progn (narrow-to-region ,store (point-max)) ,store)) +(make-obsolete-generalized-variable 'point-min 'narrow-to-region "29.1") + (gv-define-setter read-mouse-position (store scr) `(set-mouse-position ,scr (car ,store) (cdr ,store))) +(make-obsolete-generalized-variable + 'read-mouse-position 'set-mouse-position "29.1") + (gv-define-simple-setter screen-height set-screen-height t) +(make-obsolete-generalized-variable 'screen-height 'set-screen-height "29.1") + (gv-define-simple-setter screen-width set-screen-width t) +(make-obsolete-generalized-variable 'screen-width 'set-screen-width "29.1") + (gv-define-simple-setter selected-window select-window) +(make-obsolete-generalized-variable 'selected-window 'select-window "29.1") + (gv-define-simple-setter selected-screen select-screen) +(make-obsolete-generalized-variable 'selected-screen 'select-screen "29.1") + (gv-define-simple-setter selected-frame select-frame) +(make-obsolete-generalized-variable 'selected-frame 'select-frame "29.1") + (gv-define-simple-setter standard-case-table set-standard-case-table) +(make-obsolete-generalized-variable + 'standard-case-table 'set-standard-case-table "29.1") + (gv-define-simple-setter syntax-table set-syntax-table) +(make-obsolete-generalized-variable 'syntax-table 'set-syntax-table "29.1") + (gv-define-simple-setter visited-file-modtime set-visited-file-modtime t) +(make-obsolete-generalized-variable + 'visited-file-modtime 'set-visited-file-modtime "29.1") + (gv-define-setter window-height (store) `(progn (enlarge-window (- ,store (window-height))) ,store)) +(make-obsolete-generalized-variable 'window-height 'enlarge-window "29.1") + (gv-define-setter window-width (store) `(progn (enlarge-window (- ,store (window-width)) t) ,store)) +(make-obsolete-generalized-variable 'window-width 'enlarge-window "29.1") + (gv-define-simple-setter x-get-secondary-selection x-own-secondary-selection t) +(make-obsolete-generalized-variable + 'x-get-secondary-selection 'x-own-secondary-selection "29.1") + ;; More complex setf-methods. diff --git a/lisp/emacs-lisp/helper.el b/lisp/emacs-lisp/helper.el index 930dbfe6c49..10bb2973253 100644 --- a/lisp/emacs-lisp/helper.el +++ b/lisp/emacs-lisp/helper.el @@ -1,6 +1,6 @@ ;;; helper.el --- utility help package supporting help in electric modes -*- lexical-binding: t; -*- -;; Copyright (C) 1985, 2001-2022 Free Software Foundation, Inc. +;; Copyright (C) 1985-2022 Free Software Foundation, Inc. ;; Author: K. Shane Hartman ;; Maintainer: emacs-devel@gnu.org @@ -39,19 +39,16 @@ ;; keymap either. -(defvar Helper-help-map - (let ((map (make-sparse-keymap))) - ;(fillarray map 'undefined) - (define-key map "m" 'Helper-describe-mode) - (define-key map "b" 'Helper-describe-bindings) - (define-key map "c" 'Helper-describe-key-briefly) - (define-key map "k" 'Helper-describe-key) - ;(define-key map "f" 'Helper-describe-function) - ;(define-key map "v" 'Helper-describe-variable) - (define-key map "?" 'Helper-help-options) - (define-key map (char-to-string help-char) 'Helper-help-options) - (fset 'Helper-help-map map) - map)) +(defvar-keymap Helper-help-map + "m" #'Helper-describe-mode + "b" #'Helper-describe-bindings + "c" #'Helper-describe-key-briefly + "k" #'Helper-describe-key + ;;"f" #'Helper-describe-function + ;;"v" #'Helper-describe-variable + "?" #'Helper-help-options + (key-description (char-to-string help-char)) #'Helper-help-options) +(fset 'Helper-help-map Helper-help-map) (defun Helper-help-scroller () (let ((blurb (or (and (boundp 'Helper-return-blurb) @@ -68,26 +65,30 @@ (setq state (+ (* 2 (if (pos-visible-in-window-p (point-max)) 1 0)) (if (pos-visible-in-window-p (point-min)) 1 0))) (message - (nth state - '("Space forward, Delete back. Other keys %s" - "Space scrolls forward. Other keys %s" - "Delete scrolls back. Other keys %s" - "Type anything to %s")) + (nth state + (mapcar + #'substitute-command-keys + '("\\`SPC' forward, \\`DEL' back. Other keys %s" + "\\`SPC' scrolls forward. Other keys %s" + "\\`DEL' scrolls back. Other keys %s" + "Type anything to %s"))) blurb) (setq continue (read-event)) (cond ((and (memq continue '(?\s ?\C-v)) (< state 2)) (scroll-up)) - ((= continue ?\C-l) + ((eq continue ?\C-l) (recenter)) - ((and (= continue ?\177) (zerop (% state 2))) + ((and (or (eq continue 'backspace) + (eq continue ?\177)) + (zerop (% state 2))) (scroll-down)) (t (setq continue nil)))))))) (defun Helper-help-options () "Describe help options." (interactive) - (message "c (key briefly), m (mode), k (key), b (bindings)") - ;(message "c (key briefly), m (mode), k (key), v (variable), f (function)") + (message (substitute-command-keys + "\\`c' (key briefly), \\`m' (mode), \\`k' (key), \\`b' (bindings)")) (sit-for 4)) (defun Helper-describe-key-briefly (key) @@ -130,7 +131,6 @@ (defun Helper-describe-bindings () "Describe local key bindings of current mode." (interactive) - (message "Making binding list...") (save-window-excursion (describe-bindings)) (Helper-help-scroller)) @@ -140,7 +140,8 @@ (interactive) (let ((continue t) c) (while continue - (message "Help (Type ? for further options)") + (message (substitute-command-keys + "Help (Type \\`?' for further options)")) (setq c (read-key-sequence nil)) (setq c (lookup-key Helper-help-map c)) (cond ((eq c 'Helper-help-options) diff --git a/lisp/emacs-lisp/icons.el b/lisp/emacs-lisp/icons.el new file mode 100644 index 00000000000..93749a3451e --- /dev/null +++ b/lisp/emacs-lisp/icons.el @@ -0,0 +1,267 @@ +;;; icons.el --- Handling icons -*- lexical-binding:t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Author: Lars Ingebrigtsen <larsi@gnus.org> +;; Keywords: icons buttons + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'cl-lib) + +(defface icon + '((t :underline nil)) + "Face for buttons." + :version "29.1" + :group 'customize) + +(defface icon-button + '((((type x w32 ns haiku pgtk) (class color)) + :inherit icon + :box (:line-width (3 . -1) :color "#404040" :style flat-button) + :background "#808080" + :foreground "black")) + "Face for buttons." + :version "29.1" + :group 'customize) + +(defcustom icon-preference '(image emoji symbol text) + "List of icon types to use, in order of preference. +Emacs will choose the icon of the highest preference possible +on the current display, and \"degrade\" gracefully to an icon +type that's available." + :version "29.1" + :group 'customize + :type '(repeat (choice (const :tag "Images" image) + (const :tag "Colorful Emojis" emoji) + (const :tag "Monochrome Symbols" symbol) + (const :tag "Text Only" text)))) + +(defmacro define-icon (name parent specification documentation &rest keywords) + "Define an icon identified by NAME. +If non-nil, inherit the specification from PARENT. Entries from +SPECIFICATION will override inherited specifications. + +SPECIFICATION is an alist of entries where the first element is +the type, and the rest are icons of that type. Valid types are +`image', `emoji', `symbol' and `text'. + +KEYWORDS specify additional information. Valid keywords are: + +`:version': The first Emacs version to include this icon; this is +mandatory. + +`:group': The customization group the icon belongs in; this is +inferred if not present. + +`:help-echo': Informational text that explains what happens if +the icon is used as a button and you click it." + (declare (indent 2)) + (unless (symbolp name) + (error "NAME must be a symbol: %S" name)) + (unless (plist-get keywords :version) + (error "There must be a :version keyword in `define-icon'")) + `(icons--register ',name ',parent ,specification ,documentation + ',keywords)) + +(defun icons--register (name parent spec doc keywords) + (put name 'icon--properties (list parent spec doc keywords)) + (custom-add-to-group + (or (plist-get keywords :group) + (custom-current-group)) + name 'custom-icon)) + +(defun icon-spec-keywords (spec) + (seq-drop-while (lambda (e) (not (keywordp e))) (cdr spec))) + +(defun icon-spec-values (spec) + (seq-take-while (lambda (e) (not (keywordp e))) (cdr spec))) + +(defun iconp (object) + "Return nil if OBJECT is not an icon. +If OBJECT is an icon, return the icon properties." + (get object 'icon--properties)) + +(defun icon-documentation (icon) + "Return the documentation for ICON." + (let ((props (iconp icon))) + (unless props + (user-error "%s is not a valid icon" icon)) + (nth 2 props))) + +(defun icons--spec (icon) + (nth 1 (iconp icon))) + +(defun icons--copy-spec (spec) + (mapcar #'copy-sequence spec)) + +(defun icon-complete-spec (icon &optional inhibit-theme inhibit-inheritance) + "Return the merged spec for ICON." + (pcase-let ((`(,parent ,spec _ _) (iconp icon))) + ;; We destructively modify `spec' when merging, so copy it. + (setq spec (icons--copy-spec spec)) + ;; Let the Customize theme override. + (unless inhibit-theme + (when-let ((theme-spec (cadr (car (get icon 'theme-icon))))) + (setq spec (icons--merge-spec (icons--copy-spec theme-spec) spec)))) + ;; Inherit from the parent spec (recursively). + (unless inhibit-inheritance + (while parent + (let ((parent-props (get parent 'icon--properties))) + (when parent-props + (setq spec (icons--merge-spec spec (cadr parent-props)))) + (setq parent (car parent-props))))) + spec)) + +(defun icon-string (name) + "Return a string suitable for display in the current buffer for icon NAME." + (let ((props (iconp name))) + (unless props + (user-error "%s is not a valid icon" name)) + (pcase-let ((`(_ ,spec _ ,keywords) props)) + (setq spec (icon-complete-spec name)) + ;; We now have a full spec, so check the intersection of what + ;; the user wants and what this Emacs is capable of showing. + (let ((icon-string + (catch 'found + (dolist (type icon-preference) + (let* ((type-spec (assq type spec)) + ;; Find the keywords at the end of the section + ;; (if any). + (type-keywords (icon-spec-keywords type-spec))) + ;; Go through all the variations in this section + ;; and return the first one we can display. + (dolist (icon (icon-spec-values type-spec)) + (when-let ((result + (icons--create type icon type-keywords))) + (throw 'found + (if-let ((face (plist-get type-keywords :face))) + (propertize result 'face face) + result))))))))) + (unless icon-string + (error "Couldn't find any way to display the %s icon" name)) + (when-let ((help (plist-get keywords :help-echo))) + (setq icon-string (propertize icon-string 'help-echo help))) + (propertize icon-string 'rear-nonsticky t))))) + +(defun icon-elements (name) + "Return the elements of icon NAME. +The elements are represented as a plist where the keys are +`string', `face' and `display'. The `image' element is only +present if the icon is represented by an image." + (let ((string (icon-string name))) + (list 'face (get-text-property 0 'face string) + 'image (get-text-property 0 'display string) + 'string (substring-no-properties string)))) + +(defun icons--merge-spec (merged parent-spec) + (dolist (elem parent-spec) + (let ((current (assq (car elem) merged))) + (if (not current) + ;; Just add the entry. + (push elem merged) + ;; See if there are any keywords to inherit. + (let ((parent-keywords (icon-spec-keywords elem)) + (current-keywords (icon-spec-keywords current))) + (while parent-keywords + (unless (plist-get (car parent-keywords) current-keywords) + (nconc current (take 2 parent-keywords)) + (setq parent-keywords (cddr parent-keywords)))))))) + merged) + +(cl-defmethod icons--create ((_type (eql 'image)) icon keywords) + (let ((file (if (file-name-absolute-p icon) + icon + (and (fboundp 'image-search-load-path) + (image-search-load-path icon))))) + (and (display-images-p) + (fboundp 'image-supported-file-p) + (image-supported-file-p file) + (propertize + " " 'display + (if-let ((height (plist-get keywords :height))) + (create-image file + nil nil + :height (if (eq height 'line) + (window-default-line-height) + height) + :scale 1) + (create-image file)))))) + +(cl-defmethod icons--create ((_type (eql 'emoji)) icon _keywords) + (when-let ((font (and (display-multi-font-p) + ;; FIXME: This is not enough for ensuring + ;; display of color Emoji. + (car (internal-char-font nil ?🟠))))) + (and (font-has-char-p font (aref icon 0)) + icon))) + +(cl-defmethod icons--create ((_type (eql 'symbol)) icon _keywords) + (and (cl-every #'char-displayable-p icon) + icon)) + +(cl-defmethod icons--create ((_type (eql 'text)) icon _keywords) + icon) + +(define-icon button nil + '((image :face icon-button) + (emoji "🔵" :face icon) + (symbol "●" :face icon-button) + (text "button" :face icon-button)) + "Base icon for buttons." + :version "29.1") + +;;;###autoload +(defun describe-icon (icon) + "Pop to a buffer to describe ICON." + (interactive + (list (intern (completing-read "Describe icon: " obarray 'iconp t)))) + (let ((help-buffer-under-preparation t)) + (help-setup-xref (list #'describe-icon icon) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (with-current-buffer standard-output + (insert "Icon: " (symbol-name icon) "\n\n") + (insert "Documentation:\n" + (substitute-command-keys (icon-documentation icon))) + (ensure-empty-lines) + (let ((spec (icon-complete-spec icon)) + (plain (icon-complete-spec icon t t))) + (insert "Specification including inheritance and theming:\n") + (icons--describe-spec spec) + (unless (equal spec plain) + (insert "\nSpecification not including inheritance and theming:\n") + (icons--describe-spec plain))))))) + +(defun icons--describe-spec (spec) + (dolist (elem spec) + (let ((type (car elem)) + (values (icon-spec-values elem)) + (keywords (icon-spec-keywords elem))) + (when (or values keywords) + (insert (format "\nType: %s\n" type)) + (dolist (value values) + (insert (format " %s\n" value))) + (while keywords + (insert (format " %s: %s\n" (pop keywords) (pop keywords)))))))) + +(provide 'icons) + +;;; icons.el ends here diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index aaec13d1afc..c906ee6e31d 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -89,78 +89,78 @@ table) "Syntax table used in `lisp-mode'.") +(rx-define lisp-mode-symbol (+ (| (syntax word) + (syntax symbol) + (: "\\" nonl)))) + (eval-and-compile - (defconst lisp-mode-symbol-regexp "\\(?:\\sw\\|\\s_\\|\\\\.\\)+")) + (defconst lisp-mode-symbol-regexp (rx lisp-mode-symbol))) (defvar lisp-imenu-generic-expression (list (list nil (purecopy (concat "^\\s-*(" - (eval-when-compile - (regexp-opt - '("defun" "defmacro" - ;; Elisp. - "defun*" "defsubst" "define-inline" - "define-advice" "defadvice" "define-skeleton" - "define-compilation-mode" "define-minor-mode" - "define-global-minor-mode" - "define-globalized-minor-mode" - "define-derived-mode" "define-generic-mode" - "ert-deftest" - "cl-defun" "cl-defsubst" "cl-defmacro" - "cl-define-compiler-macro" "cl-defgeneric" - "cl-defmethod" - ;; CL. - "define-compiler-macro" "define-modify-macro" - "defsetf" "define-setf-expander" - "define-method-combination" - ;; CLOS and EIEIO - "defgeneric" "defmethod") - t)) - "\\s-+\\(" lisp-mode-symbol-regexp "\\)")) + (regexp-opt + '("defun" "defmacro" + ;; Elisp. + "defun*" "defsubst" "define-inline" + "define-advice" "defadvice" "define-skeleton" + "define-compilation-mode" "define-minor-mode" + "define-global-minor-mode" + "define-globalized-minor-mode" + "define-derived-mode" "define-generic-mode" + "ert-deftest" + "cl-defun" "cl-defsubst" "cl-defmacro" + "cl-define-compiler-macro" "cl-defgeneric" + "cl-defmethod" + ;; CL. + "define-compiler-macro" "define-modify-macro" + "defsetf" "define-setf-expander" + "define-method-combination" + ;; CLOS and EIEIO + "defgeneric" "defmethod") + t) + "\\s-+\\(" (rx lisp-mode-symbol) "\\)")) 2) ;; Like the previous, but uses a quoted symbol as the name. (list nil (purecopy (concat "^\\s-*(" - (eval-when-compile - (regexp-opt - '("defalias" "define-obsolete-function-alias") - t)) - "\\s-+'\\(" lisp-mode-symbol-regexp "\\)")) + (regexp-opt + '("defalias" "define-obsolete-function-alias") + t) + "\\s-+'\\(" (rx lisp-mode-symbol) "\\)")) 2) (list (purecopy "Variables") (purecopy (concat "^\\s-*(" - (eval-when-compile - (regexp-opt - '(;; Elisp - "defconst" "defcustom" - ;; CL - "defconstant" - "defparameter" "define-symbol-macro") - t)) - "\\s-+\\(" lisp-mode-symbol-regexp "\\)")) + (regexp-opt + '(;; Elisp + "defconst" "defcustom" + ;; CL + "defconstant" + "defparameter" "define-symbol-macro") + t) + "\\s-+\\(" (rx lisp-mode-symbol) "\\)")) 2) ;; For `defvar'/`defvar-local', we ignore (defvar FOO) constructs. (list (purecopy "Variables") (purecopy (concat "^\\s-*(defvar\\(?:-local\\)?\\s-+\\(" - lisp-mode-symbol-regexp "\\)" + (rx lisp-mode-symbol) "\\)" "[[:space:]\n]+[^)]")) 1) (list (purecopy "Types") (purecopy (concat "^\\s-*(" - (eval-when-compile - (regexp-opt - '(;; Elisp - "defgroup" "deftheme" - "define-widget" "define-error" - "defface" "cl-deftype" "cl-defstruct" - ;; CL - "deftype" "defstruct" - "define-condition" "defpackage" - ;; CLOS and EIEIO - "defclass") - t)) - "\\s-+'?\\(" lisp-mode-symbol-regexp "\\)")) + (regexp-opt + '(;; Elisp + "defgroup" "deftheme" + "define-widget" "define-error" + "defface" "cl-deftype" "cl-defstruct" + ;; CL + "deftype" "defstruct" + "define-condition" "defpackage" + ;; CLOS and EIEIO + "defclass") + t) + "\\s-+'?\\(" (rx lisp-mode-symbol) "\\)")) 2)) "Imenu generic expression for Lisp mode. See `imenu-generic-expression'.") @@ -269,8 +269,7 @@ to a package-local <package>-loaddefs.el file.") ;; FIXME: Move to elisp-mode.el. (catch 'found (while (re-search-forward - (eval-when-compile - (concat "(\\(" lisp-mode-symbol-regexp "\\)\\_>")) + (concat "(\\(" (rx lisp-mode-symbol) "\\)\\_>") limit t) (let ((sym (intern-soft (match-string 1)))) (when (and (or (special-form-p sym) (macrop sym)) @@ -419,8 +418,8 @@ This will generate compile-time constants from BINDINGS." ;; Any whitespace and defined object. "[ \t']*" "\\(([ \t']*\\)?" ;; An opening paren. - "\\(\\(setf\\)[ \t]+" lisp-mode-symbol-regexp - "\\|" lisp-mode-symbol-regexp "\\)?") + "\\(\\(setf\\)[ \t]+" (rx lisp-mode-symbol) + "\\|" (rx lisp-mode-symbol) "\\)?") (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) @@ -446,8 +445,8 @@ This will generate compile-time constants from BINDINGS." ;; Any whitespace and defined object. "[ \t']*" "\\(([ \t']*\\)?" ;; An opening paren. - "\\(\\(setf\\)[ \t]+" lisp-mode-symbol-regexp - "\\|" lisp-mode-symbol-regexp "\\)?") + "\\(\\(setf\\)[ \t]+" (rx lisp-mode-symbol) + "\\|" (rx lisp-mode-symbol) "\\)?") (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) @@ -473,26 +472,34 @@ This will generate compile-time constants from BINDINGS." (lisp--el-match-keyword . 1) ;; Exit/Feature symbols as constants. (,(concat "(\\(catch\\|throw\\|featurep\\|provide\\|require\\)\\_>" - "[ \t']*\\(" lisp-mode-symbol-regexp "\\)?") + "[ \t']*\\(" (rx lisp-mode-symbol) "\\)?") (1 font-lock-keyword-face) (2 font-lock-constant-face nil t)) - ;; Words inside \\[] tend to be for `substitute-command-keys'. - (,(concat "\\\\\\\\\\[\\(" lisp-mode-symbol-regexp "\\)\\]") + ;; Words inside \\[], \\<>, \\{} or \\`' tend to be for + ;; `substitute-command-keys'. + (,(rx "\\\\" (or (seq "[" (group-n 1 lisp-mode-symbol) "]") + (seq "`" (group-n 1 + ;; allow multiple words, e.g. "C-x a" + lisp-mode-symbol (* " " lisp-mode-symbol)) + "'"))) (1 font-lock-constant-face prepend)) + (,(rx "\\\\" (or (seq "<" (group-n 1 lisp-mode-symbol) ">") + (seq "{" (group-n 1 lisp-mode-symbol) "}"))) + (1 font-lock-variable-name-face prepend)) ;; Ineffective backslashes (typically in need of doubling). ("\\(\\\\\\)\\([^\"\\]\\)" (1 (elisp--font-lock-backslash) prepend)) ;; Words inside ‘’, '' and `' tend to be symbol names. - (,(concat "[`‘']\\(" lisp-mode-symbol-regexp "\\)['’]") + (,(concat "[`‘']\\(" (rx lisp-mode-symbol) "\\)['’]") (1 font-lock-constant-face prepend)) ;; \\= tends to be an escape in doc strings. - ("\\\\\\\\=" + (,(rx "\\\\=") (0 font-lock-builtin-face prepend)) ;; Constant values. - (,(concat "\\_<:" lisp-mode-symbol-regexp "\\_>") + (,(concat "\\_<:" (rx lisp-mode-symbol) "\\_>") (0 font-lock-builtin-face)) ;; ELisp and CLisp `&' keywords as types. - (,(concat "\\_<&" lisp-mode-symbol-regexp "\\_>") + (,(concat "\\_<&" (rx lisp-mode-symbol) "\\_>") . font-lock-type-face) ;; ELisp regexp grouping constructs (,(lambda (bound) @@ -529,30 +536,30 @@ This will generate compile-time constants from BINDINGS." (,(concat "(" cl-kws-re "\\_>") . 1) ;; Exit/Feature symbols as constants. (,(concat "(\\(catch\\|throw\\|provide\\|require\\)\\_>" - "[ \t']*\\(" lisp-mode-symbol-regexp "\\)?") + "[ \t']*\\(" (rx lisp-mode-symbol) "\\)?") (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. - (,(concat "[`‘]\\(" lisp-mode-symbol-regexp "\\)['’]") + (,(concat "[`‘]\\(" (rx lisp-mode-symbol) "\\)['’]") (1 font-lock-constant-face prepend)) ;; Uninterned symbols, e.g., (defpackage #:my-package ...) ;; must come before keywords below to have effect - (,(concat "#:" lisp-mode-symbol-regexp "") 0 font-lock-builtin-face) + (,(concat "#:" (rx lisp-mode-symbol) "") 0 font-lock-builtin-face) ;; Constant values. - (,(concat "\\_<:" lisp-mode-symbol-regexp "\\_>") + (,(concat "\\_<:" (rx lisp-mode-symbol) "\\_>") (0 font-lock-builtin-face)) ;; ELisp and CLisp `&' keywords as types. - (,(concat "\\_<&" lisp-mode-symbol-regexp "\\_>") + (,(concat "\\_<&" (rx lisp-mode-symbol) "\\_>") . 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. ;; That user has violated the https://www.cliki.net/Naming+conventions: ;; CL (but not EL!) `with-' (context) and `do-' (iteration) - (,(concat "(\\(\\(do-\\|with-\\)" lisp-mode-symbol-regexp "\\)") + (,(concat "(\\(\\(do-\\|with-\\)" (rx lisp-mode-symbol) "\\)") (1 font-lock-keyword-face)) (lisp--match-hidden-arg (0 '(face font-lock-warning-face @@ -579,16 +586,15 @@ This will generate compile-time constants from BINDINGS." "Gaudy highlighting from Emacs Lisp mode used in Backtrace mode.") (defun lisp-string-in-doc-position-p (listbeg startpos) - "Return non-nil if a doc string may occur at STARTPOS inside a list. + "Return non-nil if a doc string may occur at STARTPOS inside a list. LISTBEG is the position of the start of the innermost list containing STARTPOS." (let* ((firstsym (and listbeg (save-excursion (goto-char listbeg) (and (looking-at - (eval-when-compile - (concat "([ \t\n]*\\(" - lisp-mode-symbol-regexp "\\)"))) + (concat "([ \t\n]*\\(" + (rx lisp-mode-symbol) "\\)")) (match-string 1))))) (docelt (and firstsym (function-get (intern-soft firstsym) @@ -747,17 +753,16 @@ font-lock keywords will not be case sensitive." (progn (forward-sexp 1) (point))))))) -(defvar lisp-mode-shared-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map prog-mode-map) - (define-key map "\e\C-q" 'indent-sexp) - (define-key map "\177" 'backward-delete-char-untabify) - ;; This gets in the way when viewing a Lisp file in view-mode. As - ;; long as [backspace] is mapped into DEL via the - ;; function-key-map, this should remain disabled!! - ;;;(define-key map [backspace] 'backward-delete-char-untabify) - map) - "Keymap for commands shared by all sorts of Lisp modes.") +(defvar-keymap lisp-mode-shared-map + :doc "Keymap for commands shared by all sorts of Lisp modes." + :parent prog-mode-map + "C-M-q" #'indent-sexp + "DEL" #'backward-delete-char-untabify + ;; This gets in the way when viewing a Lisp file in view-mode. As + ;; long as [backspace] is mapped into DEL via the + ;; function-key-map, this should remain disabled!! + ;;;"<backspace>" #'backward-delete-char-untabify + ) (defcustom lisp-mode-hook nil "Hook run when entering Lisp mode." @@ -773,14 +778,12 @@ font-lock keywords will not be case sensitive." ;;; Generic Lisp mode. -(defvar lisp-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map lisp-mode-shared-map) - (define-key map "\e\C-x" 'lisp-eval-defun) - (define-key map "\C-c\C-z" 'run-lisp) - map) - "Keymap for ordinary Lisp mode. -All commands in `lisp-mode-shared-map' are inherited by this map.") +(defvar-keymap lisp-mode-map + :doc "Keymap for ordinary Lisp mode. +All commands in `lisp-mode-shared-map' are inherited by this map." + :parent lisp-mode-shared-map + "C-M-x" #'lisp-eval-defun + "C-c C-z" #'run-lisp) (easy-menu-define lisp-mode-menu lisp-mode-map "Menu for ordinary Lisp mode." @@ -835,9 +838,8 @@ or to switch back to an existing one." (defcustom lisp-indent-offset nil "If non-nil, indent second line of expressions that many more columns." :group 'lisp - :type '(choice (const nil) integer)) -(put 'lisp-indent-offset 'safe-local-variable - (lambda (x) (or (null x) (integerp x)))) + :type '(choice (const nil) integer) + :safe (lambda (x) (or (null x) (integerp x)))) (defcustom lisp-indent-function 'lisp-indent-function "A function to be called by `calculate-lisp-indent'. @@ -1249,8 +1251,8 @@ Lisp function does not specify a special indentation." (defcustom lisp-body-indent 2 "Number of columns to indent the second line of a `(def...)' form." :group 'lisp - :type 'integer) -(put 'lisp-body-indent 'safe-local-variable 'integerp) + :type 'integer + :safe #'integerp) (defun lisp-indent-specform (count state indent-point normal-indent) (let ((containing-form-start (elt state 1)) @@ -1411,9 +1413,8 @@ Any non-integer value means do not use a different value of `fill-column' when filling docstrings." :type '(choice (integer) (const :tag "Use the current `fill-column'" t)) + :safe (lambda (x) (or (eq x t) (integerp x))) :group 'lisp) -(put 'emacs-lisp-docstring-fill-column 'safe-local-variable - (lambda (x) (or (eq x t) (integerp x)))) (defun lisp-fill-paragraph (&optional justify) "Like \\[fill-paragraph], but handle Emacs Lisp comments and docstrings. @@ -1426,6 +1427,9 @@ and initial semicolons." ;; a comment: Point is on a program line; we are interested ;; particularly in docstring lines. ;; + ;; FIXME: The below bindings are probably mostly irrelevant + ;; since we're now narrowing to a region before filling. + ;; ;; We bind `paragraph-start' and `paragraph-separate' temporarily. They ;; are buffer-local, but we avoid changing them so that they can be set ;; to make `forward-paragraph' and friends do something the user wants. @@ -1462,7 +1466,10 @@ and initial semicolons." emacs-lisp-docstring-fill-column fill-column))) (let ((ppss (syntax-ppss)) - (start (point))) + (start (point)) + ;; Avoid recursion if we're being called directly with + ;; `M-x lisp-fill-paragraph' in an `emacs-lisp-mode' buffer. + (fill-paragraph-function t)) (save-excursion (save-restriction ;; If we're not inside a string, then do very basic @@ -1481,10 +1488,19 @@ and initial semicolons." (progn (forward-sexp 1) t)) - (narrow-to-region (ppss-comment-or-string-start ppss) - (point)))) + (narrow-to-region (1+ (ppss-comment-or-string-start ppss)) + (1- (point))))) ;; Move back to where we were. (goto-char start) + ;; We should fill the first line of a string + ;; separately (since it's usually a doc string). + (if (= (line-number-at-pos) 1) + (narrow-to-region (line-beginning-position) + (line-beginning-position 2)) + (save-excursion + (goto-char (point-min)) + (forward-line 1) + (narrow-to-region (point) (point-max)))) (fill-paragraph justify))))))) ;; Never return nil. t) diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index 641ce0d5c02..acae1a0b0a9 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -507,6 +507,11 @@ It is called with no argument, right after calling `beginning-of-defun-raw'. So the function can assume that point is at the beginning of the defun body. It should move point to the first position after the defun.") +(defvar end-of-defun-moves-to-eol t + "Whether `end-of-defun' moves to eol before doing anything else. +Set this to nil if this movement adversely affects the buffer's +major mode's decisions about context.") + (defun buffer-end (arg) "Return the \"far end\" position of the buffer, in direction ARG. If ARG is positive, that's the end of the buffer. @@ -538,7 +543,9 @@ report errors as appropriate for this kind of usage." (push-mark)) (if (or (null arg) (= arg 0)) (setq arg 1)) (let ((pos (point)) - (beg (progn (end-of-line 1) (beginning-of-defun-raw 1) (point))) + (beg (progn (when end-of-defun-moves-to-eol + (end-of-line 1)) + (beginning-of-defun-raw 1) (point))) (skip (lambda () ;; When comparing point against pos, we want to consider that ;; if point was right after the end of the function, it's @@ -943,14 +950,7 @@ character." (defun field-complete (table &optional predicate) (declare (obsolete completion-in-region "24.4")) (let ((minibuffer-completion-table table) - (minibuffer-completion-predicate predicate) - ;; This made sense for lisp-complete-symbol, but for - ;; field-complete, this is out of place. --Stef - ;; (completion-annotate-function - ;; (unless (eq predicate 'fboundp) - ;; (lambda (str) - ;; (if (fboundp (intern-soft str)) " <f>")))) - ) + (minibuffer-completion-predicate predicate)) (call-interactively 'minibuffer-complete))) (defun lisp-complete-symbol (&optional _predicate) diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el index 95666ddb2a0..e13b92bab8c 100644 --- a/lisp/emacs-lisp/loaddefs-gen.el +++ b/lisp/emacs-lisp/loaddefs-gen.el @@ -50,17 +50,27 @@ prefix, that will not be registered. But all other prefixes will be included.") (put 'autoload-compute-prefixes 'safe-local-variable #'booleanp) +(defvar no-update-autoloads nil + "File local variable to prevent scanning this file for autoload cookies.") + (defvar autoload-ignored-definitions '("define-obsolete-function-alias" "define-obsolete-variable-alias" - "define-category" "define-key" + "define-category" + "define-key" "define-key-after" "define-keymap" "defgroup" "defface" "defadvice" "def-edebug-spec" ;; Hmm... this is getting ugly: "define-widget" "define-erc-module" "define-erc-response-handler" - "defun-rcirc-command") + "defun-rcirc-command" + "define-short-documentation-group" + "def-edebug-elem-spec" + "defvar-mode-local" + "defcustom-mode-local-semantic-dependency-system-include-path" + "define-ibuffer-column" + "define-ibuffer-sorter") "List of strings naming definitions to ignore for prefixes. More specifically those definitions will not be considered for the `register-definition-prefixes' call.") @@ -117,6 +127,15 @@ scanning for autoloads and will be in the `load-path'." (substring name 0 (match-beginning 0)) name))) +(defun loaddefs-generate--shorten-autoload (form) + "Remove optional nil elements from an `autoload' form." + (take (max (- (length form) + (seq-position (reverse form) nil + (lambda (e1 e2) + (not (eq e1 e2))))) + 3) + form)) + (defun loaddefs-generate--make-autoload (form file &optional expansion) "Turn FORM into an autoload or defvar for source file FILE. Returns nil if FORM is not a special autoload form (i.e. a function definition @@ -155,8 +174,8 @@ expression, in which case we want to handle forms differently." ;; Add the usage form at the end where describe-function-1 ;; can recover it. (when (consp args) (setq doc (help-add-fundoc-usage doc args))) - ;; (message "autoload of %S" (nth 1 form)) - `(autoload ,(nth 1 form) ,file ,doc ,interactive ,type))) + (loaddefs-generate--shorten-autoload + `(autoload ,(nth 1 form) ,file ,doc ,interactive ,type)))) ((and expansion (memq car '(progn prog1))) (let ((end (memq :autoload-end form))) @@ -174,7 +193,8 @@ expression, in which case we want to handle forms differently." define-globalized-minor-mode defun defmacro easy-mmode-define-minor-mode define-minor-mode define-inline cl-defun cl-defmacro cl-defgeneric - cl-defstruct pcase-defmacro)) + cl-defstruct pcase-defmacro iter-defun cl-iter-defun + transient-define-prefix)) (macrop car) (setq expand (let ((load-true-file-name file) (load-file-name file)) @@ -209,22 +229,23 @@ expression, in which case we want to handle forms differently." ;; can recover it. (when (listp args) (setq doc (help-add-fundoc-usage doc args))) ;; `define-generic-mode' quotes the name, so take care of that - `(autoload ,(if (listp name) name (list 'quote name)) - ,file ,doc - ,(or (and (memq car '(define-skeleton define-derived-mode - define-generic-mode - easy-mmode-define-global-mode - define-global-minor-mode - define-globalized-minor-mode - easy-mmode-define-minor-mode - define-minor-mode)) - t) - (and (eq (car-safe (car body)) 'interactive) - ;; List of modes or just t. - (or (if (nthcdr 1 (car body)) - (list 'quote (nthcdr 1 (car body))) - t)))) - ,(if macrop ''macro nil)))) + (loaddefs-generate--shorten-autoload + `(autoload ,(if (listp name) name (list 'quote name)) + ,file ,doc + ,(or (and (memq car '(define-skeleton define-derived-mode + define-generic-mode + easy-mmode-define-global-mode + define-global-minor-mode + define-globalized-minor-mode + easy-mmode-define-minor-mode + define-minor-mode)) + t) + (and (eq (car-safe (car body)) 'interactive) + ;; List of modes or just t. + (or (if (nthcdr 1 (car body)) + (list 'quote (nthcdr 1 (car body))) + t)))) + ,(if macrop ''macro nil))))) ;; For defclass forms, use `eieio-defclass-autoload'. ((eq car 'defclass) @@ -329,9 +350,9 @@ expression, in which case we want to handle forms differently." 'string<)))))) (defun loaddefs-generate--parse-file (file main-outfile &optional package-data) - "Examing FILE for ;;;###autoload statements. + "Examining FILE for ;;;###autoload statements. MAIN-OUTFILE is the main loaddefs file these statements are -destined for, but this can be overriden by the buffer-local +destined for, but this can be overridden by the buffer-local setting of `generated-autoload-file' in FILE, and by ;;;###foo-autoload statements. @@ -366,7 +387,11 @@ don't include." ;; We always return the package version (even for pre-dumped ;; files). - (when package-data + (if (not package-data) + ;; We have to switch `emacs-lisp-mode' when scanning + ;; loaddefs for packages so that `syntax-ppss' later gives + ;; correct results. + (emacs-lisp-mode) (let ((version (lm-header "version")) package) (when (and version @@ -442,7 +467,7 @@ don't include." (let ((prefs nil)) ;; Avoid (defvar <foo>) by requiring a trailing space. (while (re-search-forward - "^(\\(def[^ ]+\\) ['(]*\\([^' ()\"\n]+\\)[\n \t]" nil t) + "^(\\(def[^ \t\n]+\\)[ \t\n]+['(]*\\([^' ()\"\n]+\\)[\n \t]" nil t) (unless (member (match-string 1) autoload-ignored-definitions) (let ((name (match-string-no-properties 2))) (when (save-excursion @@ -454,7 +479,7 @@ don't include." (push name prefs))))) (loaddefs-generate--make-prefixes prefs load-name))) -(defun loaddefs-generate--rubric (file &optional type feature) +(defun loaddefs-generate--rubric (file &optional type feature compile) "Return a string giving the appropriate autoload rubric for FILE. TYPE (default \"autoloads\") is a string stating the type of information contained in FILE. TYPE \"package\" acts like the default, @@ -462,7 +487,9 @@ but adds an extra line to the output to modify `load-path'. If FEATURE is non-nil, FILE will provide a feature. FEATURE may be a string naming the feature, otherwise it will be based on -FILE's name." +FILE's name. + +If COMPILE, don't include a \"don't compile\" cookie." (let ((lp (and (equal type "package") (setq type "autoloads")))) (with-temp-buffer (generate-lisp-file-heading @@ -476,30 +503,10 @@ FILE's name." (insert " \n;;; End of scraped data\n\n") (generate-lisp-file-trailer file :provide (and (stringp feature) feature) + :compile compile :inhibit-provide (not feature)) (buffer-string)))) -(defun loaddefs-generate--insert-section-header (outbuf autoloads - load-name file time) - "Insert into buffer OUTBUF the section-header line for FILE. -The header line lists the file name, its \"load name\", its autoloads, -and the time the FILE was last updated (the time is inserted only -if `autoload-timestamps' is non-nil, otherwise a fixed fake time is inserted)." - (insert "\f\n;;;### ") - (prin1 `(autoloads ,autoloads ,load-name ,file ,time) - outbuf) - (terpri outbuf) - ;; Break that line at spaces, to avoid very long lines. - ;; Make each sub-line into a comment. - (with-current-buffer outbuf - (save-excursion - (forward-line -1) - (while (not (eolp)) - (move-to-column 64) - (skip-chars-forward "^ \n") - (or (eolp) - (insert "\n" ";;;;;; ")))))) - ;;;###autoload (defun loaddefs-generate (dir output-file &optional excluded-files extra-data include-package-version @@ -512,15 +519,21 @@ binds `generated-autoload-file' as a file-local variable, write its autoloads into the specified file instead. The function does NOT recursively descend into subdirectories of the -directory or directories specified. +directory or directories specified by DIRS. -If EXTRA-DATA, include this string at the start of the generated -file. This will also force generation of OUTPUT-FILE even if -there are no autoloads to put into the file. +Optional argument EXCLUDED-FILES, if non-nil, should be a list of +files, such as preloaded files, whose autoloads should not be written +to OUTPUT-FILE. -If INCLUDE-PACKAGE-VERSION, include package version data. +If EXTRA-DATA is non-nil, it should be a string; include that string +at the beginning of the generated file. This will also force the +generation of OUTPUT-FILE even if there are no autoloads to put into +that file. -If GENERATE-FULL, don't update, but regenerate all the loaddefs files." +If INCLUDE-PACKAGE-VERSION is non-nil, include package version data. + +If GENERATE-FULL is non-nil, regenerate all the loaddefs files anew, +instead of just updating them with the new/changed autoloads." (let* ((files-re (let ((tmp nil)) (dolist (suf (get-load-suffixes)) ;; We don't use module-file-suffix below because @@ -538,6 +551,11 @@ If GENERATE-FULL, don't update, but regenerate all the loaddefs files." (updating (and (file-exists-p output-file) (not generate-full))) (defs nil)) + ;; Allow the excluded files to be relative. + (setq excluded-files + (mapcar (lambda (file) (expand-file-name file dir)) + excluded-files)) + ;; Collect all the autoload data. (let ((progress (make-progress-reporter (byte-compile-info @@ -552,16 +570,15 @@ If GENERATE-FULL, don't update, but regenerate all the loaddefs files." (time-less-p output-time (file-attribute-modification-time (file-attributes file)))) - (setq defs (nconc - (loaddefs-generate--parse-file - file output-file - ;; We only want the package name from the - ;; excluded files. - (and include-package-version - (if (member (expand-file-name file) excluded-files) - 'only - t))) - defs)))) + ;; If we're scanning for package versions, we want to look + ;; at the file even if it's excluded. + (let* ((excluded (member (expand-file-name file dir) excluded-files)) + (package-data + (and include-package-version (if excluded 'only t)))) + (when (or package-data (not excluded)) + (setq defs (nconc (loaddefs-generate--parse-file + file output-file package-data) + defs)))))) (progress-reporter-done progress)) ;; If we have no autoloads data, but we have EXTRA-DATA, then @@ -576,15 +593,18 @@ If GENERATE-FULL, don't update, but regenerate all the loaddefs files." ;; We have some data, so generate the loaddef files. First ;; group per output file. (dolist (fdefs (seq-group-by #'car defs)) - (let ((loaddefs-file (car fdefs))) + (let ((loaddefs-file (car fdefs)) + hash) (with-temp-buffer (if (and updating (file-exists-p loaddefs-file)) (insert-file-contents loaddefs-file) - (insert (loaddefs-generate--rubric loaddefs-file nil t)) + (insert (loaddefs-generate--rubric + loaddefs-file nil t include-package-version)) (search-backward "\f") (when extra-data (insert extra-data) (ensure-empty-lines 1))) + (setq hash (buffer-hash)) ;; Then group by source file (and sort alphabetically). (dolist (section (sort (seq-group-by #'cadr (cdr fdefs)) (lambda (e1 e2) @@ -621,21 +641,27 @@ If GENERATE-FULL, don't update, but regenerate all the loaddefs files." (loaddefs-generate--print-form def)) (unless (bolp) (insert "\n"))))) - (write-region (point-min) (point-max) loaddefs-file nil 'silent) - (byte-compile-info (file-relative-name loaddefs-file lisp-directory) - t "GEN"))))))) + ;; Only write the file if we actually made a change. + (unless (equal (buffer-hash) hash) + (write-region (point-min) (point-max) loaddefs-file nil 'silent) + (byte-compile-info + (file-relative-name loaddefs-file (car (ensure-list dir))) + t "GEN")))))))) (defun loaddefs-generate--print-form (def) - "Print DEF in the way make-docfile.c expects it." + "Print DEF in a format that makes sense for version control." (if (or (not (consp def)) (not (symbolp (car def))) + (memq (car def) '( make-obsolete + define-obsolete-function-alias)) (not (stringp (nth 3 def)))) (prin1 def (current-buffer) t) - ;; The salient point here is that we have to have the doc string - ;; that starts with a backslash and a newline, and there mustn't - ;; be any newlines before that. So -- typically - ;; (defvar foo 'value "\ - ;; Doc string" ...). + ;; We want to print, for instance, `defvar' values while escaping + ;; control characters (so that we don't end up with lines with + ;; trailing tab characters and the like), but we don't want to do + ;; this for doc strings, because then the doc strings would be on + ;; one single line, which would lead to more VC churn. So -- + ;; typically (defvar foo 'value "\ Doc string" ...). (insert "(") (dotimes (_ 3) (prin1 (pop def) (current-buffer) @@ -649,7 +675,9 @@ If GENERATE-FULL, don't update, but regenerate all the loaddefs files." (insert "\\\n"))) (while def (insert " ") - (prin1 (pop def) (current-buffer) t)) + (prin1 (pop def) (current-buffer) + '(t (escape-newlines . t) + (escape-control-characters . t)))) (insert ")"))) (defun loaddefs-generate--excluded-files () diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index bae303c213c..c3ba1b36d44 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -187,13 +187,15 @@ It should normally be a symbol with position and it defaults to FORM." msg)) form))) -(defun macroexp--obsolete-warning (fun obsolescence-data type) +(defun macroexp--obsolete-warning (fun obsolescence-data type &optional key) (let ((instead (car obsolescence-data)) (asof (nth 2 obsolescence-data))) (format-message "`%s' is an obsolete %s%s%s" fun type (if asof (concat " (as of " asof ")") "") (cond ((stringp instead) (concat "; " (substitute-command-keys instead))) + ((and instead key) + (format-message "; use `%s' (%s) instead." instead key)) (instead (format-message "; use `%s' instead." instead)) (t "."))))) @@ -369,6 +371,11 @@ Assumes the caller has bound `macroexpand-all-environment'." (macroexp--all-forms body)) (cdr form)) form))) + (`(while) + (macroexp-warn-and-return + "missing `while' condition" + `(signal 'wrong-number-of-arguments '(while 0)) + nil 'compile-only form)) (`(setq ,(and var (pred symbolp) (pred (not booleanp)) (pred (not keywordp))) ,expr) @@ -378,7 +385,7 @@ Assumes the caller has bound `macroexpand-all-environment'." form `(,fn ,var ,new-expr)))) (`(setq . ,args) - ;; Normalise to a sequence of (setq SYM EXPR). + ;; Normalize to a sequence of (setq SYM EXPR). ;; Malformed code is translated to code that signals an error ;; at run time. (let ((nargs (length args))) @@ -796,8 +803,8 @@ test of free variables in the following ways: (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt))) (if macroexp--debug-eager (debug 'eager-macroexp-cycle) - (message "Warning: Eager macro-expansion skipped due to cycle:\n %s" - (mapconcat #'prin1-to-string (nreverse bt) " => "))) + (error "Eager macro-expansion skipped due to cycle:\n %s" + (mapconcat #'prin1-to-string (nreverse bt) " => "))) (push 'skip macroexp--pending-eager-loads) form)) (t @@ -811,7 +818,7 @@ test of free variables in the following ways: ;; Hopefully this shouldn't happen thanks to the cycle detection, ;; but in case it does happen, let's catch the error and give the ;; code a chance to macro-expand later. - (message "Eager macro-expansion failure: %S" err) + (error "Eager macro-expansion failure: %S" err) form)))))) ;; ¡¡¡ Big Ugly Hack !!! @@ -823,7 +830,7 @@ test of free variables in the following ways: (eval-when-compile (add-hook 'emacs-startup-hook (lambda () - (and (not (byte-code-function-p + (and (not (compiled-function-p (symbol-function 'macroexpand-all))) (locate-library "macroexp.elc") (load "macroexp.elc"))))) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 00c9e5438b8..a9a20ab5abf 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -167,31 +167,31 @@ DOC is a string where \"FUNCTION\" and \"OLDFUN\" are expected.") (defun advice--interactive-form (function) "Like `interactive-form' but tries to avoid autoloading functions." - (when (commandp function) - (if (not (and (symbolp function) (autoloadp (indirect-function function)))) - (interactive-form function) + (if (not (and (symbolp function) (autoloadp (indirect-function function)))) + (interactive-form function) + (when (commandp function) `(interactive (advice-eval-interactive-spec (cadr (interactive-form ',function))))))) -(defun advice--make-interactive-form (function main) +(defun advice--make-interactive-form (iff ifm) ;; TODO: make it so that interactive spec can be a constant which ;; dynamically checks the advice--car/cdr to do its job. ;; For that, advice-eval-interactive-spec needs to be more faithful. - (let* ((iff (advice--interactive-form function)) - (ifm (advice--interactive-form main)) - (fspec (cadr iff))) + (let* ((fspec (cadr iff))) (when (eq 'function (car-safe fspec)) ;; Macroexpanded lambda? - (setq fspec (nth 1 fspec))) + (setq fspec (eval fspec t))) (if (functionp fspec) `(funcall ',fspec ',(cadr ifm)) (cadr (or iff ifm))))) (cl-defmethod oclosure-interactive-form ((ad advice) &optional _) - (let ((car (advice--car ad)) - (cdr (advice--cdr ad))) - (when (or (commandp car) (commandp cdr)) - `(interactive ,(advice--make-interactive-form car cdr))))) + (let* ((car (advice--car ad)) + (cdr (advice--cdr ad)) + (ifa (advice--interactive-form car)) + (ifd (advice--interactive-form cdr))) + (when (or ifa ifd) + `(interactive ,(advice--make-interactive-form ifa ifd))))) (cl-defmethod cl-print-object ((object advice) stream) (cl-assert (advice--p object)) @@ -313,7 +313,7 @@ different, but `function-equal' will hopefully ignore those differences.") (defmacro add-function (how place function &optional props) ;; TODO: ;; - maybe let `how' specify some kind of predicate and use it - ;; to implement things like mode-local or eieio-defmethod. + ;; to implement things like mode-local or cl-defmethod. ;; Of course, that only makes sense if the predicates of all advices can ;; be combined and made more efficient. ;; :before is like a normal add-hook on a normal hook. @@ -352,7 +352,7 @@ is also interactive. There are 3 cases: (declare ;;(indent 2) (debug (form [&or symbolp ("local" form) ("var" sexp) gv-place] - form &optional form))) + form &optional form))) `(advice--add-function ,how (gv-ref ,(advice--normalize-place place)) ,function ,props)) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 9aaeb052d0d..ed23ee5f221 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -301,6 +301,7 @@ packages in `package-directory-list'." :type 'directory :initialize #'custom-initialize-delay :risky t + :group 'applications :version "24.1") ;;;###autoload @@ -319,6 +320,7 @@ These directories contain packages intended for system-wide; in contrast, `package-user-dir' contains packages for personal use." :type '(repeat directory) :initialize #'custom-initialize-delay + :group 'applications :risky t :version "24.1") @@ -355,10 +357,10 @@ More specifically the value can be: This also applies to the \"archive-contents\" file that lists the contents of the archive." - :type '(choice (const nil :tag "Never") - (const allow-unsigned :tag "Allow unsigned") - (const t :tag "Check always") - (const all :tag "Check all signatures")) + :type '(choice (const :value nil :tag "Never") + (const :value allow-unsigned :tag "Allow unsigned") + (const :value t :tag "Check always") + (const :value all :tag "Check all signatures")) :risky t :version "27.1") @@ -418,22 +420,22 @@ synchronously." (defcustom package-name-column-width 30 "Column width for the Package name in the package menu." - :type 'number + :type 'natnum :version "28.1") (defcustom package-version-column-width 14 "Column width for the Package version in the package menu." - :type 'number + :type 'natnum :version "28.1") (defcustom package-status-column-width 12 "Column width for the Package status in the package menu." - :type 'number + :type 'natnum :version "28.1") (defcustom package-archive-column-width 8 "Column width for the Package archive in the package menu." - :type 'number + :type 'natnum :version "28.1") @@ -627,6 +629,7 @@ called via `package-activate-all'. To change which packages are loaded and/or activated, customize `package-load-list'.") (put 'package-alist 'risky-local-variable t) +;;;###autoload (defvar package-activated-list nil ;; FIXME: This should implicitly include all builtin packages. "List of the names of currently activated packages.") @@ -720,8 +723,7 @@ REQUIREMENTS is a list of dependencies on other packages. where OTHER-VERSION is a string. EXTRA-PROPERTIES is currently unused." - (declare (indent defun)) - ;; FIXME: Placeholder! Should we keep it? + (declare (obsolete nil "29.1") (indent defun)) (error "Don't call me!")) @@ -786,10 +788,14 @@ byte-compilation of the new package to fail." (with-demoted-errors "Error in package--load-files-for-activation: %s" (let* (result (dir (package-desc-dir pkg-desc)) - (load-path-sans-dir - (cl-remove-if (apply-partially #'string= dir) - (or (bound-and-true-p find-function-source-path) - load-path))) + ;; A previous implementation would skip `dir' itself. + ;; However, in normal use reloading from the same directory + ;; never happens anyway, while in certain cases external to + ;; Emacs a package in the same directory not necessary + ;; stays byte-identical, e.g. during development. Just + ;; don't special-case `dir'. + (effective-path (or (bound-and-true-p find-library-source-path) + load-path)) (files (directory-files-recursively dir "\\`[^\\.].*\\.el\\'")) (history (mapcar #'file-truename (cl-remove-if-not #'stringp @@ -797,8 +803,19 @@ byte-compilation of the new package to fail." (dolist (file files) (when-let ((library (package--library-stem (file-relative-name file dir))) - (canonical (locate-library library nil load-path-sans-dir)) - (found (member (file-truename canonical) history)) + (canonical (locate-library library nil effective-path)) + (truename (file-truename canonical)) + ;; Normally, all files in a package are compiled by + ;; now, but don't assume that. E.g. different + ;; versions can add or remove `no-byte-compile'. + (altname (if (string-suffix-p ".el" truename) + (replace-regexp-in-string + "\\.el\\'" ".elc" truename t) + (replace-regexp-in-string + "\\.elc\\'" ".el" truename t))) + (found (or (member truename history) + (and (not (string= altname truename)) + (member altname history)))) (recent-index (length found))) (unless (equal (file-name-base library) (format "%s-autoloads" (package-desc-name pkg-desc))) @@ -1007,7 +1024,9 @@ untar into a directory named DIR; otherwise, signal an error." (unless (file-exists-p file) (require 'autoload) (let ((coding-system-for-write 'utf-8-emacs-unix)) - (write-region (autoload-rubric file "package" nil) nil file nil 'silent))) + (with-suppressed-warnings ((obsolete autoload-rubric)) + (write-region (autoload-rubric file "package" nil) + nil file nil 'silent)))) file) (defvar autoload-timestamps) @@ -1311,7 +1330,7 @@ errors signaled by ERROR-FORM or by BODY). (cl-defun package--with-response-buffer-1 (url body &key async file error-function noerror &allow-other-keys) (if (string-match-p "\\`https?:" url) - (let ((url (concat url file))) + (let ((url (url-expand-file-name file url))) (if async (package--unless-error #'ignore (url-retrieve @@ -1646,6 +1665,7 @@ The variable `package-load-list' controls which packages to load." (require 'package) (package--activate-all))))) +;;;###autoload (defun package--activate-all () (dolist (elt (package--alist)) (condition-case err @@ -2067,7 +2087,10 @@ If PACKAGE is a `package-desc' object, MIN-VERSION is ignored." package-activated-list) ;; We used the quickstart: make it possible to use package-installed-p ;; even before package is fully initialized. - (memq package package-activated-list)) + (or + (memq package package-activated-list) + ;; Also check built-in packages. + (package-built-in-p package min-version))) (t (or (let ((pkg-descs (cdr (assq package (package--alist))))) @@ -2423,6 +2446,35 @@ object." (package-install pkg 'dont-select)) ;;;###autoload +(defun package-recompile (pkg) + "Byte-compile package PKG again. +PKG should be either a symbol, the package name, or a `package-desc' +object." + (interactive (list (intern (completing-read + "Recompile package: " + (mapcar #'symbol-name + (mapcar #'car package-alist)))))) + (let ((pkg-desc (if (package-desc-p pkg) + pkg + (cadr (assq pkg package-alist))))) + ;; Delete the old .elc files to ensure that we don't inadvertently + ;; load them (in case they contain byte code/macros that are now + ;; invalid). + (dolist (elc (directory-files-recursively + (package-desc-dir pkg-desc) "\\.elc\\'")) + (delete-file elc)) + (package--compile pkg-desc))) + +;;;###autoload +(defun package-recompile-all () + "Byte-compile all installed packages. +This is meant to be used only in the case the byte-compiled files +are invalid due to changed byte-code, macros or the like." + (interactive) + (pcase-dolist (`(_ ,pkg-desc) package-alist) + (package-recompile pkg-desc))) + +;;;###autoload (defun package-autoremove () "Remove packages that are no longer needed. @@ -3478,7 +3530,7 @@ If optional arg BUTTON is non-nil, describe its associated package." (let ((place (cdr desc)) (out (copy-sequence (car desc)))) (add-text-properties place (1+ place) - '(face (bold font-lock-warning-face)) + '(face help-key-binding) out) out)) (package--prettify-quick-help-key (cons desc 0)))) @@ -3491,9 +3543,6 @@ The full list of keys can be viewed with \\[describe-mode]." (message (mapconcat #'package--prettify-quick-help-key package--quick-help-keys "\n"))) -(define-obsolete-function-alias - 'package-menu-view-commentary 'package-menu-describe-package "24.1") - (defun package-menu-get-status () "Return status text of package at point in Package Menu." (package--ensure-package-menu-mode) @@ -4246,6 +4295,7 @@ activations need to be changed, such as when `package-load-list' is modified." (locate-user-emacs-file "package-quickstart.el") "Location of the file used to speed up activation of packages at startup." :type 'file + :group 'applications :initialize #'custom-initialize-delay :version "27.1") diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 07443dabfef..10bd4bc6886 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -607,31 +607,38 @@ recording whether the var has been referenced by earlier parts of the match." (symbolp . vectorp) (symbolp . stringp) (symbolp . byte-code-function-p) + (symbolp . compiled-function-p) (symbolp . recordp) (integerp . consp) (integerp . arrayp) (integerp . vectorp) (integerp . stringp) (integerp . byte-code-function-p) + (integerp . compiled-function-p) (integerp . recordp) (numberp . consp) (numberp . arrayp) (numberp . vectorp) (numberp . stringp) (numberp . byte-code-function-p) + (numberp . compiled-function-p) (numberp . recordp) (consp . arrayp) (consp . atom) (consp . vectorp) (consp . stringp) (consp . byte-code-function-p) + (consp . compiled-function-p) (consp . recordp) (arrayp . byte-code-function-p) + (arrayp . compiled-function-p) (vectorp . byte-code-function-p) + (vectorp . compiled-function-p) (vectorp . recordp) (stringp . vectorp) (stringp . recordp) - (stringp . byte-code-function-p))) + (stringp . byte-code-function-p) + (stringp . compiled-function-p))) (defun pcase--mutually-exclusive-p (pred1 pred2) (or (member (cons pred1 pred2) @@ -771,8 +778,8 @@ A and B can be one of: ((consp (cadr pat)) #'consp) ((stringp (cadr pat)) #'stringp) ((vectorp (cadr pat)) #'vectorp) - ((byte-code-function-p (cadr pat)) - #'byte-code-function-p)))) + ((compiled-function-p (cadr pat)) + #'compiled-function-p)))) (pcase--mutually-exclusive-p (cadr upat) otherpred)) '(:pcase--fail . nil)) ;; Since we turn (or 'a 'b 'c) into (pred (pcase--flip (memq '(a b c)))) diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index 24770fac67f..e6e8bb202da 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -216,19 +216,17 @@ Except for Lisp syntax this is the same as `reb-regexp'.") "Buffer to use for the RE Builder.") ;; Define the local "\C-c" keymap -(defvar reb-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-c" 'reb-toggle-case) - (define-key map "\C-c\C-q" 'reb-quit) - (define-key map "\C-c\C-w" 'reb-copy) - (define-key map "\C-c\C-s" 'reb-next-match) - (define-key map "\C-c\C-r" 'reb-prev-match) - (define-key map "\C-c\C-i" 'reb-change-syntax) - (define-key map "\C-c\C-e" 'reb-enter-subexp-mode) - (define-key map "\C-c\C-b" 'reb-change-target-buffer) - (define-key map "\C-c\C-u" 'reb-force-update) - map) - "Keymap used by the RE Builder.") +(defvar-keymap reb-mode-map + :doc "Keymap used by the RE Builder." + "C-c C-c" #'reb-toggle-case + "C-c C-q" #'reb-quit + "C-c C-w" #'reb-copy + "C-c C-s" #'reb-next-match + "C-c C-r" #'reb-prev-match + "C-c C-i" #'reb-change-syntax + "C-c C-e" #'reb-enter-subexp-mode + "C-c C-b" #'reb-change-target-buffer + "C-c C-u" #'reb-force-update) (easy-menu-define reb-mode-menu reb-mode-map "Menu for the RE Builder." @@ -263,12 +261,10 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (setq-local blink-matching-paren nil) (reb-mode-common)) -(defvar reb-lisp-mode-map - (let ((map (make-sparse-keymap))) - ;; Use the same "\C-c" keymap as `reb-mode' and use font-locking from - ;; `emacs-lisp-mode' - (define-key map "\C-c" (lookup-key reb-mode-map "\C-c")) - map)) +(defvar-keymap reb-lisp-mode-map + ;; Use the same "\C-c" keymap as `reb-mode' and use font-locking from + ;; `emacs-lisp-mode' + "C-c" (keymap-lookup reb-mode-map "C-c")) (define-derived-mode reb-lisp-mode emacs-lisp-mode "RE Builder Lisp" @@ -278,16 +274,22 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (require 'rx)) ; require rx anyway (reb-mode-common)) -(defvar reb-subexp-mode-map - (let ((m (make-keymap))) - (suppress-keymap m) - ;; Again share the "\C-c" keymap for the commands - (define-key m "\C-c" (lookup-key reb-mode-map "\C-c")) - (define-key m "q" 'reb-quit-subexp-mode) - (dotimes (digit 10) - (define-key m (int-to-string digit) 'reb-display-subexp)) - m) - "Keymap used by the RE Builder for the subexpression mode.") +(defvar-keymap reb-subexp-mode-map + :doc "Keymap used by the RE Builder for the subexpression mode." + :full t :suppress t + ;; Again share the "\C-c" keymap for the commands + "C-c" (keymap-lookup reb-mode-map "C-c") + "q" #'reb-quit-subexp-mode + "0" #'reb-display-subexp + "1" #'reb-display-subexp + "2" #'reb-display-subexp + "3" #'reb-display-subexp + "4" #'reb-display-subexp + "5" #'reb-display-subexp + "6" #'reb-display-subexp + "7" #'reb-display-subexp + "8" #'reb-display-subexp + "9" #'reb-display-subexp) (defun reb-mode-common () "Setup functions common to functions `reb-mode' and `reb-lisp-mode'." @@ -495,7 +497,8 @@ Optional argument SYNTAX must be specified if called non-interactively." (setq reb-re-syntax syntax) (when buffer (with-current-buffer buffer - (reb-initialize-buffer)))) + (reb-initialize-buffer)) + (message "Switched syntax to `%s'" reb-re-syntax))) (error "Invalid syntax: %s" syntax))) @@ -735,8 +738,7 @@ If SUBEXP is non-nil mark only the corresponding sub-expressions." (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) - t) + (eq 'font-lock-string-face face)) (throw 'found t)))))))) (defface reb-regexp-grouping-backslash @@ -817,7 +819,6 @@ If SUBEXP is non-nil mark only the corresponding sub-expressions." (defun reb-restart-font-lock () "Restart `font-lock-mode' to fit current regexp format." - (message "reb-restart-font-lock re-re-syntax=%s" reb-re-syntax) (with-current-buffer (get-buffer reb-buffer) (let ((font-lock-is-on font-lock-mode)) (font-lock-mode -1) diff --git a/lisp/emacs-lisp/regi.el b/lisp/emacs-lisp/regi.el index 0099d157e4e..a7d61ed51ca 100644 --- a/lisp/emacs-lisp/regi.el +++ b/lisp/emacs-lisp/regi.el @@ -5,7 +5,6 @@ ;; Author: 1993 Barry A. Warsaw, Century Computing, Inc. <bwarsaw@cen.com> ;; Created: 24-Feb-1993 ;; Old-Version: 1.8 -;; Last Modified: 1993/06/01 21:33:00 ;; Keywords: extensions, matching ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/ring.el b/lisp/emacs-lisp/ring.el index 2b2039f9d15..e8b92a532fa 100644 --- a/lisp/emacs-lisp/ring.el +++ b/lisp/emacs-lisp/ring.el @@ -42,6 +42,8 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + ;;; User Functions: ;;;###autoload @@ -51,6 +53,8 @@ (consp (cdr x)) (integerp (cadr x)) (vectorp (cddr x)))) +(cl-deftype ring () '(satisfies ring-p)) + ;;;###autoload (defun make-ring (size) "Make a ring that can contain SIZE elements." diff --git a/lisp/emacs-lisp/rmc.el b/lisp/emacs-lisp/rmc.el index 195035e6be9..dae6590b9bc 100644 --- a/lisp/emacs-lisp/rmc.el +++ b/lisp/emacs-lisp/rmc.el @@ -23,8 +23,6 @@ ;;; Code: -(require 'seq) - (defun rmc--add-key-description (elem) (let* ((char (car elem)) (name (cadr elem)) @@ -125,7 +123,8 @@ buf)) ;;;###autoload -(defun read-multiple-choice (prompt choices &optional help-string show-help) +(defun read-multiple-choice (prompt choices &optional help-string show-help + long-form) "Ask user to select an entry from CHOICES, promting with PROMPT. This function allows to ask the user a multiple-choice question. @@ -163,12 +162,21 @@ dialogs. Otherwise, the function will always use text-mode dialogs. The return value is the matching entry from the CHOICES list. +If LONG-FORM, do a `completing-read' over the NAME elements in +CHOICES instead. + Usage example: \(read-multiple-choice \"Continue connecting?\" \\='((?a \"always\") (?s \"session only\") (?n \"no\")))" + (if long-form + (read-multiple-choice--long-answers prompt choices) + (read-multiple-choice--short-answers + prompt choices help-string show-help))) + +(defun read-multiple-choice--short-answers (prompt choices help-string show-help) (let* ((prompt-choices (if show-help choices (append choices '((?? "?"))))) (altered-names (mapcar #'rmc--add-key-description prompt-choices)) @@ -244,6 +252,17 @@ Usage example: (kill-buffer buf)) (assq tchar choices))) +(defun read-multiple-choice--long-answers (prompt choices) + (let ((answer + (completing-read + (concat prompt " (" + (mapconcat #'identity (mapcar #'cadr choices) "/") + ") ") + (mapcar #'cadr choices) nil t))) + (seq-find (lambda (elem) + (equal (cadr elem) answer)) + choices))) + (provide 'rmc) ;;; rmc.el ends here diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index aa2486b47ec..ec51146484a 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -1110,6 +1110,15 @@ can expand to any number of values." (append rx--builtin-forms rx--builtin-symbols) "List of built-in rx names. These cannot be redefined by the user.") +;; Declare Lisp indentation rules for constructs that take 1 or 2 +;; parameters before a body of RX forms. +;; (`>=' and `=' are omitted because they are more likely to be used +;; as Lisp functions than RX constructs; `repeat' is a `defcustom' type.) +(put 'group-n 'lisp-indent-function 1) +(put 'submatch-n 'lisp-indent-function 1) +(put '** 'lisp-indent-function 2) + + (defun rx--translate (item) "Translate the rx-expression ITEM. Return (REGEXP . PRECEDENCE)." (cond @@ -1442,6 +1451,12 @@ following constructs: REF can be a number, as usual, or a name introduced by a previous (let REF ...) construct." + (rx--pcase-expand regexps)) + +;; Autoloaded because it's referred to by the pcase rx macro above, +;; whose body ends up in loaddefs.el. +;;;###autoload +(defun rx--pcase-expand (regexps) (let* ((rx--pcase-vars nil) (regexp (rx--to-expr (rx--pcase-transform (cons 'seq regexps))))) `(and (pred stringp) diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 133d3c9e118..b6f0f66e5b1 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -59,8 +59,8 @@ (eval-when-compile (require 'cl-generic)) ;; We used to use some sequence functions from cl-lib, but this -;; dependency was swapped around so that it will be easier to make -;; seq.el preloaded in the future. See also Bug#39761#26. +;; dependency was swapped around so that it's easier to make seq.el +;; preloaded. See also Bug#39761#26. (defmacro seq-doseq (spec &rest body) "Loop over a sequence. @@ -168,21 +168,25 @@ if positive or too small if negative)." ((or (stringp sequence) (vectorp sequence)) (substring sequence start end)) ((listp sequence) (let (len - (errtext (format "Bad bounding indices: %s, %s" start end))) + (orig-start start) + (orig-end end)) (and end (< end 0) (setq end (+ end (setq len (length sequence))))) (if (< start 0) (setq start (+ start (or len (setq len (length sequence)))))) (unless (>= start 0) - (error "%s" errtext)) + (error "Start index out of bounds: %s" orig-start)) (when (> start 0) (setq sequence (nthcdr (1- start) sequence)) - (or sequence (error "%s" errtext)) + (unless sequence + (error "Start index out of bounds: %s" orig-start)) (setq sequence (cdr sequence))) (if end - (let ((res nil)) - (while (and (>= (setq end (1- end)) start) sequence) - (push (pop sequence) res)) - (or (= (1+ end) start) (error "%s" errtext)) - (nreverse res)) + (let ((n (- end start))) + (when (or (< n 0) + (if len + (> end len) + (and (> n 0) (null (nthcdr (1- n) sequence))))) + (error "End index out of bounds: %s" orig-end)) + (take n sequence)) (copy-sequence sequence)))) (t (error "Unsupported sequence: %s" sequence)))) @@ -451,6 +455,33 @@ TESTFN is used to compare elements, or `equal' if TESTFN is nil." (setq result (cons elt result)))) (nreverse result))) +(cl-defmethod seq-uniq ((sequence list) &optional testfn) + (let ((result nil)) + (if (not testfn) + ;; Fast path. If the list is long, use a hash table to speed + ;; things up even more. + (let ((l (length sequence))) + (if (> l 100) + (let ((hash (make-hash-table :test #'equal :size l))) + (while sequence + (unless (gethash (car sequence) hash) + (setf (gethash (car sequence) hash) t) + (push (car sequence) result)) + (setq sequence (cdr sequence)))) + ;; Short list. + (while sequence + (unless (member (car sequence) result) + (push (car sequence) result)) + (pop sequence)))) + ;; Slower path. + (while sequence + (unless (seq-find (lambda (elem) + (funcall testfn elem (car sequence))) + result) + (push (car sequence) result)) + (pop sequence))) + (nreverse result))) + (cl-defgeneric seq-mapcat (function sequence &optional type) "Concatenate the result of applying FUNCTION to each element of SEQUENCE. The result is a sequence of type TYPE, or a list if TYPE is nil." @@ -587,11 +618,13 @@ Signal an error if SEQUENCE is empty." (cl-defmethod seq-take ((list list) n) "Optimized implementation of `seq-take' for lists." - (let ((result '())) - (while (and list (> n 0)) - (setq n (1- n)) - (push (pop list) result)) - (nreverse result))) + (if (eval-when-compile (fboundp 'take)) + (take n list) + (let ((result '())) + (while (and list (> n 0)) + (setq n (1- n)) + (push (pop list) result)) + (nreverse result)))) (cl-defmethod seq-drop-while (pred (list list)) "Optimized implementation of `seq-drop-while' for lists." @@ -632,5 +665,20 @@ Signal an error if SEQUENCE is empty." ;; we automatically highlight macros. (add-hook 'emacs-lisp-mode-hook #'seq--activate-font-lock-keywords)) +(defun seq-split (sequence length) + "Split SEQUENCE into a list of sub-sequences of at most LENGTH. +All the sub-sequences will be of LENGTH, except the last one, +which may be shorter." + (when (< length 1) + (error "Sub-sequence length must be larger than zero")) + (let ((result nil) + (seq-length (length sequence)) + (start 0)) + (while (< start seq-length) + (push (seq-subseq sequence start + (setq start (min seq-length (+ start length)))) + result)) + (nreverse result))) + (provide 'seq) ;;; seq.el ends here diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index 2343a9b589f..da32e4564f6 100644 --- a/lisp/emacs-lisp/shadow.el +++ b/lisp/emacs-lisp/shadow.el @@ -128,11 +128,8 @@ See the documentation for `list-load-path-shadows' for further information." (if (setq orig-dir (assoc file files - (when dir-case-insensitive - (lambda (f1 f2) - (eq (compare-strings f1 nil nil - f2 nil nil t) - t))))) + (and dir-case-insensitive + #'string-equal-ignore-case))) ;; This file was seen before, we have a shadowing. ;; Report it unless the files are identical. (let ((base1 (concat (cdr orig-dir) "/" (car orig-dir))) diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index a1256ce1b8b..990dabe351a 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -41,10 +41,12 @@ '((t :inherit variable-pitch)) "Face used for a section.") -(defvar shortdoc--groups nil) +;;;###autoload +(progn + (defvar shortdoc--groups nil) -(defmacro define-short-documentation-group (group &rest functions) - "Add GROUP to the list of defined documentation groups. + (defmacro define-short-documentation-group (group &rest functions) + "Add GROUP to the list of defined documentation groups. FUNCTIONS is a list of elements on the form: (FUNC @@ -88,8 +90,7 @@ string will be `read' and evaluated. (FUNC :no-eval EXAMPLE-FORM - :result RESULT-FORM ;Use `:result-string' if value is in string form - ) + :result RESULT-FORM) ;Use `:result-string' if value is in string form Using `:no-value' is the same as using `:no-eval'. @@ -102,17 +103,16 @@ execution of the documented form depends on some conditions. (FUNC :no-eval EXAMPLE-FORM - :eg-result RESULT-FORM ;Use `:eg-result-string' if value is in string form - ) + :eg-result RESULT-FORM) ;Use `:eg-result-string' if value is in string form A FUNC form can have any number of `:no-eval' (or `:no-value'), `:no-eval*', `:result', `:result-string', `:eg-result' and `:eg-result-string' properties." - (declare (indent defun)) - `(progn - (setq shortdoc--groups (delq (assq ',group shortdoc--groups) - shortdoc--groups)) - (push (cons ',group ',functions) shortdoc--groups))) + (declare (indent defun)) + `(progn + (setq shortdoc--groups (delq (assq ',group shortdoc--groups) + shortdoc--groups)) + (push (cons ',group ',functions) shortdoc--groups)))) (define-short-documentation-group alist "Alist Basics" @@ -243,6 +243,8 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), "Predicates for Strings" (string-equal :eval (string-equal "foo" "foo")) + (string-equal-ignore-case + :eval (string-equal-ignore-case "foo" "FOO")) (eq :eval (eq "foo" "foo")) (eql @@ -353,6 +355,13 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), (abbreviate-file-name :no-eval (abbreviate-file-name "/home/some-user") :eg-result "~some-user") + (file-parent-directory + :eval (file-parent-directory "/foo/bar") + :eval (file-parent-directory "~") + :eval (file-parent-directory "/tmp/") + :eval (file-parent-directory "foo/bar") + :eval (file-parent-directory "foo") + :eval (file-parent-directory "/")) "Quoted File Names" (file-name-quote :args (name) @@ -494,7 +503,7 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), (set-file-modes :no-value "(set-file-modes \"/tmp/foo\" #o644)") (set-file-times - :no-value (set-file-times "/tmp/foo" (current-time))) + :no-value (set-file-times "/tmp/foo")) "File Modes" (set-default-file-modes :no-value "(set-default-file-modes #o755)") @@ -588,6 +597,10 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :eval (nth 1 '(one two three))) (nthcdr :eval (nthcdr 1 '(one two three))) + (take + :eval (take 3 '(one two three four))) + (ntake + :eval (ntake 3 (list 'one 'two 'three 'four))) (elt :eval (elt '(one two three) 1)) (car-safe @@ -691,11 +704,6 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), (plist-put :no-eval (setq plist (plist-put plist 'd 4)) :eq-result (a 1 b 2 c 3 d 4)) - (lax-plist-get - :eval (lax-plist-get '("a" 1 "b" 2 "c" 3) "b")) - (lax-plist-put - :no-eval (setq plist (lax-plist-put plist "d" 4)) - :eq-result '("a" 1 "b" 2 "c" 3 "d" 4)) (plist-member :eval (plist-member '(a 1 b 2 c 3) 'b)) "Data About Lists" @@ -894,6 +902,8 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :eval (seq-subseq '(a b c d e) 2 4)) (seq-take :eval (seq-take '(a b c d e) 3)) + (seq-split + :eval (seq-split [0 1 2 3 5] 2)) (seq-take-while :eval (seq-take-while #'cl-evenp [2 4 9 6 5])) (seq-uniq @@ -931,12 +941,24 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :eval (point-min)) (point-max :eval (point-max)) + (pos-bol + :eval (pos-bol)) + (pos-eol + :eval (pos-eol)) + (bolp + :eval (bolp)) + (eolp + :eval (eolp)) (line-beginning-position :eval (line-beginning-position)) (line-end-position :eval (line-end-position)) (buffer-size :eval (buffer-size)) + (bobp + :eval (bobp)) + (eobp + :eval (eobp)) "Moving Around" (goto-char :no-eval (goto-char (point-max)) @@ -962,8 +984,13 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), (following-char :no-eval (following-char) :eg-result 67) + (preceding-char + :no-eval (preceding-char) + :eg-result 38) (char-after :eval (char-after 45)) + (char-before + :eval (char-before 13)) (get-byte :no-eval (get-byte 45) :eg-result-string "#xff") @@ -972,6 +999,8 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :no-value (delete-region (point-min) (point-max))) (erase-buffer :no-value (erase-buffer)) + (delete-line + :no-value (delete-line)) (insert :no-value (insert "This string will be inserted in the buffer\n")) (subst-char-in-region @@ -1175,9 +1204,6 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), (ash :eval (ash 1 4) :eval (ash 16 -1)) - (lsh - :eval (lsh 1 4) - :eval (lsh 16 -1)) (logand :no-eval "(logand #b10 #b111)" :result-string "#b10") @@ -1363,15 +1389,15 @@ If SAME-WINDOW, don't pop to a new window." 'action (lambda (_) (describe-function function)) 'follow-link t - 'help-echo (purecopy "mouse-1, RET: describe function")) + 'help-echo "mouse-1, RET: describe function") (insert-text-button (symbol-name function) 'face 'button 'action (lambda (_) (info-lookup-symbol function 'emacs-lisp-mode)) 'follow-link t - 'help-echo (purecopy "mouse-1, RET: show \ -function's documentation in the Info manual"))) + 'help-echo "mouse-1, RET: show \ +function's documentation in the Info manual")) (setq arglist-start (point)) (insert ")\n") ;; Doc string. diff --git a/lisp/emacs-lisp/shorthands.el b/lisp/emacs-lisp/shorthands.el index a9e4343715c..ffd3856db6c 100644 --- a/lisp/emacs-lisp/shorthands.el +++ b/lisp/emacs-lisp/shorthands.el @@ -61,8 +61,7 @@ (defun shorthands-font-lock-shorthands (limit) (when read-symbol-shorthands (while (re-search-forward - (eval-when-compile - (concat "\\_<\\(" lisp-mode-symbol-regexp "\\)\\_>")) + (concat "\\_<\\(" (rx lisp-mode-symbol) "\\)\\_>") limit t) (let* ((existing (get-text-property (match-beginning 1) 'face)) (probe (and (not (memq existing '(font-lock-comment-face diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 9cd793d05c5..bd7c3c82f97 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -87,15 +87,15 @@ threading." (defsubst hash-table-keys (hash-table) "Return a list of keys in HASH-TABLE." - (cl-loop for k being the hash-keys of hash-table collect k)) + (let ((keys nil)) + (maphash (lambda (k _) (push k keys)) hash-table) + keys)) (defsubst hash-table-values (hash-table) "Return a list of values in HASH-TABLE." - (cl-loop for v being the hash-values of hash-table collect v)) - -(defsubst string-empty-p (string) - "Check whether STRING is empty." - (string= string "")) + (let ((values nil)) + (maphash (lambda (_ v) (push v values)) hash-table) + values)) (defsubst string-join (strings &optional separator) "Join all STRINGS using SEPARATOR. @@ -107,13 +107,18 @@ characters; nil stands for the empty string." ;;;###autoload (defun string-truncate-left (string length) - "Truncate STRING to LENGTH, replacing initial surplus with \"...\"." + "If STRING is longer than LENGTH, return a truncated version. +When truncating, \"...\" is always prepended to the string, so +the resulting string may be longer than the original if LENGTH is +3 or smaller." (let ((strlen (length string))) (if (<= strlen length) string (setq length (max 0 (- length 3))) - (concat "..." (substring string (max 0 (- strlen 1 length))))))) + (concat "..." (substring string (min (1- strlen) + (max 0 (- strlen length)))))))) +;;;###autoload (defsubst string-blank-p (string) "Check whether STRING is either empty or only whitespace. The following characters count as whitespace here: space, tab, newline and @@ -167,9 +172,13 @@ non-nil, return the last LENGTH characters instead. If CODING-SYSTEM is non-nil, STRING will be encoded before limiting, and LENGTH is interpreted as the number of bytes to limit the string to. The result will be a unibyte string that is -shorter than LENGTH, but will not contain \"partial\" characters, -even if CODING-SYSTEM encodes characters with several bytes per -character. +shorter than LENGTH, but will not contain \"partial\" +characters (or glyphs), even if CODING-SYSTEM encodes characters +with several bytes per character. If the coding system specifies +prefix like the byte order mark (aka \"BOM\") or a shift-in sequence, +their bytes will be normally counted as part of LENGTH. This is +the case, for instance, with `utf-16'. If this isn't desired, use a +coding system that doesn't specify a BOM, like `utf-16le' or `utf-16be'. When shortening strings for display purposes, `truncate-string-to-width' is almost always a better alternative @@ -177,34 +186,55 @@ than this function." (unless (natnump length) (signal 'wrong-type-argument (list 'natnump length))) (if coding-system - (let ((result nil) - (result-length 0) - (index (if end (1- (length string)) 0))) - ;; FIXME: This implementation, which uses encode-coding-char - ;; to encode the string one character at a time, is in general - ;; incorrect: coding-systems that produce prefix or suffix - ;; bytes, such as ISO-2022-based or UTF-8/16 with BOM, will - ;; produce those bytes for each character, instead of just - ;; once for the entire string. encode-coding-char attempts to - ;; remove those extra bytes at least in some situations, but - ;; it cannot do that in all cases. And in any case, producing - ;; what is supposed to be a UTF-16 or ISO-2022-CN encoded - ;; string which lacks the BOM bytes at the beginning and the - ;; charset designation sequences at the head and tail of the - ;; result will definitely surprise the callers in some cases. - (while (let ((encoded (encode-coding-char - (aref string index) coding-system))) - (and (<= (+ (length encoded) result-length) length) - (progn - (push encoded result) - (cl-incf result-length (length encoded)) - (setq index (if end (1- index) - (1+ index)))) - (if end (> index -1) - (< index (length string))))) - ;; No body. - ) - (apply #'concat (if end result (nreverse result)))) + ;; The previous implementation here tried to encode char by + ;; char, and then adding up the length of the encoded octets, + ;; but that's not reliably in the presence of BOM marks and + ;; ISO-2022-CN which may add charset designations at the + ;; start/end of each encoded char (which we don't want). So + ;; iterate (with a binary search) instead to find the desired + ;; length. + (let* ((glyphs (string-glyph-split string)) + (nglyphs (length glyphs)) + (too-long (1+ nglyphs)) + (stop (max (/ nglyphs 2) 1)) + (gap stop) + candidate encoded found candidate-stop) + ;; We're returning the end of the string. + (when end + (setq glyphs (nreverse glyphs))) + (while (and (not found) + (< stop too-long)) + (setq encoded + (encode-coding-string (string-join (seq-take glyphs stop)) + coding-system)) + (cond + ((= (length encoded) length) + (setq found encoded + candidate-stop stop)) + ;; Too long; try shortening. + ((> (length encoded) length) + (setq too-long stop + stop (max (- stop gap) 1))) + ;; Too short; try lengthening. + (t + (setq candidate encoded + candidate-stop stop) + (setq stop + (if (>= stop nglyphs) + too-long + (min (+ stop gap) nglyphs))))) + (setq gap (max (/ gap 2) 1))) + (cond + ((not (or found candidate)) + "") + ;; We're returning the end, so redo the encoding. + (end + (encode-coding-string + (string-join (nreverse (seq-take glyphs candidate-stop))) + coding-system)) + (t + (or found candidate)))) + ;; Char-based version. (cond ((<= (length string) length) string) (end (substring string (- (length string) length))) @@ -224,13 +254,9 @@ the string." (unless (natnump length) (signal 'wrong-type-argument (list 'natnump length))) (let ((pad-length (- length (length string)))) - (if (< pad-length 0) - string - (concat (and start - (make-string pad-length (or padding ?\s))) - string - (and (not start) - (make-string pad-length (or padding ?\s))))))) + (cond ((<= pad-length 0) string) + (start (concat (make-string pad-length (or padding ?\s)) string)) + (t (concat string (make-string pad-length (or padding ?\s))))))) (defun string-chop-newline (string) "Remove the final newline (if any) from STRING." @@ -265,6 +291,7 @@ it makes no sense to convert it to a string using (set-buffer source-buffer) (replace-buffer-contents tmp-buffer max-secs max-costs))))))))) +;;;###autoload (defmacro named-let (name bindings &rest body) "Looping construct taken from Scheme. Like `let', bind variables in BINDINGS and then evaluate BODY, @@ -286,19 +313,6 @@ as the new values of the bound variables in the recursive invocation." (cl-labels ((,name ,fargs . ,body)) #',name) . ,aargs))) -(defmacro with-memoization (place &rest code) - "Return the value of CODE and stash it in PLACE. -If PLACE's value is non-nil, then don't bother evaluating CODE -and return the value found in PLACE instead." - (declare (indent 1) (debug (gv-place body))) - (gv-letplace (getter setter) place - `(or ,getter - ,(macroexp-let2 nil val (macroexp-progn code) - `(progn - ,(funcall setter val) - ,val))))) - - ;;;###autoload (defun string-pixel-width (string) "Return the width of STRING in pixels." @@ -453,6 +467,18 @@ be marked unmodified, effectively ignoring those changes." (equal ,hash (buffer-hash))) (restore-buffer-modified-p nil)))))))) +(defun emacs-etc--hide-local-variables () + "Hide local variables. +Used by `emacs-authors-mode' and `emacs-news-mode'." + (narrow-to-region (point-min) + (save-excursion + (goto-char (point-max)) + ;; Obfuscate to avoid this being interpreted + ;; as a local variable section itself. + (if (re-search-backward "^Local\sVariables:$" nil t) + (progn (forward-line -1) (point)) + (point-max))))) + (provide 'subr-x) ;;; subr-x.el ends here diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el index a4d7beade13..e1be3015838 100644 --- a/lisp/emacs-lisp/syntax.el +++ b/lisp/emacs-lisp/syntax.el @@ -124,15 +124,49 @@ When the last position scanned holds the first character of a otherwise nil. That construct can be a two character comment delimiter or an Escaped or Char-quoted character.")) -(defun syntax-propertize-wholelines (start end) - "Extend the region delimited by START and END to whole lines. +(defvar syntax-wholeline-max 10000 + "Maximum line length for syntax operations. +If lines are longer than that, syntax operations will treat them as chunks +of this size. Misfontification may then occur. +This is a tradeoff between correctly applying the syntax rules, +and avoiding major slowdown on pathologically long lines.") + +(defun syntax--lbp (&optional arg) + "Like `line-beginning-position' but obeying `syntax-wholeline-max'." + (let ((pos (point)) + (res (line-beginning-position arg))) + (cond + ((< (abs (- pos res)) syntax-wholeline-max) res) + ;; For lines that are too long, round to the nearest multiple of + ;; `syntax-wholeline-max'. We use rounding rather than just + ;; (min res (+ pos syntax-wholeline-max)) so that repeated calls + ;; to `syntax-propertize-wholelines' don't keep growing the bounds, + ;; i.e. it really behaves like additional line-breaks. + ((< res pos) + (let ((max syntax-wholeline-max)) + (max (point-min) (* max (truncate pos max))))) + (t + (let ((max syntax-wholeline-max)) + (min (point-max) (* max (ceiling pos max)))))))) + +(defun syntax-propertize-wholelines (beg end) + "Extend the region delimited by BEG and END to whole lines. This function is useful for `syntax-propertize-extend-region-functions'; see Info node `(elisp) Syntax Properties'." - (goto-char start) - (cons (line-beginning-position) - (progn (goto-char end) - (if (bolp) (point) (line-beginning-position 2))))) + ;; This let-binding was taken from + ;; `font-lock-extend-region-wholelines' where it was used to avoid + ;; inf-looping (Bug#21615) but for some reason it was not applied + ;; here in syntax.el and was used only for the "beg" side. + (let ((inhibit-field-text-motion t)) + (let ((new-beg (progn (goto-char beg) + (if (bolp) beg + (syntax--lbp)))) + (new-end (progn (goto-char end) + (if (bolp) end + (syntax--lbp 2))))) + (unless (and (eql beg new-beg) (eql end new-end)) + (cons new-beg new-end))))) (defun syntax-propertize-multiline (beg end) "Let `syntax-propertize' pay attention to the syntax-multiline property." @@ -345,10 +379,16 @@ END) suitable for `syntax-propertize-function'." (defvar-local syntax-ppss-table nil "Syntax-table to use during `syntax-ppss', if any.") -(defvar-local syntax-propertize--inhibit-flush nil - "If non-nil, `syntax-ppss-flush-cache' only flushes the ppss cache. -Otherwise it flushes both the ppss cache and the properties -set by `syntax-propertize'") +(defun syntax-propertize--in-process-p () + "Non-nil if we're inside `syntax-propertize'. +This is used to avoid infinite recursion as well as to handle cases where +`syntax-ppss' is called when the final `syntax-table' properties have not +yet been setup, in which case we may end up putting invalid info into the cache. +It's also used so that `syntax-ppss-flush-cache' can be used from within +`syntax-propertize' without ruining the `syntax-table' already set." + (eq syntax-propertize--done most-positive-fixnum)) + +(defvar-local syntax-ppss--updated-cache nil) (defun syntax-propertize (pos) "Ensure that syntax-table properties are set until POS (a buffer point)." @@ -370,21 +410,24 @@ set by `syntax-propertize'") (with-silent-modifications (with-syntax-table (or syntax-ppss-table (syntax-table)) (make-local-variable 'syntax-propertize--done) ;Just in case! + ;; Make sure we let-bind it only buffer-locally. + (make-local-variable 'syntax-ppss--updated-cache) (let* ((start (max (min syntax-propertize--done (point-max)) (point-min))) (end (max pos (min (point-max) (+ start syntax-propertize-chunk-size)))) (first t) - (repeat t)) + (repeat t) + (syntax-ppss--updated-cache nil)) (while repeat (setq repeat nil) (run-hook-wrapped 'syntax-propertize-extend-region-functions (lambda (f) - (let ((new (funcall f start end)) - ;; Avoid recursion! - (syntax-propertize--done most-positive-fixnum)) + ;; Bind `syntax-propertize--done' to avoid recursion! + (let* ((syntax-propertize--done most-positive-fixnum) + (new (funcall f start end))) (if (or (null new) (and (>= (car new) start) (<= (cdr new) end))) nil @@ -399,20 +442,26 @@ set by `syntax-propertize'") ;; Flush ppss cache between the original value of `start' and that ;; set above by syntax-propertize-extend-region-functions. (syntax-ppss-flush-cache start) - ;; Move the limit before calling the function, so the function - ;; can use syntax-ppss. + ;; Move the limit before calling the function, so it's + ;; done in case of errors. (setq syntax-propertize--done end) ;; (message "syntax-propertizing from %s to %s" start end) (remove-text-properties start end '(syntax-table nil syntax-multiline nil)) - ;; Make sure we only let-bind it buffer-locally. - (make-local-variable 'syntax-propertize--inhibit-flush) - ;; Let-bind `syntax-propertize--done' to avoid infinite recursion! - (let ((syntax-propertize--done most-positive-fixnum) - ;; Let `syntax-propertize-function' call - ;; `syntax-ppss-flush-cache' without worries. - (syntax-propertize--inhibit-flush t)) - (funcall syntax-propertize-function start end))))))))) + ;; Bind `syntax-propertize--done' to avoid recursion! + (let ((syntax-propertize--done most-positive-fixnum)) + (funcall syntax-propertize-function start end) + (when syntax-ppss--updated-cache + ;; `syntax-ppss' was called and updated the cache while we + ;; were propertizing so we need to flush the part of the + ;; cache that may have been rendered out-of-date by the new + ;; properties. + ;; We used to require syntax-propertize-functions to do that + ;; manually when applicable, but nowadays the `syntax-ppss' + ;; cache can be updated by too many functions, so the author + ;; of the syntax-propertize-function may not be aware it + ;; can happen. + (syntax-ppss-flush-cache start)))))))))) ;;; Link syntax-propertize with syntax.c. @@ -487,10 +536,10 @@ These are valid when the buffer has no restriction.") (define-obsolete-function-alias 'syntax-ppss-after-change-function #'syntax-ppss-flush-cache "27.1") -(defun syntax-ppss-flush-cache (beg &rest ignored) +(defun syntax-ppss-flush-cache (beg &rest _ignored) "Flush the cache of `syntax-ppss' starting at position BEG." ;; Set syntax-propertize to refontify anything past beg. - (unless syntax-propertize--inhibit-flush + (unless (syntax-propertize--in-process-p) (setq syntax-propertize--done (min beg syntax-propertize--done))) ;; Flush invalid cache entries. (dolist (cell (list syntax-ppss-wide syntax-ppss-narrow)) @@ -517,10 +566,16 @@ These are valid when the buffer has no restriction.") (setcdr cell cache))) )) -;;; FIXME: Explain this variable. Currently only its last (5th) slot is used. -;;; Perhaps the other slots should be removed? +;; FIXME: Explain this variable. Currently only its last (5th) slot is used. +;; Perhaps the other slots should be removed? +;; This variable is only used when `syntax-begin-function' is used and +;; will hence be removed together with `syntax-begin-function'. (defvar syntax-ppss-stats - [(0 . 0) (0 . 0) (0 . 0) (0 . 0) (0 . 0) (2 . 2500)]) + [(0 . 0) (0 . 0) (0 . 0) (0 . 0) (0 . 0) (2 . 2500)] + "Statistics about which case is more/less frequent in `syntax-ppss'. +The 5th slot drives the heuristic to use `syntax-begin-function'. +The rest is only useful if you're interested in tweaking the algorithm.") + (defun syntax-ppss-stats () (mapcar (lambda (x) (condition-case nil @@ -658,6 +713,7 @@ running the hook." ;; populate the cache so we won't need to do it again soon. (t (syntax-ppss--update-stats 3 pt-min pos) + (setq syntax-ppss--updated-cache t) ;; If `pt-min' is too far, add a few intermediate entries. (while (> (- pos pt-min) (* 2 syntax-ppss-max-span)) @@ -692,6 +748,7 @@ running the hook." (push pair ppss-cache) (setcar ppss-cache pair))))))))) + (setq syntax-ppss--updated-cache t) (setq ppss-last (cons pos ppss)) (setcar cell ppss-last) (setcdr cell ppss-cache) diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 7d815a3cedc..c01f3fd4fec 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -216,33 +216,28 @@ If ADVANCE is non-nil, move forward by one line afterwards." (while (re-search-forward re nil 'noerror) (tabulated-list-put-tag empty))))) -(defvar tabulated-list-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map (make-composed-keymap - button-buffer-map - special-mode-map)) - (define-key map "n" 'next-line) - (define-key map "p" 'previous-line) - (define-key map (kbd "M-<left>") 'tabulated-list-previous-column) - (define-key map (kbd "M-<right>") 'tabulated-list-next-column) - (define-key map "S" 'tabulated-list-sort) - (define-key map "}" 'tabulated-list-widen-current-column) - (define-key map "{" 'tabulated-list-narrow-current-column) - (define-key map [follow-link] 'mouse-face) - (define-key map [mouse-2] 'mouse-select-window) - map) - "Local keymap for `tabulated-list-mode' buffers.") - -(defvar tabulated-list-sort-button-map - (let ((map (make-sparse-keymap))) - (define-key map [header-line mouse-1] 'tabulated-list-col-sort) - (define-key map [header-line mouse-2] 'tabulated-list-col-sort) - (define-key map [mouse-1] 'tabulated-list-col-sort) - (define-key map [mouse-2] 'tabulated-list-col-sort) - (define-key map "\C-m" 'tabulated-list-sort) - (define-key map [follow-link] 'mouse-face) - map) - "Local keymap for `tabulated-list-mode' sort buttons.") +(defvar-keymap tabulated-list-mode-map + :doc "Local keymap for `tabulated-list-mode' buffers." + :parent (make-composed-keymap button-buffer-map + special-mode-map) + "n" #'next-line + "p" #'previous-line + "M-<left>" #'tabulated-list-previous-column + "M-<right>" #'tabulated-list-next-column + "S" #'tabulated-list-sort + "}" #'tabulated-list-widen-current-column + "{" #'tabulated-list-narrow-current-column + "<follow-link>" 'mouse-face + "<mouse-2>" #'mouse-select-window) + +(defvar-keymap tabulated-list-sort-button-map + :doc "Local keymap for `tabulated-list-mode' sort buttons." + "<header-line> <mouse-1>" #'tabulated-list-col-sort + "<header-line> <mouse-2>" #'tabulated-list-col-sort + "<mouse-1>" #'tabulated-list-col-sort + "<mouse-2>" #'tabulated-list-col-sort + "RET" #'tabulated-list-sort + "<follow-link>" 'mouse-face) (defun tabulated-list-make-glyphless-char-display-table () "Make the `glyphless-char-display' table used for text-mode frames. @@ -470,7 +465,7 @@ changing `tabulated-list-sort-key'." (let* ((elt (car entries)) (tabulated-list--near-rows (list - (or (tabulated-list-get-entry (point-at-bol 0)) (cadr elt)) + (or (tabulated-list-get-entry (pos-bol 0)) (cadr elt)) (cadr elt) (or (cadr (cadr entries)) (cadr elt)))) (id (car elt))) @@ -524,7 +519,7 @@ of column descriptors." (insert (make-string x ?\s))) (let ((tabulated-list--near-rows ; Bind it if not bound yet (Bug#25506). (or (bound-and-true-p tabulated-list--near-rows) - (list (or (tabulated-list-get-entry (point-at-bol 0)) + (list (or (tabulated-list-get-entry (pos-bol 0)) cols) cols)))) (dotimes (n ncols) @@ -616,7 +611,7 @@ This function only changes the buffer contents; it does not alter (cols (tabulated-list-get-entry)) (inhibit-read-only t)) (when cols - (delete-region (line-beginning-position) (1+ (line-end-position))) + (delete-region (pos-bol) (1+ (pos-eol))) (list id cols)))) (defun tabulated-list-set-col (col desc &optional change-entry-data) @@ -630,8 +625,8 @@ by setting the appropriate slot of the vector originally used to print this entry. If `tabulated-list-entries' has a list value, this is the vector stored within it." (let* ((opoint (point)) - (eol (line-end-position)) - (pos (line-beginning-position)) + (eol (pos-eol)) + (pos (pos-bol)) (id (tabulated-list-get-id pos)) (entry (tabulated-list-get-entry pos)) (prop 'tabulated-list-column-name) @@ -656,9 +651,9 @@ this is the vector stored within it." (goto-char pos) (let ((tabulated-list--near-rows (list - (tabulated-list-get-entry (point-at-bol 0)) + (tabulated-list-get-entry (pos-bol 0)) entry - (or (tabulated-list-get-entry (point-at-bol 2)) entry)))) + (or (tabulated-list-get-entry (pos-bol 2)) entry)))) (tabulated-list-print-col col desc (current-column))) (if change-entry-data (aset entry col desc)) @@ -790,7 +785,7 @@ If ARG is provided, move that many columns." (let ((prev (or (previous-single-property-change (point) 'tabulated-list-column-name) 1))) - (unless (< prev (line-beginning-position)) + (unless (< prev (pos-bol)) (goto-char prev))))) ;;; The mode definition: diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el index 33628d8f47f..cd2e388ce42 100644 --- a/lisp/emacs-lisp/testcover.el +++ b/lisp/emacs-lisp/testcover.el @@ -65,7 +65,6 @@ (eval-when-compile (require 'cl-lib)) (require 'edebug) -(provide 'testcover) ;;;========================================================================== @@ -677,4 +676,6 @@ The list is 1valued if all of its constituent elements are also 1valued." (testcover-analyze-coverage (cadr form))) (t (testcover-analyze-coverage-backquote form)))) +(provide 'testcover) + ;;; testcover.el ends here diff --git a/lisp/emacs-lisp/timer-list.el b/lisp/emacs-lisp/timer-list.el index aef18d0ba27..d48698234fc 100644 --- a/lisp/emacs-lisp/timer-list.el +++ b/lisp/emacs-lisp/timer-list.el @@ -81,13 +81,12 @@ ;; doing. Kids, don't try this at home! ;;;###autoload (put 'list-timers 'disabled "Beware: manually canceling timers can ruin your Emacs session.") -(defvar timer-list-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "c" 'timer-list-cancel) - (easy-menu-define nil map "" - '("Timers" - ["Cancel" timer-list-cancel t])) - map)) +(defvar-keymap timer-list-mode-map + "c" #'timer-list-cancel + :menu + '("Timers" + ["Cancel" timer-list-cancel t] + ["Quit" quit-window])) (define-derived-mode timer-list-mode tabulated-list-mode "Timer-List" "Mode for listing and controlling timers." diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index fd29abf40a3..b25a040a96c 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -122,7 +122,7 @@ of SECS seconds since the epoch. SECS may be a fraction." (setq ticks (ash ticks 1)) (setq hz (ash hz 1))) (let ((more-ticks (+ ticks trunc-s-ticks))) - (time-convert (cons (- more-ticks (% more-ticks trunc-s-ticks)) hz))))) + (time-convert (cons (- more-ticks (% more-ticks trunc-s-ticks)) hz) t)))) (defun timer-relative-time (time secs &optional usecs psecs) "Advance TIME by SECS seconds. @@ -159,32 +159,42 @@ SECS may be a fraction." timer) (defun timer--activate (timer &optional triggered-p reuse-cell idle) - (if (and (timerp timer) - (integerp (timer--high-seconds timer)) - (integerp (timer--low-seconds timer)) - (integerp (timer--usecs timer)) - (integerp (timer--psecs timer)) - (timer--function timer)) - (let ((timers (if idle timer-idle-list timer-list)) - last) - ;; Skip all timers to trigger before the new one. - (while (and timers (timer--time-less-p (car timers) timer)) - (setq last timers - timers (cdr timers))) - (if reuse-cell - (progn - (setcar reuse-cell timer) - (setcdr reuse-cell timers)) - (setq reuse-cell (cons timer timers))) - ;; Insert new timer after last which possibly means in front of queue. - (setf (cond (last (cdr last)) - (idle timer-idle-list) - (t timer-list)) - reuse-cell) - (setf (timer--triggered timer) triggered-p) - (setf (timer--idle-delay timer) idle) - nil) - (error "Invalid or uninitialized timer"))) + (let ((timers (if idle timer-idle-list timer-list)) + last) + (cond + ((not (and (timerp timer) + (integerp (timer--high-seconds timer)) + (integerp (timer--low-seconds timer)) + (integerp (timer--usecs timer)) + (integerp (timer--psecs timer)) + (timer--function timer))) + (error "Invalid or uninitialized timer")) + ;; FIXME: This is not reliable because `idle-delay' is only set late, + ;; by `timer-activate-when-idle' :-( + ;;((not (eq (not idle) + ;; (not (timer--idle-delay timer)))) + ;; (error "idle arg %S out of sync with idle-delay field of timer: %S" + ;; idle timer)) + ((memq timer timers) + (error "Timer already activated")) + (t + ;; Skip all timers to trigger before the new one. + (while (and timers (timer--time-less-p (car timers) timer)) + (setq last timers + timers (cdr timers))) + (if reuse-cell + (progn + (setcar reuse-cell timer) + (setcdr reuse-cell timers)) + (setq reuse-cell (cons timer timers))) + ;; Insert new timer after last which possibly means in front of queue. + (setf (cond (last (cdr last)) + (idle timer-idle-list) + (t timer-list)) + reuse-cell) + (setf (timer--triggered timer) triggered-p) + (setf (timer--idle-delay timer) idle) + nil)))) (defun timer-activate (timer &optional triggered-p reuse-cell) "Insert TIMER into `timer-list'. @@ -216,7 +226,7 @@ the time of the current timer. That's because the activated timer will fire right away." (timer--activate timer (not dont-wait) reuse-cell 'idle)) -(defalias 'disable-timeout 'cancel-timer) +(defalias 'disable-timeout #'cancel-timer) (defun cancel-timer (timer) "Remove TIMER from the list of active timers." @@ -430,7 +440,7 @@ The action is to call FUNCTION with arguments ARGS. This function returns a timer object which you can use in `cancel-timer'." (interactive "sRun after delay (seconds): \nNRepeat interval: \naFunction: ") - (apply 'run-at-time secs repeat function args)) + (apply #'run-at-time secs repeat function args)) (defun add-timeout (secs function object &optional repeat) "Add a timer to run SECS seconds from now, to call FUNCTION on OBJECT. @@ -457,7 +467,7 @@ This function returns a timer object which you can use in `cancel-timer'." (interactive (list (read-from-minibuffer "Run after idle (seconds): " nil nil t) (y-or-n-p "Repeat each time Emacs is idle? ") - (intern (completing-read "Function: " obarray 'fboundp t)))) + (intern (completing-read "Function: " obarray #'fboundp t)))) (let ((timer (timer-create))) (timer-set-function timer function args) (timer-set-idle-time timer secs repeat) diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el index 165f5c7bfe2..aea12f146da 100644 --- a/lisp/emacs-lisp/trace.el +++ b/lisp/emacs-lisp/trace.el @@ -1,6 +1,6 @@ ;;; trace.el --- tracing facility for Emacs Lisp functions -*- lexical-binding: t -*- -;; Copyright (C) 1993, 1998, 2000-2022 Free Software Foundation, Inc. +;; Copyright (C) 1993-2022 Free Software Foundation, Inc. ;; Author: Hans Chalupsky <hans@cs.buffalo.edu> ;; Maintainer: emacs-devel@gnu.org @@ -22,12 +22,6 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. -;; LCD Archive Entry: -;; trace|Hans Chalupsky|hans@cs.buffalo.edu| -;; Tracing facility for Emacs Lisp functions| -;; 1993/05/18 00:41:16|2.0|~/packages/trace.el.Z| - - ;;; Commentary: ;; Introduction: @@ -273,12 +267,11 @@ If `current-prefix-arg' is non-nil, also read a buffer and a \"context\" (if default (symbol-name default))))) (when current-prefix-arg (list - (read-buffer (format-prompt "Output to buffer" trace-buffer)) + (read-buffer "Output to buffer" trace-buffer) (let ((exp - (let ((minibuffer-completing-symbol t)) - (read-from-minibuffer "Context expression: " - nil read-expression-map t - 'read-expression-history)))) + (read-from-minibuffer "Context expression: " + nil read-expression-map t + 'read-expression-history))) (lambda () (let ((print-circle t) (print-escape-newlines t)) diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index 23e20c3b10c..3a966957ec5 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -27,6 +27,8 @@ ;;; Code: +(require 'icons) + (defgroup warnings nil "Log and display warnings." :version "22.1" @@ -201,20 +203,28 @@ SUPPRESS-LIST is the list of kinds of warnings to suppress." ;; we return t. some-match)) -(define-button-type 'warning-suppress-warning - 'action #'warning-suppress-action - 'help-echo "mouse-2, RET: Don't display this warning automatically") -(defun warning-suppress-action (button) - (customize-save-variable 'warning-suppress-types - (cons (list (button-get button 'warning-type)) - warning-suppress-types))) -(define-button-type 'warning-suppress-log-warning - 'action #'warning-suppress-log-action - 'help-echo "mouse-2, RET: Don't log this warning") -(defun warning-suppress-log-action (button) - (customize-save-variable 'warning-suppress-log-types - (cons (list (button-get button 'warning-type)) - warning-suppress-types))) +(define-icon warnings-suppress button + '((emoji "⛔") + (symbol " ■ ") + (text " stop ")) + "Suppress warnings." + :version "29.1" + :help-echo "Click to suppress this warning type") + +(defun warnings-suppress (type) + (pcase (car + (read-multiple-choice + (format "Suppress `%s' warnings? " type) + `((?y ,(format "yes, ignore `%s' warnings completely" type)) + (?n "no, just disable showing them") + (?q "quit and do nothing")))) + (?y + (customize-save-variable 'warning-suppress-log-types + (cons (list type) warning-suppress-log-types))) + (?n + (customize-save-variable 'warning-suppress-types + (cons (list type) warning-suppress-types))) + (_ (message "Exiting")))) ;;;###autoload (defun display-warning (type message &optional level buffer-name) @@ -289,23 +299,18 @@ entirely by setting `warning-suppress-types' or (unless (bolp) (funcall newline)) (setq start (point)) + ;; Don't output the button when doing batch compilation + ;; and similar. + (unless (or noninteractive (eq type 'bytecomp)) + (insert (buttonize (icon-string 'warnings-suppress) + #'warnings-suppress type) + " ")) (if warning-prefix-function (setq level-info (funcall warning-prefix-function level level-info))) (insert (format (nth 1 level-info) (format warning-type-format typename)) message) - ;; Don't output the buttons when doing batch compilation - ;; and similar. - (unless (or noninteractive (eq type 'bytecomp)) - (insert " ") - (insert-button "Disable showing" - 'type 'warning-suppress-warning - 'warning-type type) - (insert " ") - (insert-button "Disable logging" - 'type 'warning-suppress-log-warning - 'warning-type type)) (funcall newline) (when (and warning-fill-prefix (not (string-search "\n" message)) |