diff options
Diffstat (limited to 'lisp/emacs-lisp')
77 files changed, 6899 insertions, 3250 deletions
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index aaa12e8e3f9..b9a3a32a9b6 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -1840,8 +1840,7 @@ function at point for which PREDICATE returns non-nil)." (or default ;; Prefer func name at point, if it's an advised function etc. (let ((function (progn - (require 'help) - (function-called-at-point)))) + (function-called-at-point)))) (and function (member (symbol-name function) ad-advised-functions) (or (null predicate) @@ -1856,7 +1855,7 @@ function at point for which PREDICATE returns non-nil)." "There are no qualifying advised functions"))) (let* ((function (completing-read - (format "%s (default %s): " (or prompt "Function") default) + (format-prompt (or prompt "Function") default) ad-advised-functions (if predicate (lambda (function) @@ -1884,7 +1883,7 @@ class of FUNCTION)." (cl-return class))) (error "ad-read-advice-class: `%s' has no advices" function))) (let ((class (completing-read - (format "%s (default %s): " (or prompt "Class") default) + (format-prompt (or prompt "Class") default) ad-advice-class-completion-table nil t))) (if (equal class "") default @@ -1894,16 +1893,16 @@ class of FUNCTION)." "Read name of existing advice of CLASS for FUNCTION with completion. An optional PROMPT is used to prompt for the name." (let* ((name-completion-table - (mapcar (function (lambda (advice) - (list (symbol-name (ad-advice-name advice))))) + (mapcar (lambda (advice) + (list (symbol-name (ad-advice-name advice)))) (ad-get-advice-info-field function class))) (default (if (null name-completion-table) (error "ad-read-advice-name: `%s' has no %s advice" function class) (car (car name-completion-table)))) - (prompt (format "%s (default %s): " (or prompt "Name") default)) - (name (completing-read prompt name-completion-table nil t))) + (name (completing-read (format-prompt (or prompt "Name") default) + name-completion-table nil t))) (if (equal name "") (intern default) (intern name)))) @@ -1923,9 +1922,9 @@ be used to prompt for the function." (defun ad-read-regexp (&optional prompt) "Read a regular expression from the minibuffer." (let ((regexp (read-from-minibuffer - (concat (or prompt "Regular expression") - (if (equal ad-last-regexp "") ": " - (format " (default %s): " ad-last-regexp)))))) + (format-prompt (or prompt "Regular expression") + (and (not (equal ad-last-regexp "")) + ad-last-regexp))))) (setq ad-last-regexp (if (equal regexp "") ad-last-regexp regexp)))) @@ -2224,8 +2223,6 @@ For that it has to be fbound with a non-autoload definition." (let ((byte-compile-warnings byte-compile-warnings) ;; Don't pop up windows showing byte-compiler warnings. (warning-suppress-types '((bytecomp)))) - (if (featurep 'cl) - (byte-compile-disable-warning 'cl-functions)) (byte-compile (ad-get-advice-info-field function 'advicefunname)))) ;; @@@ Accessing argument lists: @@ -2255,13 +2252,11 @@ element is its actual current value, and the third element is either (let* ((parsed-arglist (ad-parse-arglist arglist)) (rest (nth 2 parsed-arglist))) `(list - ,@(mapcar (function - (lambda (req) - `(list ',req ,req 'required))) + ,@(mapcar (lambda (req) + `(list ',req ,req 'required)) (nth 0 parsed-arglist)) - ,@(mapcar (function - (lambda (opt) - `(list ',opt ,opt 'optional))) + ,@(mapcar (lambda (opt) + `(list ',opt ,opt 'optional)) (nth 1 parsed-arglist)) ,@(if rest (list `(list ',rest ,rest 'rest)))))) @@ -2372,28 +2367,26 @@ The assignment starts at position INDEX." (defun ad-insert-argument-access-forms (definition arglist) "Expands arg-access text macros in DEFINITION according to ARGLIST." (ad-substitute-tree - (function - (lambda (form) - (or (eq form 'ad-arg-bindings) - (and (memq (car-safe form) - '(ad-get-arg ad-get-args ad-set-arg ad-set-args)) - (integerp (car-safe (cdr form))))))) - (function - (lambda (form) - (if (eq form 'ad-arg-bindings) - (ad-retrieve-args-form arglist) - (let ((accessor (car form)) - (index (car (cdr form))) - (val (car (cdr (ad-insert-argument-access-forms - (cdr form) arglist))))) - (cond ((eq accessor 'ad-get-arg) - (ad-get-argument arglist index)) - ((eq accessor 'ad-set-arg) - (ad-set-argument arglist index val)) - ((eq accessor 'ad-get-args) - (ad-get-arguments arglist index)) - ((eq accessor 'ad-set-args) - (ad-set-arguments arglist index val))))))) + (lambda (form) + (or (eq form 'ad-arg-bindings) + (and (memq (car-safe form) + '(ad-get-arg ad-get-args ad-set-arg ad-set-args)) + (integerp (car-safe (cdr form)))))) + (lambda (form) + (if (eq form 'ad-arg-bindings) + (ad-retrieve-args-form arglist) + (let ((accessor (car form)) + (index (car (cdr form))) + (val (car (cdr (ad-insert-argument-access-forms + (cdr form) arglist))))) + (cond ((eq accessor 'ad-get-arg) + (ad-get-argument arglist index)) + ((eq accessor 'ad-set-arg) + (ad-set-argument arglist index val)) + ((eq accessor 'ad-get-args) + (ad-get-arguments arglist index)) + ((eq accessor 'ad-set-args) + (ad-set-arguments arglist index val)))))) definition)) ;; @@@ Mapping argument lists: @@ -2412,8 +2405,9 @@ as if they had been supplied to a function with TARGET-ARGLIST directly. Excess source arguments will be neglected, missing source arguments will be supplied as nil. Returns a `funcall' or `apply' form with the second element being `function' which has to be replaced by an actual function argument. -Example: (ad-map-arglists \\='(a &rest args) \\='(w x y z)) will return - (funcall ad--addoit-function a (car args) (car (cdr args)) (nth 2 args))." +Example: + (ad-map-arglists \\='(a &rest args) \\='(w x y z)) will return + (funcall ad--addoit-function a (car args) (car (cdr args)) (nth 2 args))." (let* ((parsed-source-arglist (ad-parse-arglist source-arglist)) (source-reqopt-args (append (nth 0 parsed-source-arglist) (nth 1 parsed-source-arglist))) @@ -2623,8 +2617,8 @@ should be modified. The assembled function will be returned." (defun ad-make-hook-form (function hook-name) "Make hook-form from FUNCTION's advice bodies in class HOOK-NAME." (let ((hook-forms - (mapcar (function (lambda (advice) - (ad-body-forms (ad-advice-definition advice)))) + (mapcar (lambda (advice) + (ad-body-forms (ad-advice-definition advice))) (ad-get-enabled-advices function hook-name)))) (if hook-forms (macroexp-progn (apply 'append hook-forms))))) @@ -3167,15 +3161,14 @@ usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...) (setq args (cdr args))))) (flags (mapcar - (function - (lambda (flag) + (lambda (flag) (let ((completion (try-completion (symbol-name flag) ad-defadvice-flags))) (cond ((eq completion t) flag) ((member completion ad-defadvice-flags) (intern completion)) (t (error "defadvice: Invalid or ambiguous flag: %s" - flag)))))) + flag))))) args)) (advice (ad-make-advice name (memq 'protect flags) @@ -3217,11 +3210,10 @@ undone on exit of this macro." (let* ((index -1) ;; Make let-variables to store current definitions: (current-bindings - (mapcar (function - (lambda (function) + (mapcar (lambda (function) (setq index (1+ index)) (list (intern (format "ad-oRiGdEf-%d" index)) - `(symbol-function ',function)))) + `(symbol-function ',function))) functions))) `(let ,current-bindings (unwind-protect diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index 36afeee9f02..ec7492dd4b1 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -1,4 +1,4 @@ -;; autoload.el --- maintain autoloads in loaddefs.el -*- lexical-binding: t -*- +;;; autoload.el --- maintain autoloads in loaddefs.el -*- lexical-binding: t -*- ;; Copyright (C) 1991-1997, 2001-2021 Free Software Foundation, Inc. @@ -220,16 +220,27 @@ expression, in which case we want to handle forms differently." ;; Convert defcustom to less space-consuming data. ((eq car 'defcustom) - (let ((varname (car-safe (cdr-safe form))) - (init (car-safe (cdr-safe (cdr-safe form)))) - (doc (car-safe (cdr-safe (cdr-safe (cdr-safe form))))) - ;; (rest (cdr-safe (cdr-safe (cdr-safe (cdr-safe form))))) - ) + (let* ((varname (car-safe (cdr-safe form))) + (props (nthcdr 4 form)) + (initializer (plist-get props :initialize)) + (init (car-safe (cdr-safe (cdr-safe form)))) + (doc (car-safe (cdr-safe (cdr-safe (cdr-safe form))))) + ;; (rest (cdr-safe (cdr-safe (cdr-safe (cdr-safe form))))) + ) `(progn - (defvar ,varname ,init ,doc) + ,(if (not (member initializer '(nil 'custom-initialize-default + #'custom-initialize-default + 'custom-initialize-reset + #'custom-initialize-reset))) + form + `(defvar ,varname ,init ,doc)) + ;; When we include the complete `form', this `custom-autoload' + ;; is not indispensable, but it still helps in case the `defcustom' + ;; doesn't specify its group explicitly, and probably in a few other + ;; corner cases. (custom-autoload ',varname ,file ,(condition-case nil - (null (cadr (memq :set form))) + (null (plist-get props :set)) (error nil)))))) ((eq car 'defgroup) @@ -254,12 +265,12 @@ expression, in which case we want to handle forms differently." ;; the doc-string in FORM. ;; Those properties are now set in lisp-mode.el. -(defun autoload-find-generated-file () +(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) - (delay-mode-hooks t) - (file (autoload-generated-file))) + (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 @@ -267,18 +278,20 @@ expression, in which case we want to handle forms differently." (if (zerop (buffer-size)) (insert (autoload-rubric file nil t))) (current-buffer)))) -(defun autoload-generated-file () - "Return `generated-autoload-file' as an absolute name. -If local to the current buffer, expand using the default directory; -otherwise, using `source-directory'/lisp." - (expand-file-name generated-autoload-file +(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, @@ -366,7 +379,8 @@ FILE's name." (let ((basename (file-name-nondirectory file)) (lp (if (equal type "package") (setq type "autoloads")))) (concat ";;; " basename - " --- automatically extracted " (or type "autoloads") "\n" + " --- automatically extracted " (or type "autoloads") + " -*- lexical-binding: t -*-\n" ";;\n" ";;; Code:\n\n" (if lp @@ -453,13 +467,12 @@ which lists the file name and which functions are in it, etc." (defvar no-update-autoloads nil "File local variable to prevent scanning this file for autoload cookies.") -(defun autoload-file-load-name (file) +(defun autoload-file-load-name (file outfile) "Compute the name that will be used to load FILE." ;; OUTFILE should be the name of the global loaddefs.el file, which ;; is expected to be at the root directory of the files we're ;; scanning for autoloads and will be in the `load-path'. - (let* ((outfile (default-value 'generated-autoload-file)) - (name (file-relative-name file (file-name-directory outfile))) + (let* ((name (file-relative-name file (file-name-directory outfile))) (names '()) (dir (file-name-directory outfile))) ;; If `name' has directory components, only keep the @@ -489,8 +502,9 @@ 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 ((generated-autoload-file buffer-file-name)) - (autoload-generate-file-autoloads file (current-buffer)))) + (let ((autoload-modified-buffers nil)) + (autoload-generate-file-autoloads file (current-buffer) buffer-file-name) + autoload-modified-buffers)) (defvar autoload-compute-prefixes t "If non-nil, autoload will add code to register the prefixes used in a file. @@ -604,11 +618,10 @@ Don't try to split prefixes that are already longer than that.") prefix file dropped) nil)))) prefixes))) - `(if (fboundp 'register-definition-prefixes) - (register-definition-prefixes ,file ',(sort (delq nil strings) - 'string<))))))) + `(register-definition-prefixes ,file ',(sort (delq nil strings) + 'string<)))))) -(defun autoload--setup-output (otherbuf outbuf absfile load-name) +(defun autoload--setup-output (otherbuf outbuf absfile load-name output-file) (let ((outbuf (or (if otherbuf ;; A file-local setting of @@ -616,7 +629,7 @@ Don't try to split prefixes that are already longer than that.") ;; should ignore OUTBUF. nil outbuf) - (autoload-find-destination absfile load-name) + (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, @@ -673,23 +686,16 @@ Don't try to split prefixes that are already longer than that.") More specifically those definitions will not be considered for the `register-definition-prefixes' call.") -;; When called from `generate-file-autoloads' we should ignore -;; `generated-autoload-file' altogether. When called from -;; `update-file-autoloads' we don't know `outbuf'. And when called from -;; `update-directory-autoloads' it's in between: we know the default -;; `outbuf' but we should obey any file-local setting of -;; `generated-autoload-file'. (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, it will be determined by `autoload-generated-file'. -If provided, OUTFILE is expected to be the file name of OUTBUF. -If OUTFILE is non-nil and FILE specifies a `generated-autoload-file' -different from OUTFILE, then OUTBUF is ignored. +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 @@ -717,16 +723,19 @@ FILE's modification time." (setq load-name (if (stringp generated-autoload-load-name) generated-autoload-load-name - (autoload-file-load-name absfile))) + (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))) - (equal outfile (autoload-generated-file))))) + (downcase (autoload-generated-file + outfile))) + (equal outfile (autoload-generated-file + outfile))))) (setq otherbuf t)) (save-excursion (save-restriction @@ -740,7 +749,8 @@ FILE's modification time." (file-name-sans-extension (file-name-nondirectory file)))) (setq output-start (autoload--setup-output - otherbuf outbuf absfile load-name)) + otherbuf outbuf absfile + load-name outfile)) (let ((standard-output (marker-buffer output-start)) (print-quoted t)) (princ `(push (purecopy @@ -758,7 +768,8 @@ FILE's modification time." ;; 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))) + otherbuf outbuf absfile + load-name outfile))) (autoload--print-cookie-text output-start load-name file)) ((= (following-char) ?\;) ;; Don't read the comment. @@ -789,7 +800,7 @@ FILE's modification time." ((not otherbuf) (unless output-start (setq output-start (autoload--setup-output - nil outbuf absfile load-name))) + nil outbuf absfile load-name outfile))) (let ((autoload-print-form-outbuf (marker-buffer output-start))) (autoload-print-form form))) @@ -801,9 +812,8 @@ FILE's modification time." ;; then passing otherbuf=nil is enough, but if ;; outbuf is nil, that won't cut it, so we ;; locally bind generated-autoload-file. - (let ((generated-autoload-file - (default-value 'generated-autoload-file))) - (autoload--setup-output nil outbuf absfile load-name))) + (autoload--setup-output nil outbuf absfile load-name + outfile)) (autoload-print-form-outbuf (marker-buffer other-output-start))) (autoload-print-form form) @@ -895,7 +905,7 @@ FILE's modification time." (cons (lambda () (ignore-errors (delete-file tempfile))) kill-emacs-hook))) (unless (= temp-modes desired-modes) - (set-file-modes tempfile 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)) @@ -925,19 +935,23 @@ 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: "))) - (let* ((generated-autoload-file (or outfile generated-autoload-file)) - (autoload-modified-buffers nil) + (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))) + (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) +(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. @@ -947,12 +961,12 @@ 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 (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) + (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)) @@ -1033,12 +1047,31 @@ 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, and temporarily bind the variable -`generated-autoload-file' to this value. 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." +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 @@ -1049,10 +1082,10 @@ write its autoloads into the specified file instead." (push suf tmp))) (concat "\\`[^=.].*" (regexp-opt tmp t) "\\'"))) (files (apply #'nconc - (mapcar (lambda (dir) - (directory-files (expand-file-name dir) - t files-re)) - dirs))) + (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) @@ -1060,16 +1093,12 @@ write its autoloads into the specified file instead." ;; files because of file-local autoload-generated-file settings. (no-autoloads nil) (autoload-modified-buffers nil) - (generated-autoload-file - (if (called-interactively-p 'interactive) - (read-file-name "Write autoload definitions to file: ") - generated-autoload-file)) (output-time - (if (file-exists-p generated-autoload-file) - (file-attribute-modification-time - (file-attributes generated-autoload-file))))) + (and (file-exists-p output-file) + (file-attribute-modification-time + (file-attributes output-file))))) - (with-current-buffer (autoload-find-generated-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) @@ -1124,10 +1153,9 @@ write its autoloads into the specified file instead." ;; 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-string + (byte-compile-info (concat "Scraping files for " - (file-relative-name - generated-autoload-file))) + (file-relative-name output-file))) 0 (length files) nil 10)) (file-count 0) file-time) @@ -1167,6 +1195,19 @@ write its autoloads into the specified file instead." ;; 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. @@ -1190,8 +1231,9 @@ should be non-nil)." (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) - (apply #'update-directory-autoloads args))) + (make-directory-autoloads args generated-autoload-file))) (provide 'autoload) diff --git a/lisp/emacs-lisp/backquote.el b/lisp/emacs-lisp/backquote.el index e4f786df8f7..173c11644d5 100644 --- a/lisp/emacs-lisp/backquote.el +++ b/lisp/emacs-lisp/backquote.el @@ -1,4 +1,4 @@ -;;; backquote.el --- implement the ` Lisp construct +;;; backquote.el --- implement the ` Lisp construct -*- lexical-binding: t -*- ;; Copyright (C) 1990, 1992, 1994, 2001-2021 Free Software Foundation, ;; Inc. diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el index 701e6c513f3..14bc2817390 100644 --- a/lisp/emacs-lisp/benchmark.el +++ b/lisp/emacs-lisp/benchmark.el @@ -81,7 +81,7 @@ result. The overhead of the `lambda's is accounted for." (gcs (make-symbol "gcs")) (gc (make-symbol "gc")) (code (byte-compile `(lambda () ,@forms))) - (lambda-code (byte-compile '(lambda ())))) + (lambda-code (byte-compile '(lambda ())))) `(let ((,gc gc-elapsed) (,gcs gcs-done)) (list ,(if (or (symbolp repetitions) (> repetitions 1)) diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 8d384e2c240..0d9ba57d663 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -1,4 +1,4 @@ -;;; bindat.el --- binary data structure packing and unpacking. +;;; bindat.el --- binary data structure packing and unpacking. -*- lexical-binding: t; -*- ;; Copyright (C) 2002-2021 Free Software Foundation, Inc. @@ -149,9 +149,6 @@ ;; | ip -- 4 byte vector ;; | bits LEN -- List with bits set in LEN bytes. ;; -;; -- Note: 32 bit values may be limited by emacs' INTEGER -;; implementation limits. -;; ;; -- Example: `bits 2' will unpack 0x28 0x1c to (2 3 4 11 13) ;; and 0x1c 0x28 to (3 5 10 11 12). @@ -201,7 +198,7 @@ (defun bindat--unpack-u8 () (prog1 - (aref bindat-raw bindat-idx) + (aref bindat-raw bindat-idx) (setq bindat-idx (1+ bindat-idx)))) (defun bindat--unpack-u16 () @@ -279,6 +276,8 @@ (t nil))) (defun bindat--unpack-group (spec) + (with-suppressed-warnings ((lexical last)) + (defvar last)) (let (struct last) (while spec (let* ((item (car spec)) @@ -290,65 +289,68 @@ data) (setq spec (cdr spec)) (if (and (consp field) (eq (car field) 'eval)) - (setq field (eval (car (cdr field))))) + (setq field (eval (car (cdr field)) t))) (if (and type (consp type) (eq (car type) 'eval)) - (setq type (eval (car (cdr type))))) + (setq type (eval (car (cdr type)) t))) (if (and len (consp len) (eq (car len) 'eval)) - (setq len (eval (car (cdr len))))) + (setq len (eval (car (cdr len)) t))) (if (memq field '(eval fill align struct union)) (setq tail 2 len type type field field nil)) (if (and (consp len) (not (eq type 'eval))) - (setq len (apply 'bindat-get-field struct len))) + (setq len (apply #'bindat-get-field struct len))) (if (not len) (setq len 1)) (cond ((eq type 'eval) (if field - (setq data (eval len)) - (eval len))) + (setq data (eval len t)) + (eval len t))) ((eq type 'fill) (setq bindat-idx (+ bindat-idx len))) ((eq type 'align) (while (/= (% bindat-idx len) 0) (setq bindat-idx (1+ bindat-idx)))) ((eq type 'struct) - (setq data (bindat--unpack-group (eval len)))) + (setq data (bindat--unpack-group (eval len t)))) ((eq type 'repeat) (let ((index 0) (count len)) (while (< index count) - (setq data (cons (bindat--unpack-group (nthcdr tail item)) data)) + (push (bindat--unpack-group (nthcdr tail item)) data) (setq index (1+ index))) (setq data (nreverse data)))) ((eq type 'union) + (with-suppressed-warnings ((lexical tag)) + (defvar tag)) (let ((tag len) (cases (nthcdr tail item)) case cc) (while cases (setq case (car cases) cases (cdr cases) cc (car case)) (if (or (equal cc tag) (equal cc t) - (and (consp cc) (eval cc))) + (and (consp cc) (eval cc t))) (setq data (bindat--unpack-group (cdr case)) cases nil))))) (t (setq data (bindat--unpack-item type len vectype) last data))) (if data - (if field - (setq struct (cons (cons field data) struct)) - (setq struct (append data struct)))))) + (setq struct (if field + (cons (cons field data) struct) + (append data struct)))))) struct)) -(defun bindat-unpack (spec bindat-raw &optional bindat-idx) - "Return structured data according to SPEC for binary data in BINDAT-RAW. -BINDAT-RAW is a unibyte string or vector. -Optional third arg BINDAT-IDX specifies the starting offset in BINDAT-RAW." - (when (multibyte-string-p bindat-raw) +(defun bindat-unpack (spec raw &optional idx) + "Return structured data according to SPEC for binary data in RAW. +RAW is a unibyte string or vector. +Optional third arg IDX specifies the starting offset in RAW." + (when (multibyte-string-p raw) (error "String is multibyte")) - (unless bindat-idx (setq bindat-idx 0)) - (bindat--unpack-group spec)) + (let ((bindat-idx (or idx 0)) + (bindat-raw raw)) + (bindat--unpack-group spec))) (defun bindat-get-field (struct &rest field) "In structured data STRUCT, return value of field named FIELD. @@ -376,6 +378,8 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (ip . 4))) (defun bindat--length-group (struct spec) + (with-suppressed-warnings ((lexical last)) + (defvar last)) (let (last) (while spec (let* ((item (car spec)) @@ -386,32 +390,31 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (tail 3)) (setq spec (cdr spec)) (if (and (consp field) (eq (car field) 'eval)) - (setq field (eval (car (cdr field))))) + (setq field (eval (car (cdr field)) t))) (if (and type (consp type) (eq (car type) 'eval)) - (setq type (eval (car (cdr type))))) + (setq type (eval (car (cdr type)) t))) (if (and len (consp len) (eq (car len) 'eval)) - (setq len (eval (car (cdr len))))) + (setq len (eval (car (cdr len)) t))) (if (memq field '(eval fill align struct union)) (setq tail 2 len type type field field nil)) (if (and (consp len) (not (eq type 'eval))) - (setq len (apply 'bindat-get-field struct len))) + (setq len (apply #'bindat-get-field struct len))) (if (not len) (setq len 1)) (while (eq type 'vec) - (let ((vlen 1)) - (if (consp vectype) - (setq len (* len (nth 1 vectype)) - type (nth 2 vectype)) - (setq type (or vectype 'u8) - vectype nil)))) + (if (consp vectype) + (setq len (* len (nth 1 vectype)) + type (nth 2 vectype)) + (setq type (or vectype 'u8) + vectype nil))) (cond ((eq type 'eval) (if field - (setq struct (cons (cons field (eval len)) struct)) - (eval len))) + (setq struct (cons (cons field (eval len t)) struct)) + (eval len t))) ((eq type 'fill) (setq bindat-idx (+ bindat-idx len))) ((eq type 'align) @@ -419,7 +422,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (setq bindat-idx (1+ bindat-idx)))) ((eq type 'struct) (bindat--length-group - (if field (bindat-get-field struct field) struct) (eval len))) + (if field (bindat-get-field struct field) struct) (eval len t))) ((eq type 'repeat) (let ((index 0) (count len)) (while (< index count) @@ -428,13 +431,15 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (nthcdr tail item)) (setq index (1+ index))))) ((eq type 'union) + (with-suppressed-warnings ((lexical tag)) + (defvar tag)) (let ((tag len) (cases (nthcdr tail item)) case cc) (while cases (setq case (car cases) cases (cdr cases) cc (car case)) (if (or (equal cc tag) (equal cc t) - (and (consp cc) (eval cc))) + (and (consp cc) (eval cc t))) (progn (bindat--length-group struct (cdr case)) (setq cases nil)))))) @@ -539,6 +544,8 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (setq bindat-idx (+ bindat-idx len))))) (defun bindat--pack-group (struct spec) + (with-suppressed-warnings ((lexical last)) + (defvar last)) (let (last) (while spec (let* ((item (car spec)) @@ -549,25 +556,25 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (tail 3)) (setq spec (cdr spec)) (if (and (consp field) (eq (car field) 'eval)) - (setq field (eval (car (cdr field))))) + (setq field (eval (car (cdr field)) t))) (if (and type (consp type) (eq (car type) 'eval)) - (setq type (eval (car (cdr type))))) + (setq type (eval (car (cdr type)) t))) (if (and len (consp len) (eq (car len) 'eval)) - (setq len (eval (car (cdr len))))) + (setq len (eval (car (cdr len)) t))) (if (memq field '(eval fill align struct union)) (setq tail 2 len type type field field nil)) (if (and (consp len) (not (eq type 'eval))) - (setq len (apply 'bindat-get-field struct len))) + (setq len (apply #'bindat-get-field struct len))) (if (not len) (setq len 1)) (cond ((eq type 'eval) (if field - (setq struct (cons (cons field (eval len)) struct)) - (eval len))) + (setq struct (cons (cons field (eval len t)) struct)) + (eval len t))) ((eq type 'fill) (setq bindat-idx (+ bindat-idx len))) ((eq type 'align) @@ -575,7 +582,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (setq bindat-idx (1+ bindat-idx)))) ((eq type 'struct) (bindat--pack-group - (if field (bindat-get-field struct field) struct) (eval len))) + (if field (bindat-get-field struct field) struct) (eval len t))) ((eq type 'repeat) (let ((index 0) (count len)) (while (< index count) @@ -584,13 +591,15 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (nthcdr tail item)) (setq index (1+ index))))) ((eq type 'union) + (with-suppressed-warnings ((lexical tag)) + (defvar tag)) (let ((tag len) (cases (nthcdr tail item)) case cc) (while cases (setq case (car cases) cases (cdr cases) cc (car case)) (if (or (equal cc tag) (equal cc t) - (and (consp cc) (eval cc))) + (and (consp cc) (eval cc t))) (progn (bindat--pack-group struct (cdr case)) (setq cases nil)))))) @@ -599,19 +608,19 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (bindat--pack-item last type len vectype) )))))) -(defun bindat-pack (spec struct &optional bindat-raw bindat-idx) +(defun bindat-pack (spec struct &optional raw idx) "Return binary data packed according to SPEC for structured data STRUCT. -Optional third arg BINDAT-RAW is a pre-allocated unibyte string or vector to +Optional third arg RAW is a pre-allocated unibyte string or vector to pack into. -Optional fourth arg BINDAT-IDX is the starting offset into BINDAT-RAW." - (when (multibyte-string-p bindat-raw) +Optional fourth arg IDX is the starting offset into RAW." + (when (multibyte-string-p raw) (error "Pre-allocated string is multibyte")) - (let ((no-return bindat-raw)) - (unless bindat-idx (setq bindat-idx 0)) - (unless bindat-raw - (setq bindat-raw (make-string (+ bindat-idx (bindat-length spec struct)) 0))) + (let* ((bindat-idx (or idx 0)) + (bindat-raw + (or raw + (make-string (+ bindat-idx (bindat-length spec struct)) 0)))) (bindat--pack-group struct spec) - (if no-return nil bindat-raw))) + (if raw nil bindat-raw))) ;; Misc. format conversions @@ -627,7 +636,7 @@ only that many elements from VECT." (while (> i 0) (setq i (1- i) s (cons (format (if (= i 0) fmt fmt2) (aref vect i)) s))) - (apply 'concat s))) + (apply #'concat s))) (defun bindat-vector-to-dec (vect &optional sep) "Format vector VECT in decimal format separated by dots. @@ -635,7 +644,7 @@ If optional second arg SEP is a string, use that as separator." (bindat-format-vector vect "%d" (if (stringp sep) sep "."))) (defun bindat-vector-to-hex (vect &optional sep) - "Format vector VECT in hex format separated by dots. + "Format vector VECT in hex format separated by colons. If optional second arg SEP is a string, use that as separator." (bindat-format-vector vect "%02x" (if (stringp sep) sep ":"))) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 492218fcd7c..66a117fccc8 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -227,7 +227,7 @@ ;;; byte-compile optimizers to support inlining -(put 'inline 'byte-optimizer 'byte-optimize-inline-handler) +(put 'inline 'byte-optimizer #'byte-optimize-inline-handler) (defun byte-optimize-inline-handler (form) "byte-optimize-handler for the `inline' special-form." @@ -284,8 +284,10 @@ ;; If `fn' is from the same file, it has already ;; been preprocessed! `(function ,fn) - (byte-compile-preprocess - (byte-compile--reify-function fn))))) + ;; Try and process it "in its original environment". + (let ((byte-compile-bound-variables nil)) + (byte-compile-preprocess + (byte-compile--reify-function fn)))))) (if (eq (car-safe newfn) 'function) (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form))) ;; This can happen because of macroexp-warn-and-return &co. @@ -374,201 +376,184 @@ ;; the important aspect is that they are subrs that don't evaluate all of ;; their args.) ;; - (let ((fn (car-safe form)) - tmp) - (cond ((not (consp form)) - (if (not (and for-effect - (or byte-compile-delete-errors - (not (symbolp form)) - (eq form t)))) - form)) - ((eq fn 'quote) - (if (cdr (cdr form)) - (byte-compile-warn "malformed quote form: `%s'" - (prin1-to-string form))) - ;; map (quote nil) to nil to simplify optimizer logic. - ;; map quoted constants to nil if for-effect (just because). - (and (nth 1 form) - (not for-effect) - form)) - ((eq (car-safe fn) 'lambda) - (let ((newform (byte-compile-unfold-lambda form))) - (if (eq newform form) - ;; Some error occurred, avoid infinite recursion - form - (byte-optimize-form-code-walker newform for-effect)))) - ((eq (car-safe fn) 'closure) form) - ((memq fn '(let let*)) - ;; recursively enter the optimizer for the bindings and body - ;; of a let or let*. This for depth-firstness: forms that - ;; are more deeply nested are optimized first. - (cons fn + ;; FIXME: There are a bunch of `byte-compile-warn' here which arguably + ;; have no place in an optimizer: the corresponding tests should be + ;; performed in `macroexpand-all', or in `cconv', or in `bytecomp'. + (let ((fn (car-safe form))) + (pcase form + ((pred (not consp)) + (if (not (and for-effect + (or byte-compile-delete-errors + (not (symbolp form)) + (eq form t)))) + form)) + (`(quote . ,v) + (if (cdr v) + (byte-compile-warn "malformed quote form: `%s'" + (prin1-to-string form))) + ;; Map (quote nil) to nil to simplify optimizer logic. + ;; Map quoted constants to nil if for-effect (just because). + (and (car v) + (not for-effect) + form)) + (`(,(or 'let 'let*) . ,(or `(,bindings . ,exps) pcase--dontcare)) + ;; Recursively enter the optimizer for the bindings and body + ;; of a let or let*. This for depth-firstness: forms that + ;; are more deeply nested are optimized first. + (cons fn (cons (mapcar (lambda (binding) - (if (symbolp binding) - binding - (if (cdr (cdr binding)) - (byte-compile-warn "malformed let binding: `%s'" - (prin1-to-string binding))) - (list (car binding) - (byte-optimize-form (nth 1 binding) nil)))) - (nth 1 form)) - (byte-optimize-body (cdr (cdr form)) for-effect)))) - ((eq fn 'cond) - (cons fn - (mapcar (lambda (clause) - (if (consp clause) - (cons - (byte-optimize-form (car clause) nil) - (byte-optimize-body (cdr clause) for-effect)) - (byte-compile-warn "malformed cond form: `%s'" - (prin1-to-string clause)) - clause)) - (cdr form)))) - ((eq fn 'progn) - ;; As an extra added bonus, this simplifies (progn <x>) --> <x>. - (if (cdr (cdr form)) - (macroexp-progn (byte-optimize-body (cdr form) for-effect)) - (byte-optimize-form (nth 1 form) for-effect))) - ((eq fn 'prog1) - (if (cdr (cdr form)) - (cons 'prog1 - (cons (byte-optimize-form (nth 1 form) for-effect) - (byte-optimize-body (cdr (cdr form)) t))) - (byte-optimize-form (nth 1 form) for-effect))) - - ((memq fn '(save-excursion save-restriction save-current-buffer)) - ;; those subrs which have an implicit progn; it's not quite good - ;; enough to treat these like normal function calls. - ;; This can turn (save-excursion ...) into (save-excursion) which - ;; will be optimized away in the lap-optimize pass. - (cons fn (byte-optimize-body (cdr form) for-effect))) - - ((eq fn 'with-output-to-temp-buffer) - ;; this is just like the above, except for the first argument. - (cons fn - (cons - (byte-optimize-form (nth 1 form) nil) - (byte-optimize-body (cdr (cdr form)) for-effect)))) - - ((eq fn 'if) - (when (< (length form) 3) - (byte-compile-warn "too few arguments for `if'")) - (cons fn - (cons (byte-optimize-form (nth 1 form) nil) - (cons - (byte-optimize-form (nth 2 form) for-effect) - (byte-optimize-body (nthcdr 3 form) for-effect))))) - - ((memq fn '(and or)) ; Remember, and/or are control structures. - ;; Take forms off the back until we can't any more. - ;; In the future it could conceivably be a problem that the - ;; subexpressions of these forms are optimized in the reverse - ;; order, but it's ok for now. - (if for-effect - (let ((backwards (reverse (cdr form)))) - (while (and backwards - (null (setcar backwards - (byte-optimize-form (car backwards) - for-effect)))) - (setq backwards (cdr backwards))) - (if (and (cdr form) (null backwards)) - (byte-compile-log - " all subforms of %s called for effect; deleted" form)) - (and backwards - (cons fn (nreverse (mapcar 'byte-optimize-form - backwards))))) - (cons fn (mapcar 'byte-optimize-form (cdr form))))) - - ((eq fn 'interactive) - (byte-compile-warn "misplaced interactive spec: `%s'" - (prin1-to-string form)) - nil) - - ((eq fn 'function) - ;; This forms is compiled as constant or by breaking out - ;; all the subexpressions and compiling them separately. - form) - - ((eq fn 'condition-case) - (if byte-compile--use-old-handlers - ;; Will be optimized later. - form - `(condition-case ,(nth 1 form) ;Not evaluated. - ,(byte-optimize-form (nth 2 form) for-effect) - ,@(mapcar (lambda (clause) - `(,(car clause) - ,@(byte-optimize-body (cdr clause) for-effect))) - (nthcdr 3 form))))) - - ((eq fn 'unwind-protect) - ;; the "protected" part of an unwind-protect is compiled (and thus - ;; optimized) as a top-level form, so don't do it here. But the - ;; non-protected part has the same for-effect status as the - ;; unwind-protect itself. (The protected part is always for effect, - ;; but that isn't handled properly yet.) - (cons fn - (cons (byte-optimize-form (nth 1 form) for-effect) - (cdr (cdr form))))) - - ((eq fn 'catch) - (cons fn - (cons (byte-optimize-form (nth 1 form) nil) - (if byte-compile--use-old-handlers - ;; The body of a catch is compiled (and thus - ;; optimized) as a top-level form, so don't do it - ;; here. - (cdr (cdr form)) - (byte-optimize-body (cdr form) for-effect))))) - - ((eq fn 'ignore) - ;; Don't treat the args to `ignore' as being - ;; computed for effect. We want to avoid the warnings - ;; that might occur if they were treated that way. - ;; However, don't actually bother calling `ignore'. - `(prog1 nil . ,(mapcar 'byte-optimize-form (cdr form)))) - - ;; Needed as long as we run byte-optimize-form after cconv. - ((eq fn 'internal-make-closure) form) - - ((byte-code-function-p fn) - (cons fn (mapcar #'byte-optimize-form (cdr form)))) - - ((not (symbolp fn)) - (byte-compile-warn "`%s' is a malformed function" - (prin1-to-string fn)) - form) - - ((and for-effect (setq tmp (get fn 'side-effect-free)) - (or byte-compile-delete-errors - (eq tmp 'error-free) - (progn - (byte-compile-warn "value returned from %s is unused" - (prin1-to-string form)) - nil))) - (byte-compile-log " %s called for effect; deleted" fn) - ;; appending a nil here might not be necessary, but it can't hurt. - (byte-optimize-form - (cons 'progn (append (cdr form) '(nil))) t)) + (if (symbolp binding) + binding + (if (cdr (cdr binding)) + (byte-compile-warn "malformed let binding: `%s'" + (prin1-to-string binding))) + (list (car binding) + (byte-optimize-form (nth 1 binding) nil)))) + bindings) + (byte-optimize-body exps for-effect)))) + (`(cond . ,clauses) + (cons fn + (mapcar (lambda (clause) + (if (consp clause) + (cons + (byte-optimize-form (car clause) nil) + (byte-optimize-body (cdr clause) for-effect)) + (byte-compile-warn "malformed cond form: `%s'" + (prin1-to-string clause)) + clause)) + clauses))) + (`(progn . ,exps) + ;; As an extra added bonus, this simplifies (progn <x>) --> <x>. + (if (cdr exps) + (macroexp-progn (byte-optimize-body exps for-effect)) + (byte-optimize-form (car exps) for-effect))) + (`(prog1 . ,(or `(,exp . ,exps) pcase--dontcare)) + (if exps + `(prog1 ,(byte-optimize-form exp for-effect) + . ,(byte-optimize-body exps t)) + (byte-optimize-form exp for-effect))) + + (`(,(or `save-excursion `save-restriction `save-current-buffer) . ,exps) + ;; Those subrs which have an implicit progn; it's not quite good + ;; enough to treat these like normal function calls. + ;; This can turn (save-excursion ...) into (save-excursion) which + ;; will be optimized away in the lap-optimize pass. + (cons fn (byte-optimize-body exps for-effect))) + + (`(if ,test ,then . ,else) + `(if ,(byte-optimize-form test nil) + ,(byte-optimize-form then for-effect) + . ,(byte-optimize-body else for-effect))) + (`(if . ,_) + (byte-compile-warn "too few arguments for `if'")) + + (`(,(or 'and 'or) . ,exps) ; Remember, and/or are control structures. + ;; Take forms off the back until we can't any more. + ;; In the future it could conceivably be a problem that the + ;; subexpressions of these forms are optimized in the reverse + ;; order, but it's ok for now. + (if for-effect + (let ((backwards (reverse exps))) + (while (and backwards + (null (setcar backwards + (byte-optimize-form (car backwards) + for-effect)))) + (setq backwards (cdr backwards))) + (if (and exps (null backwards)) + (byte-compile-log + " all subforms of %s called for effect; deleted" form)) + (and backwards + (cons fn (nreverse (mapcar #'byte-optimize-form + backwards))))) + (cons fn (mapcar #'byte-optimize-form exps)))) + + (`(while ,exp . ,exps) + `(while ,(byte-optimize-form exp nil) + . ,(byte-optimize-body exps t))) + (`(while . ,_) + (byte-compile-warn "too few arguments for `while'")) + + (`(interactive . ,_) + (byte-compile-warn "misplaced interactive spec: `%s'" + (prin1-to-string form)) + nil) + + (`(function . ,_) + ;; This forms is compiled as constant or by breaking out + ;; all the subexpressions and compiling them separately. + form) - (t - ;; Otherwise, no args can be considered to be for-effect, - ;; even if the called function is for-effect, because we - ;; don't know anything about that function. - (let ((args (mapcar #'byte-optimize-form (cdr form)))) - (if (and (get fn 'pure) - (byte-optimize-all-constp args)) - (list 'quote (apply fn (mapcar #'eval args))) - (cons fn args))))))) - -(defun byte-optimize-all-constp (list) - "Non-nil if all elements of LIST satisfy `macroexp-const-p'." - (let ((constant t)) - (while (and list constant) - (unless (macroexp-const-p (car list)) - (setq constant nil)) - (setq list (cdr list))) - constant)) + (`(condition-case . ,(or `(,var ,exp . ,clauses) pcase--dontcare)) + `(condition-case ,var ;Not evaluated. + ,(byte-optimize-form exp for-effect) + ,@(mapcar (lambda (clause) + `(,(car clause) + ,@(byte-optimize-body (cdr clause) for-effect))) + clauses))) + + (`(unwind-protect . ,(or `(,exp . ,exps) pcase--dontcare)) + ;; The "protected" part of an unwind-protect is compiled (and thus + ;; optimized) as a top-level form, so don't do it here. But the + ;; non-protected part has the same for-effect status as the + ;; unwind-protect itself. (The protected part is always for effect, + ;; but that isn't handled properly yet.) + `(unwind-protect ,(byte-optimize-form exp for-effect) . ,exps)) + + (`(catch . ,(or `(,tag . ,exps) pcase--dontcare)) + `(catch ,(byte-optimize-form tag nil) + . ,(byte-optimize-body exps for-effect))) + + (`(ignore . ,exps) + ;; Don't treat the args to `ignore' as being + ;; computed for effect. We want to avoid the warnings + ;; that might occur if they were treated that way. + ;; However, don't actually bother calling `ignore'. + `(prog1 nil . ,(mapcar #'byte-optimize-form exps))) + + ;; Needed as long as we run byte-optimize-form after cconv. + (`(internal-make-closure . ,_) form) + + (`((lambda . ,_) . ,_) + (let ((newform (byte-compile-unfold-lambda form))) + (if (eq newform form) + ;; Some error occurred, avoid infinite recursion. + form + (byte-optimize-form newform for-effect)))) + + ;; FIXME: Strictly speaking, I think this is a bug: (closure...) + ;; is a *value* and shouldn't appear in the car. + (`((closure . ,_) . ,_) form) + + (`(,(pred byte-code-function-p) . ,exps) + (cons fn (mapcar #'byte-optimize-form exps))) + + (`(,(pred (not symbolp)) . ,_) + (byte-compile-warn "`%s' is a malformed function" + (prin1-to-string fn)) + form) + + ((guard (when for-effect + (if-let ((tmp (get fn 'side-effect-free))) + (or byte-compile-delete-errors + (eq tmp 'error-free) + (progn + (byte-compile-warn "value returned from %s is unused" + (prin1-to-string form)) + nil))))) + (byte-compile-log " %s called for effect; deleted" fn) + ;; appending a nil here might not be necessary, but it can't hurt. + (byte-optimize-form + (cons 'progn (append (cdr form) '(nil))) t)) + + (_ + ;; Otherwise, no args can be considered to be for-effect, + ;; even if the called function is for-effect, because we + ;; don't know anything about that function. + (let ((form (cons fn (mapcar #'byte-optimize-form (cdr form))))) + (if (get fn 'pure) + (byte-optimize-constant-args form) + form)))))) (defun byte-optimize-form (form &optional for-effect) "The source-level pass of the optimizer." @@ -664,45 +649,36 @@ (setq args (cons (car rest) args))) (setq rest (cdr rest))) (if (cdr constants) - (if args - (list (car form) - (apply (car form) constants) - (if (cdr args) - (cons (car form) (nreverse args)) - (car args))) - (apply (car form) constants)) - form))) + (let ((const (apply (car form) (nreverse constants)))) + (if args + (append (list (car form) const) + (nreverse args)) + const)) + form))) -;; Portable Emacs integers fall in this range. -(defconst byte-opt--portable-max #x1fffffff) -(defconst byte-opt--portable-min (- -1 byte-opt--portable-max)) - -;; True if N is a number that works the same on all Emacs platforms. -;; Portable Emacs fixnums are exactly representable as floats on all -;; Emacs platforms, and (except for -0.0) any floating-point number -;; that equals one of these integers must be the same on all -;; platforms. Although other floating-point numbers such as 0.5 are -;; also portable, it can be tricky to characterize them portably so -;; they are not optimized. -(defun byte-opt--portable-numberp (n) - (and (numberp n) - (<= byte-opt--portable-min n byte-opt--portable-max) - (= n (floor n)) - (not (and (floatp n) (zerop n) - (condition-case () (< (/ n) 0) (error)))))) - -;; Use OP to reduce any leading prefix of portable numbers in the list -;; (cons ACCUM ARGS) down to a single portable number, and return the +(defun byte-optimize-min-max (form) + "Optimize `min' and `max'." + (let ((opt (byte-optimize-associative-math form))) + (if (and (consp opt) (memq (car opt) '(min max)) + (= (length opt) 4)) + ;; (OP x y z) -> (OP (OP x y) z), in order to use binary byte ops. + (list (car opt) + (list (car opt) (nth 1 opt) (nth 2 opt)) + (nth 3 opt)) + opt))) + +;; Use OP to reduce any leading prefix of constant numbers in the list +;; (cons ACCUM ARGS) down to a single number, and return the ;; resulting list A of arguments. The idea is that applying OP to A ;; is equivalent to (but likely more efficient than) applying OP to ;; (cons ACCUM ARGS), on any Emacs platform. Do not make any special ;; provision for (- X) or (/ X); for example, it is the caller’s ;; responsibility that (- 1 0) should not be "optimized" to (- 1). (defun byte-opt--arith-reduce (op accum args) - (when (byte-opt--portable-numberp accum) + (when (numberp accum) (let (accum1) - (while (and (byte-opt--portable-numberp (car args)) - (byte-opt--portable-numberp + (while (and (numberp (car args)) + (numberp (setq accum1 (condition-case () (funcall op accum (car args)) (error)))) @@ -725,6 +701,9 @@ (integer (if integer-is-first arg1 arg2)) (other (if integer-is-first arg2 arg1))) (list (if (eq integer 1) '1+ '1-) other))) + ;; (+ x y z) -> (+ (+ x y) z) + ((= (length args) 3) + `(+ ,(byte-optimize-plus `(+ ,(car args) ,(cadr args))) ,@(cddr args))) ;; not further optimized ((equal args (cdr form)) form) (t (cons '+ args))))) @@ -747,35 +726,19 @@ ;; (- x -1) --> (1+ x) ((equal (cdr args) '(-1)) (list '1+ (car args))) - ;; (- n) -> -n, where n and -n are portable numbers. + ;; (- n) -> -n, where n and -n are constant numbers. ;; This must be done separately since byte-opt--arith-reduce ;; is not applied to (- n). ((and (null (cdr args)) - (byte-opt--portable-numberp (car args)) - (byte-opt--portable-numberp (- (car args)))) + (numberp (car args))) (- (car args))) + ;; (- x y z) -> (- (- x y) z) + ((= (length args) 3) + `(- ,(byte-optimize-minus `(- ,(car args) ,(cadr args))) ,@(cddr args))) ;; not further optimized ((equal args (cdr form)) form) (t (cons '- args)))))) -(defun byte-optimize-1+ (form) - (let ((args (cdr form))) - (when (null (cdr args)) - (let ((n (car args))) - (when (and (byte-opt--portable-numberp n) - (byte-opt--portable-numberp (1+ n))) - (setq form (1+ n)))))) - form) - -(defun byte-optimize-1- (form) - (let ((args (cdr form))) - (when (null (cdr args)) - (let ((n (car args))) - (when (and (byte-opt--portable-numberp n) - (byte-opt--portable-numberp (1- n))) - (setq form (1- n)))))) - form) - (defun byte-optimize-multiply (form) (let* ((args (remq 1 (byte-opt--arith-reduce #'* 1 (cdr form))))) (cond @@ -783,6 +746,10 @@ ((null args) 1) ;; (* n) -> n, where n is a number ((and (null (cdr args)) (numberp (car args))) (car args)) + ;; (* x y z) -> (* (* x y) z) + ((= (length args) 3) + `(* ,(byte-optimize-multiply `(* ,(car args) ,(cadr args))) + ,@(cddr args))) ;; not further optimized ((equal args (cdr form)) form) (t (cons '* args))))) @@ -811,10 +778,10 @@ (condition-case () (list 'quote (eval form)) (error form))) - (t ;; This can enable some lapcode optimizations. + (t ;; Moving the constant to the end can enable some lapcode optimizations. (list (car form) (nth 2 form) (nth 1 form))))) -(defun byte-optimize-predicate (form) +(defun byte-optimize-constant-args (form) (let ((ok t) (rest (cdr form))) (while (and rest ok) @@ -829,9 +796,6 @@ (defun byte-optimize-identity (form) (if (and (cdr form) (null (cdr (cdr form)))) (nth 1 form) - (byte-compile-warn "identity called with %d arg%s, but requires 1" - (length (cdr form)) - (if (= 1 (length (cdr form))) "" "s")) form)) (defun byte-optimize--constant-symbol-p (expr) @@ -864,21 +828,29 @@ ;; Arity errors reported elsewhere. form)) +(defun byte-optimize-assoc (form) + ;; Replace 2-argument `assoc' with `assq', `rassoc' with `rassq', + ;; if the first arg is a symbol. + (cond + ((/= (length form) 3) + form) + ((byte-optimize--constant-symbol-p (nth 1 form)) + (cons (if (eq (car form) 'assoc) 'assq 'rassq) + (cdr form))) + (t (byte-optimize-constant-args form)))) + (defun byte-optimize-memq (form) ;; (memq foo '(bar)) => (and (eq foo 'bar) '(bar)) - (if (/= (length (cdr form)) 2) - (byte-compile-warn "memq called with %d arg%s, but requires 2" - (length (cdr form)) - (if (= 1 (length (cdr form))) "" "s")) - (let ((list (nth 2 form))) - (when (and (eq (car-safe list) 'quote) + (if (= (length (cdr form)) 2) + (let ((list (nth 2 form))) + (if (and (eq (car-safe list) 'quote) (listp (setq list (cadr list))) (= (length list) 1)) - (setq form (byte-optimize-and - `(and ,(byte-optimize-predicate - `(eq ,(nth 1 form) ',(nth 0 list))) - ',list))))) - (byte-optimize-predicate form))) + `(and (eq ,(nth 1 form) ',(nth 0 list)) + ',list) + form)) + ;; Arity errors reported elsewhere. + form)) (defun byte-optimize-concat (form) "Merge adjacent constant arguments to `concat'." @@ -907,58 +879,34 @@ form ; No improvement. (cons 'concat (nreverse newargs))))) -(put 'identity 'byte-optimizer 'byte-optimize-identity) -(put 'memq 'byte-optimizer 'byte-optimize-memq) -(put 'memql 'byte-optimizer 'byte-optimize-member) -(put 'member 'byte-optimizer 'byte-optimize-member) - -(put '+ 'byte-optimizer 'byte-optimize-plus) -(put '* 'byte-optimizer 'byte-optimize-multiply) -(put '- 'byte-optimizer 'byte-optimize-minus) -(put '/ 'byte-optimizer 'byte-optimize-divide) -(put 'max 'byte-optimizer 'byte-optimize-associative-math) -(put 'min 'byte-optimizer 'byte-optimize-associative-math) - -(put '= 'byte-optimizer 'byte-optimize-binary-predicate) -(put 'eq 'byte-optimizer 'byte-optimize-binary-predicate) -(put 'eql 'byte-optimizer 'byte-optimize-equal) -(put 'equal 'byte-optimizer 'byte-optimize-equal) -(put 'string= 'byte-optimizer 'byte-optimize-binary-predicate) -(put 'string-equal 'byte-optimizer 'byte-optimize-binary-predicate) - -(put '< 'byte-optimizer 'byte-optimize-predicate) -(put '> 'byte-optimizer 'byte-optimize-predicate) -(put '<= 'byte-optimizer 'byte-optimize-predicate) -(put '>= 'byte-optimizer 'byte-optimize-predicate) -(put '1+ 'byte-optimizer 'byte-optimize-1+) -(put '1- 'byte-optimizer 'byte-optimize-1-) -(put 'not 'byte-optimizer 'byte-optimize-predicate) -(put 'null 'byte-optimizer 'byte-optimize-predicate) -(put 'consp 'byte-optimizer 'byte-optimize-predicate) -(put 'listp 'byte-optimizer 'byte-optimize-predicate) -(put 'symbolp 'byte-optimizer 'byte-optimize-predicate) -(put 'stringp 'byte-optimizer 'byte-optimize-predicate) -(put 'string< 'byte-optimizer 'byte-optimize-predicate) -(put 'string-lessp 'byte-optimizer 'byte-optimize-predicate) -(put 'proper-list-p 'byte-optimizer 'byte-optimize-predicate) - -(put 'logand 'byte-optimizer 'byte-optimize-predicate) -(put 'logior 'byte-optimizer 'byte-optimize-predicate) -(put 'logxor 'byte-optimizer 'byte-optimize-predicate) -(put 'lognot 'byte-optimizer 'byte-optimize-predicate) - -(put 'car 'byte-optimizer 'byte-optimize-predicate) -(put 'cdr 'byte-optimizer 'byte-optimize-predicate) -(put 'car-safe 'byte-optimizer 'byte-optimize-predicate) -(put 'cdr-safe 'byte-optimizer 'byte-optimize-predicate) - -(put 'concat 'byte-optimizer 'byte-optimize-concat) +(put 'identity 'byte-optimizer #'byte-optimize-identity) +(put 'memq 'byte-optimizer #'byte-optimize-memq) +(put 'memql 'byte-optimizer #'byte-optimize-member) +(put 'member 'byte-optimizer #'byte-optimize-member) +(put 'assoc 'byte-optimizer #'byte-optimize-assoc) +(put 'rassoc 'byte-optimizer #'byte-optimize-assoc) + +(put '+ 'byte-optimizer #'byte-optimize-plus) +(put '* 'byte-optimizer #'byte-optimize-multiply) +(put '- 'byte-optimizer #'byte-optimize-minus) +(put '/ 'byte-optimizer #'byte-optimize-divide) +(put 'max 'byte-optimizer #'byte-optimize-min-max) +(put 'min 'byte-optimizer #'byte-optimize-min-max) + +(put '= 'byte-optimizer #'byte-optimize-binary-predicate) +(put 'eq 'byte-optimizer #'byte-optimize-binary-predicate) +(put 'eql 'byte-optimizer #'byte-optimize-equal) +(put 'equal 'byte-optimizer #'byte-optimize-equal) +(put 'string= 'byte-optimizer #'byte-optimize-binary-predicate) +(put 'string-equal 'byte-optimizer #'byte-optimize-binary-predicate) + +(put 'concat 'byte-optimizer #'byte-optimize-concat) ;; I'm not convinced that this is necessary. Doesn't the optimizer loop ;; take care of this? - Jamie ;; I think this may some times be necessary to reduce ie (quote 5) to 5, ;; so arithmetic optimizers recognize the numeric constant. - Hallvard -(put 'quote 'byte-optimizer 'byte-optimize-quote) +(put 'quote 'byte-optimizer #'byte-optimize-quote) (defun byte-optimize-quote (form) (if (or (consp (nth 1 form)) (and (symbolp (nth 1 form)) @@ -981,7 +929,7 @@ nil)) ((null (cdr (cdr form))) (nth 1 form)) - ((byte-optimize-predicate form)))) + ((byte-optimize-constant-args form)))) (defun byte-optimize-or (form) ;; Throw away nil's, and simplify if less than 2 args. @@ -994,7 +942,7 @@ (setq form (copy-sequence form) rest (setcdr (memq (car rest) form) nil)))) (if (cdr (cdr form)) - (byte-optimize-predicate form) + (byte-optimize-constant-args form) (nth 1 form)))) (defun byte-optimize-cond (form) @@ -1076,16 +1024,16 @@ (if (nth 1 form) 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 '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) ;; byte-compile-negation-optimizer lives in bytecomp.el -(put '/= 'byte-optimizer 'byte-compile-negation-optimizer) -(put 'atom 'byte-optimizer 'byte-compile-negation-optimizer) -(put 'nlistp 'byte-optimizer 'byte-compile-negation-optimizer) +(put '/= 'byte-optimizer #'byte-compile-negation-optimizer) +(put 'atom 'byte-optimizer #'byte-compile-negation-optimizer) +(put 'nlistp 'byte-optimizer #'byte-compile-negation-optimizer) (defun byte-optimize-funcall (form) @@ -1099,26 +1047,29 @@ (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 ...). - (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)))) - (byte-compile-warn - "last arg to apply can't be a literal atom: `%s'" - (prin1-to-string last)) - nil)) - form))) - -(put 'funcall 'byte-optimizer 'byte-optimize-funcall) -(put 'apply 'byte-optimizer 'byte-optimize-apply) - - -(put 'let 'byte-optimizer 'byte-optimize-letX) -(put 'let* 'byte-optimizer 'byte-optimize-letX) + (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)))) + (byte-compile-warn + "last arg to apply can't be a literal atom: `%s'" + (prin1-to-string last)) + nil)) + form)))) + +(put 'funcall 'byte-optimizer #'byte-optimize-funcall) +(put 'apply 'byte-optimizer #'byte-optimize-apply) + + +(put 'let 'byte-optimizer #'byte-optimize-letX) +(put 'let* 'byte-optimizer #'byte-optimize-letX) (defun byte-optimize-letX (form) (cond ((null (nth 1 form)) ;; No bindings @@ -1134,17 +1085,17 @@ (list 'let* (reverse (cdr binds)) (nth 1 (car binds)) nil))))) -(put 'nth 'byte-optimizer 'byte-optimize-nth) +(put 'nth 'byte-optimizer #'byte-optimize-nth) (defun byte-optimize-nth (form) (if (= (safe-length form) 3) (if (memq (nth 1 form) '(0 1)) (list 'car (if (zerop (nth 1 form)) (nth 2 form) (list 'cdr (nth 2 form)))) - (byte-optimize-predicate form)) + form) form)) -(put 'nthcdr 'byte-optimizer 'byte-optimize-nthcdr) +(put 'nthcdr 'byte-optimizer #'byte-optimize-nthcdr) (defun byte-optimize-nthcdr (form) (if (= (safe-length form) 3) (if (memq (nth 1 form) '(0 1 2)) @@ -1153,14 +1104,14 @@ (while (>= (setq count (1- count)) 0) (setq form (list 'cdr form))) form) - (byte-optimize-predicate form)) + form) 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) +(put 'set 'byte-optimizer #'byte-optimize-set) (defun byte-optimize-set (form) (let ((var (car-safe (cdr-safe form)))) (cond @@ -1196,13 +1147,15 @@ ;; I wonder if I missed any :-\) (let ((side-effect-free-fns '(% * + - / /= 1+ 1- < <= = > >= abs acos append aref ash asin atan - assoc assq + assq + bool-vector-count-consecutive bool-vector-count-population + bool-vector-subsetp boundp buffer-file-name buffer-local-variables buffer-modified-p buffer-substring byte-code-function-p capitalize car-less-than-car car cdr ceiling char-after char-before char-equal char-to-string char-width compare-strings compare-window-configurations concat coordinates-in-window-p - copy-alist copy-sequence copy-marker cos count-lines + copy-alist copy-sequence copy-marker copysign cos count-lines current-time-string current-time-zone decode-char decode-time default-boundp default-value documentation downcase @@ -1215,21 +1168,24 @@ frame-visible-p fround ftruncate get gethash get-buffer get-buffer-window getenv get-file-buffer hash-table-count - int-to-string intern-soft + int-to-string intern-soft isnan keymap-parent - length line-beginning-position line-end-position + lax-plist-get ldexp + length length< length> length= + line-beginning-position line-end-position local-variable-if-set-p local-variable-p locale-info log log10 logand logb logcount logior lognot logxor lsh - make-list make-string make-symbol marker-buffer max member memq min - minibuffer-selected-window minibuffer-window + make-byte-code make-list make-string make-symbol marker-buffer max + 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 prefix-numeric-value previous-window prin1-to-string propertize degrees-to-radians - radians-to-degrees rassq rassoc read-from-string regexp-quote - region-beginning region-end reverse round - sin sqrt string string< string= string-equal string-lessp string-to-char - string-to-number substring + 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-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 @@ -1279,7 +1235,7 @@ standard-case-table standard-syntax-table stringp subrp symbolp syntax-table syntax-table-p this-command-keys this-command-keys-vector this-single-command-keys - this-single-command-raw-keys + this-single-command-raw-keys type-of user-real-login-name user-real-uid user-uid vector vectorp visible-frame-list wholenump window-configuration-p window-live-p @@ -1296,9 +1252,9 @@ ;; Pure functions are side-effect free functions whose values depend ;; only on their arguments, not on the platform. For these functions, ;; calls with constant arguments can be evaluated at compile time. -;; This may shift runtime errors to compile time. For example, logand -;; is pure since its results are machine-independent, whereas ash is -;; not pure because (ash 1 29)'s value depends on machine word size. +;; For example, ash is pure since its results are machine-independent, +;; whereas lsh is not pure because (lsh -1 -1)'s value depends on the +;; fixnum range. ;; ;; When deciding whether a function is pure, do not worry about ;; mutable strings or markers, as they are so unlikely in real code @@ -1308,9 +1264,42 @@ ;; values if a marker is moved. (let ((pure-fns - '(% concat logand logcount logior lognot logxor - regexp-opt regexp-quote - string-to-char string-to-syntax symbol-name))) + '(concat regexp-opt regexp-quote + string-to-char string-to-syntax symbol-name + eq eql + = /= < <= >= > min max + + - * / % mod abs ash 1+ 1- sqrt + logand logior lognot logxor logcount + copysign isnan ldexp float logb + floor ceiling round truncate + ffloor fceiling fround ftruncate + string= string-equal string< string-lessp + string-search + consp atom listp nlistp proper-list-p + sequencep arrayp vectorp stringp bool-vector-p hash-table-p + null not + numberp integerp floatp natnump characterp + integer-or-marker-p number-or-marker-p char-or-string-p + symbolp keywordp + type-of + identity ignore + + ;; The following functions are pure up to mutation of their + ;; 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 + 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 + aref elt + bool-vector-subsetp + bool-vector-count-population bool-vector-count-consecutive + ))) (while pure-fns (put (car pure-fns) 'pure t) (setq pure-fns (cdr pure-fns))) @@ -1473,10 +1462,10 @@ (setq rest (cdr rest)))) (if tags (error "optimizer error: missed tags %s" tags)) ;; Remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* ) - (mapcar (function (lambda (elt) - (if (numberp elt) - elt - (cdr elt)))) + (mapcar (lambda (elt) + (if (numberp elt) + elt + (cdr elt))) (nreverse lap)))) @@ -1510,13 +1499,13 @@ byte-current-buffer byte-stack-ref)) (defconst byte-compile-side-effect-free-ops - (nconc + (append '(byte-varref byte-nth byte-memq byte-car byte-cdr byte-length byte-aref byte-symbol-value byte-get byte-concat2 byte-concat3 byte-sub1 byte-add1 byte-eqlsign byte-gtr byte-lss byte-leq byte-geq byte-diff byte-negate byte-plus byte-max byte-min byte-mult byte-char-after byte-char-syntax byte-buffer-substring byte-string= byte-string< byte-nthcdr byte-elt - byte-member byte-assq byte-quo byte-rem) + byte-member byte-assq byte-quo byte-rem byte-substring) byte-compile-side-effect-and-error-free-ops)) ;; This crock is because of the way DEFVAR_BOOL variables work. @@ -1574,467 +1563,548 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; You may notice that sequences like "dup varset discard" are ;; optimized but sequences like "dup varset TAG1: discard" are not. ;; You may be tempted to change this; resist that temptation. - (cond ;; - ;; <side-effect-free> pop --> <deleted> - ;; ...including: - ;; const-X pop --> <deleted> - ;; varref-X pop --> <deleted> - ;; dup pop --> <deleted> - ;; - ((and (eq 'byte-discard (car lap1)) - (memq (car lap0) side-effect-free)) - (setq keep-going t) - (setq tmp (aref byte-stack+-info (symbol-value (car lap0)))) - (setq rest (cdr rest)) - (cond ((= tmp 1) - (byte-compile-log-lap - " %s discard\t-->\t<deleted>" lap0) - (setq lap (delq lap0 (delq lap1 lap)))) - ((= tmp 0) - (byte-compile-log-lap - " %s discard\t-->\t<deleted> discard" lap0) - (setq lap (delq lap0 lap))) - ((= tmp -1) - (byte-compile-log-lap - " %s discard\t-->\tdiscard discard" lap0) - (setcar lap0 'byte-discard) - (setcdr lap0 0)) - ((error "Optimizer error: too much on the stack")))) - ;; - ;; goto*-X X: --> X: - ;; - ((and (memq (car lap0) byte-goto-ops) - (eq (cdr lap0) lap1)) - (cond ((eq (car lap0) 'byte-goto) - (setq lap (delq lap0 lap)) - (setq tmp "<deleted>")) - ((memq (car lap0) byte-goto-always-pop-ops) - (setcar lap0 (setq tmp 'byte-discard)) - (setcdr lap0 0)) - ((error "Depth conflict at tag %d" (nth 2 lap0)))) - (and (memq byte-optimize-log '(t byte)) - (byte-compile-log " (goto %s) %s:\t-->\t%s %s:" - (nth 1 lap1) (nth 1 lap1) - tmp (nth 1 lap1))) - (setq keep-going t)) - ;; - ;; varset-X varref-X --> dup varset-X - ;; varbind-X varref-X --> dup varbind-X - ;; const/dup varset-X varref-X --> const/dup varset-X const/dup - ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup - ;; The latter two can enable other optimizations. - ;; - ;; For lexical variables, we could do the same - ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2 - ;; but this is a very minor gain, since dup is stack-ref-0, - ;; i.e. it's only better if X>5, and even then it comes - ;; at the cost of an extra stack slot. Let's not bother. - ((and (eq 'byte-varref (car lap2)) - (eq (cdr lap1) (cdr lap2)) - (memq (car lap1) '(byte-varset byte-varbind))) - (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) - (not (eq (car lap0) 'byte-constant))) - nil - (setq keep-going t) - (if (memq (car lap0) '(byte-constant byte-dup)) - (progn - (setq tmp (if (or (not tmp) - (macroexp--const-symbol-p - (car (cdr lap0)))) - (cdr lap0) - (byte-compile-get-constant t))) - (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s" - lap0 lap1 lap2 lap0 lap1 - (cons (car lap0) tmp)) - (setcar lap2 (car lap0)) - (setcdr lap2 tmp)) - (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1) - (setcar lap2 (car lap1)) - (setcar lap1 'byte-dup) - (setcdr lap1 0) - ;; The stack depth gets locally increased, so we will - ;; increase maxdepth in case depth = maxdepth here. - ;; This can cause the third argument to byte-code to - ;; be larger than necessary. - (setq add-depth 1)))) - ;; - ;; dup varset-X discard --> varset-X - ;; dup varbind-X discard --> varbind-X - ;; dup stack-set-X discard --> stack-set-X-1 - ;; (the varbind variant can emerge from other optimizations) - ;; - ((and (eq 'byte-dup (car lap0)) - (eq 'byte-discard (car lap2)) - (memq (car lap1) '(byte-varset byte-varbind - byte-stack-set))) - (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) - (setq keep-going t - rest (cdr rest)) - (if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1))) - (setq lap (delq lap0 (delq lap2 lap)))) - ;; - ;; not goto-X-if-nil --> goto-X-if-non-nil - ;; not goto-X-if-non-nil --> goto-X-if-nil - ;; - ;; it is wrong to do the same thing for the -else-pop variants. - ;; - ((and (eq 'byte-not (car lap0)) - (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil))) - (byte-compile-log-lap " not %s\t-->\t%s" - lap1 - (cons - (if (eq (car lap1) 'byte-goto-if-nil) - 'byte-goto-if-not-nil - 'byte-goto-if-nil) - (cdr lap1))) - (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil) - 'byte-goto-if-not-nil - 'byte-goto-if-nil)) - (setq lap (delq lap0 lap)) - (setq keep-going t)) - ;; - ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X: - ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X: - ;; - ;; it is wrong to do the same thing for the -else-pop variants. - ;; - ((and (memq (car lap0) - '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX - (eq 'byte-goto (car lap1)) ; gotoY - (eq (cdr lap0) lap2)) ; TAG X - (let ((inverse (if (eq 'byte-goto-if-nil (car lap0)) - 'byte-goto-if-not-nil 'byte-goto-if-nil))) - (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:" - lap0 lap1 lap2 - (cons inverse (cdr lap1)) lap2) - (setq lap (delq lap0 lap)) - (setcar lap1 inverse) - (setq keep-going t))) - ;; - ;; const goto-if-* --> whatever - ;; - ((and (eq 'byte-constant (car lap0)) - (memq (car lap1) byte-conditional-ops) - ;; If the `byte-constant's cdr is not a cons cell, it has - ;; to be an index into the constant pool); even though - ;; it'll be a constant, that constant is not known yet - ;; (it's typically a free variable of a closure, so will - ;; only be known when the closure will be built at - ;; run-time). - (consp (cdr lap0))) - (cond ((if (memq (car lap1) '(byte-goto-if-nil - byte-goto-if-nil-else-pop)) - (car (cdr lap0)) - (not (car (cdr lap0)))) - (byte-compile-log-lap " %s %s\t-->\t<deleted>" - lap0 lap1) - (setq rest (cdr rest) - lap (delq lap0 (delq lap1 lap)))) - (t - (byte-compile-log-lap " %s %s\t-->\t%s" - lap0 lap1 - (cons 'byte-goto (cdr lap1))) - (when (memq (car lap1) byte-goto-always-pop-ops) - (setq lap (delq lap0 lap))) - (setcar lap1 'byte-goto))) - (setq keep-going t)) - ;; - ;; varref-X varref-X --> varref-X dup - ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup - ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup - ;; We don't optimize the const-X variations on this here, - ;; because that would inhibit some goto optimizations; we - ;; optimize the const-X case after all other optimizations. - ;; - ((and (memq (car lap0) '(byte-varref byte-stack-ref)) - (progn - (setq tmp (cdr rest)) - (setq tmp2 0) - (while (eq (car (car tmp)) 'byte-dup) - (setq tmp2 (1+ tmp2)) - (setq tmp (cdr tmp))) - t) - (eq (if (eq 'byte-stack-ref (car lap0)) - (+ tmp2 1 (cdr lap0)) - (cdr lap0)) - (cdr (car tmp))) - (eq (car lap0) (car (car tmp)))) - (if (memq byte-optimize-log '(t byte)) - (let ((str "")) - (setq tmp2 (cdr rest)) - (while (not (eq tmp tmp2)) - (setq tmp2 (cdr tmp2) - str (concat str " dup"))) - (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup" - lap0 str lap0 lap0 str))) - (setq keep-going t) - (setcar (car tmp) 'byte-dup) - (setcdr (car tmp) 0) - (setq rest tmp)) - ;; - ;; TAG1: TAG2: --> TAG1: <deleted> - ;; (and other references to TAG2 are replaced with TAG1) - ;; - ((and (eq (car lap0) 'TAG) - (eq (car lap1) 'TAG)) - (and (memq byte-optimize-log '(t byte)) - (byte-compile-log " adjacent tags %d and %d merged" - (nth 1 lap1) (nth 1 lap0))) - (setq tmp3 lap) - (while (setq tmp2 (rassq lap0 tmp3)) - (setcdr tmp2 lap1) - (setq tmp3 (cdr (memq tmp2 tmp3)))) - (setq lap (delq lap0 lap) - keep-going t) - ;; replace references to tag in jump tables, if any - (dolist (table byte-compile-jump-tables) - (maphash #'(lambda (value tag) - (when (equal tag lap0) - (puthash value lap1 table))) - table))) - ;; - ;; unused-TAG: --> <deleted> - ;; - ((and (eq 'TAG (car lap0)) - (not (rassq lap0 lap)) - ;; make sure this tag isn't used in a jump-table - (cl-loop for table in byte-compile-jump-tables - when (member lap0 (hash-table-values table)) - return nil finally return t)) - (and (memq byte-optimize-log '(t byte)) - (byte-compile-log " unused tag %d removed" (nth 1 lap0))) - (setq lap (delq lap0 lap) - keep-going t)) - ;; - ;; goto ... --> goto <delete until TAG or end> - ;; return ... --> return <delete until TAG or end> - ;; (unless a jump-table is being used, where deleting may affect - ;; other valid case bodies) - ;; - ((and (memq (car lap0) '(byte-goto byte-return)) - (not (memq (car lap1) '(TAG nil))) - ;; FIXME: Instead of deferring simply when jump-tables are - ;; being used, keep a list of tags used for switch tags and - ;; use them instead (see `byte-compile-inline-lapcode'). - (not byte-compile-jump-tables)) - (setq tmp rest) - (let ((i 0) - (opt-p (memq byte-optimize-log '(t lap))) - str deleted) - (while (and (setq tmp (cdr tmp)) - (not (eq 'TAG (car (car tmp))))) - (if opt-p (setq deleted (cons (car tmp) deleted) - str (concat str " %s") - i (1+ i)))) - (if opt-p - (let ((tagstr - (if (eq 'TAG (car (car tmp))) - (format "%d:" (car (cdr (car tmp)))) - (or (car tmp) "")))) - (if (< i 6) - (apply 'byte-compile-log-lap-1 - (concat " %s" str - " %s\t-->\t%s <deleted> %s") - lap0 - (nconc (nreverse deleted) - (list tagstr lap0 tagstr))) - (byte-compile-log-lap - " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s" - lap0 i (if (= i 1) "" "s") - tagstr lap0 tagstr)))) - (rplacd rest tmp)) - (setq keep-going t)) - ;; - ;; <safe-op> unbind --> unbind <safe-op> - ;; (this may enable other optimizations.) - ;; - ((and (eq 'byte-unbind (car lap1)) - (memq (car lap0) byte-after-unbind-ops)) - (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0) - (setcar rest lap1) - (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) - ;; - ((and (eq 'byte-unbind (car lap1)) - (memq (car lap0) '(byte-varbind byte-save-excursion - byte-save-restriction)) - (< 0 (cdr lap1))) - (if (zerop (setcdr lap1 (1- (cdr lap1)))) - (delq lap1 rest)) - (if (eq (car lap0) 'byte-varbind) - (setcar rest (cons 'byte-discard 0)) + (cond + ;; <side-effect-free> pop --> <deleted> + ;; ...including: + ;; const-X pop --> <deleted> + ;; varref-X pop --> <deleted> + ;; dup pop --> <deleted> + ;; + ((and (eq 'byte-discard (car lap1)) + (memq (car lap0) side-effect-free)) + (setq keep-going t) + (setq tmp (aref byte-stack+-info (symbol-value (car lap0)))) + (setq rest (cdr rest)) + (cond ((= tmp 1) + (byte-compile-log-lap + " %s discard\t-->\t<deleted>" lap0) + (setq lap (delq lap0 (delq lap1 lap)))) + ((= tmp 0) + (byte-compile-log-lap + " %s discard\t-->\t<deleted> discard" lap0) (setq lap (delq lap0 lap))) - (byte-compile-log-lap " %s %s\t-->\t%s %s" - lap0 (cons (car lap1) (1+ (cdr lap1))) - (if (eq (car lap0) 'byte-varbind) - (car rest) - (car (cdr rest))) - (if (and (/= 0 (cdr lap1)) - (eq (car lap0) 'byte-varbind)) - (car (cdr rest)) - "")) - (setq keep-going t)) - ;; - ;; goto*-X ... X: goto-Y --> goto*-Y - ;; goto-X ... X: return --> return - ;; - ((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))) - (byte-compile-log-lap " %s [%s]\t-->\t%s" - (car lap0) tmp tmp) - (if (eq (car tmp) 'byte-return) - (setcar lap0 'byte-return)) - (setcdr lap0 (cdr tmp)) - (setq keep-going t)))) - ;; - ;; goto-*-else-pop X ... X: goto-if-* --> whatever - ;; goto-*-else-pop X ... X: discard --> whatever - ;; - ((and (memq (car lap0) '(byte-goto-if-nil-else-pop - byte-goto-if-not-nil-else-pop)) - (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap))))) - (eval-when-compile - (cons 'byte-discard byte-conditional-ops))) - (not (eq lap0 (car tmp)))) - (setq tmp2 (car tmp)) - (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop - byte-goto-if-nil) - (byte-goto-if-not-nil-else-pop - byte-goto-if-not-nil)))) - (if (memq (car tmp2) tmp3) - (progn (setcar lap0 (car tmp2)) - (setcdr lap0 (cdr tmp2)) - (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s" - (car lap0) tmp2 lap0)) - ;; Get rid of the -else-pop's and jump one step further. + ((= tmp -1) + (byte-compile-log-lap + " %s discard\t-->\tdiscard discard" lap0) + (setcar lap0 'byte-discard) + (setcdr lap0 0)) + ((error "Optimizer error: too much on the stack")))) + ;; + ;; goto*-X X: --> X: + ;; + ((and (memq (car lap0) byte-goto-ops) + (eq (cdr lap0) lap1)) + (cond ((eq (car lap0) 'byte-goto) + (setq lap (delq lap0 lap)) + (setq tmp "<deleted>")) + ((memq (car lap0) byte-goto-always-pop-ops) + (setcar lap0 (setq tmp 'byte-discard)) + (setcdr lap0 0)) + ((error "Depth conflict at tag %d" (nth 2 lap0)))) + (and (memq byte-optimize-log '(t byte)) + (byte-compile-log " (goto %s) %s:\t-->\t%s %s:" + (nth 1 lap1) (nth 1 lap1) + tmp (nth 1 lap1))) + (setq keep-going t)) + ;; + ;; varset-X varref-X --> dup varset-X + ;; varbind-X varref-X --> dup varbind-X + ;; const/dup varset-X varref-X --> const/dup varset-X const/dup + ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup + ;; The latter two can enable other optimizations. + ;; + ;; For lexical variables, we could do the same + ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2 + ;; but this is a very minor gain, since dup is stack-ref-0, + ;; i.e. it's only better if X>5, and even then it comes + ;; at the cost of an extra stack slot. Let's not bother. + ((and (eq 'byte-varref (car lap2)) + (eq (cdr lap1) (cdr lap2)) + (memq (car lap1) '(byte-varset byte-varbind))) + (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) + (not (eq (car lap0) 'byte-constant))) + nil + (setq keep-going t) + (if (memq (car lap0) '(byte-constant byte-dup)) + (progn + (setq tmp (if (or (not tmp) + (macroexp--const-symbol-p + (car (cdr lap0)))) + (cdr lap0) + (byte-compile-get-constant t))) + (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s" + lap0 lap1 lap2 lap0 lap1 + (cons (car lap0) tmp)) + (setcar lap2 (car lap0)) + (setcdr lap2 tmp)) + (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1) + (setcar lap2 (car lap1)) + (setcar lap1 'byte-dup) + (setcdr lap1 0) + ;; The stack depth gets locally increased, so we will + ;; increase maxdepth in case depth = maxdepth here. + ;; This can cause the third argument to byte-code to + ;; be larger than necessary. + (setq add-depth 1)))) + ;; + ;; dup varset-X discard --> varset-X + ;; dup varbind-X discard --> varbind-X + ;; dup stack-set-X discard --> stack-set-X-1 + ;; (the varbind variant can emerge from other optimizations) + ;; + ((and (eq 'byte-dup (car lap0)) + (eq 'byte-discard (car lap2)) + (memq (car lap1) '(byte-varset byte-varbind + byte-stack-set))) + (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) + (setq keep-going t + rest (cdr rest)) + (if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1))) + (setq lap (delq lap0 (delq lap2 lap)))) + ;; + ;; not goto-X-if-nil --> goto-X-if-non-nil + ;; not goto-X-if-non-nil --> goto-X-if-nil + ;; + ;; it is wrong to do the same thing for the -else-pop variants. + ;; + ((and (eq 'byte-not (car lap0)) + (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil))) + (byte-compile-log-lap " not %s\t-->\t%s" + lap1 + (cons + (if (eq (car lap1) 'byte-goto-if-nil) + 'byte-goto-if-not-nil + 'byte-goto-if-nil) + (cdr lap1))) + (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil) + 'byte-goto-if-not-nil + 'byte-goto-if-nil)) + (setq lap (delq lap0 lap)) + (setq keep-going t)) + ;; + ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X: + ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X: + ;; + ;; it is wrong to do the same thing for the -else-pop variants. + ;; + ((and (memq (car lap0) + '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX + (eq 'byte-goto (car lap1)) ; gotoY + (eq (cdr lap0) lap2)) ; TAG X + (let ((inverse (if (eq 'byte-goto-if-nil (car lap0)) + 'byte-goto-if-not-nil 'byte-goto-if-nil))) + (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:" + lap0 lap1 lap2 + (cons inverse (cdr lap1)) lap2) + (setq lap (delq lap0 lap)) + (setcar lap1 inverse) + (setq keep-going t))) + ;; + ;; const goto-if-* --> whatever + ;; + ((and (eq 'byte-constant (car lap0)) + (memq (car lap1) byte-conditional-ops) + ;; If the `byte-constant's cdr is not a cons cell, it has + ;; to be an index into the constant pool); even though + ;; it'll be a constant, that constant is not known yet + ;; (it's typically a free variable of a closure, so will + ;; only be known when the closure will be built at + ;; run-time). + (consp (cdr lap0))) + (cond ((if (memq (car lap1) '(byte-goto-if-nil + byte-goto-if-nil-else-pop)) + (car (cdr lap0)) + (not (car (cdr lap0)))) + (byte-compile-log-lap " %s %s\t-->\t<deleted>" + lap0 lap1) + (setq rest (cdr rest) + lap (delq lap0 (delq lap1 lap)))) + (t + (byte-compile-log-lap " %s %s\t-->\t%s" + lap0 lap1 + (cons 'byte-goto (cdr lap1))) + (when (memq (car lap1) byte-goto-always-pop-ops) + (setq lap (delq lap0 lap))) + (setcar lap1 'byte-goto))) + (setq keep-going t)) + ;; + ;; varref-X varref-X --> varref-X dup + ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup + ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup + ;; We don't optimize the const-X variations on this here, + ;; because that would inhibit some goto optimizations; we + ;; optimize the const-X case after all other optimizations. + ;; + ((and (memq (car lap0) '(byte-varref byte-stack-ref)) + (progn + (setq tmp (cdr rest)) + (setq tmp2 0) + (while (eq (car (car tmp)) 'byte-dup) + (setq tmp2 (1+ tmp2)) + (setq tmp (cdr tmp))) + t) + (eq (if (eq 'byte-stack-ref (car lap0)) + (+ tmp2 1 (cdr lap0)) + (cdr lap0)) + (cdr (car tmp))) + (eq (car lap0) (car (car tmp)))) + (if (memq byte-optimize-log '(t byte)) + (let ((str "")) + (setq tmp2 (cdr rest)) + (while (not (eq tmp tmp2)) + (setq tmp2 (cdr tmp2) + str (concat str " dup"))) + (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup" + lap0 str lap0 lap0 str))) + (setq keep-going t) + (setcar (car tmp) 'byte-dup) + (setcdr (car tmp) 0) + (setq rest tmp)) + ;; + ;; TAG1: TAG2: --> TAG1: <deleted> + ;; (and other references to TAG2 are replaced with TAG1) + ;; + ((and (eq (car lap0) 'TAG) + (eq (car lap1) 'TAG)) + (and (memq byte-optimize-log '(t byte)) + (byte-compile-log " adjacent tags %d and %d merged" + (nth 1 lap1) (nth 1 lap0))) + (setq tmp3 lap) + (while (setq tmp2 (rassq lap0 tmp3)) + (setcdr tmp2 lap1) + (setq tmp3 (cdr (memq tmp2 tmp3)))) + (setq lap (delq lap0 lap) + keep-going t) + ;; replace references to tag in jump tables, if any + (dolist (table byte-compile-jump-tables) + (maphash #'(lambda (value tag) + (when (equal tag lap0) + (puthash value lap1 table))) + table))) + ;; + ;; unused-TAG: --> <deleted> + ;; + ((and (eq 'TAG (car lap0)) + (not (rassq lap0 lap)) + ;; make sure this tag isn't used in a jump-table + (cl-loop for table in byte-compile-jump-tables + when (member lap0 (hash-table-values table)) + return nil finally return t)) + (and (memq byte-optimize-log '(t byte)) + (byte-compile-log " unused tag %d removed" (nth 1 lap0))) + (setq lap (delq lap0 lap) + keep-going t)) + ;; + ;; goto ... --> goto <delete until TAG or end> + ;; return ... --> return <delete until TAG or end> + ;; (unless a jump-table is being used, where deleting may affect + ;; other valid case bodies) + ;; + ((and (memq (car lap0) '(byte-goto byte-return)) + (not (memq (car lap1) '(TAG nil))) + ;; FIXME: Instead of deferring simply when jump-tables are + ;; being used, keep a list of tags used for switch tags and + ;; use them instead (see `byte-compile-inline-lapcode'). + (not byte-compile-jump-tables)) + (setq tmp rest) + (let ((i 0) + (opt-p (memq byte-optimize-log '(t lap))) + str deleted) + (while (and (setq tmp (cdr tmp)) + (not (eq 'TAG (car (car tmp))))) + (if opt-p (setq deleted (cons (car tmp) deleted) + str (concat str " %s") + i (1+ i)))) + (if opt-p + (let ((tagstr + (if (eq 'TAG (car (car tmp))) + (format "%d:" (car (cdr (car tmp)))) + (or (car tmp) "")))) + (if (< i 6) + (apply 'byte-compile-log-lap-1 + (concat " %s" str + " %s\t-->\t%s <deleted> %s") + lap0 + (nconc (nreverse deleted) + (list tagstr lap0 tagstr))) + (byte-compile-log-lap + " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s" + lap0 i (if (= i 1) "" "s") + tagstr lap0 tagstr)))) + (rplacd rest tmp)) + (setq keep-going t)) + ;; + ;; <safe-op> unbind --> unbind <safe-op> + ;; (this may enable other optimizations.) + ;; + ((and (eq 'byte-unbind (car lap1)) + (memq (car lap0) byte-after-unbind-ops)) + (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0) + (setcar rest lap1) + (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) + ;; + ((and (eq 'byte-unbind (car lap1)) + (memq (car lap0) '(byte-varbind byte-save-excursion + byte-save-restriction)) + (< 0 (cdr lap1))) + (if (zerop (setcdr lap1 (1- (cdr lap1)))) + (delq lap1 rest)) + (if (eq (car lap0) 'byte-varbind) + (setcar rest (cons 'byte-discard 0)) + (setq lap (delq lap0 lap))) + (byte-compile-log-lap " %s %s\t-->\t%s %s" + lap0 (cons (car lap1) (1+ (cdr lap1))) + (if (eq (car lap0) 'byte-varbind) + (car rest) + (car (cdr rest))) + (if (and (/= 0 (cdr lap1)) + (eq (car lap0) 'byte-varbind)) + (car (cdr rest)) + "")) + (setq keep-going t)) + ;; + ;; goto*-X ... X: goto-Y --> goto*-Y + ;; goto-X ... X: return --> return + ;; + ((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))) + (byte-compile-log-lap " %s [%s]\t-->\t%s" + (car lap0) tmp tmp) + (if (eq (car tmp) 'byte-return) + (setcar lap0 'byte-return)) + (setcdr lap0 (cdr tmp)) + (setq keep-going t)))) + ;; + ;; goto-*-else-pop X ... X: goto-if-* --> whatever + ;; goto-*-else-pop X ... X: discard --> whatever + ;; + ((and (memq (car lap0) '(byte-goto-if-nil-else-pop + byte-goto-if-not-nil-else-pop)) + (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap))))) + (eval-when-compile + (cons 'byte-discard byte-conditional-ops))) + (not (eq lap0 (car tmp)))) + (setq tmp2 (car tmp)) + (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop + byte-goto-if-nil) + (byte-goto-if-not-nil-else-pop + byte-goto-if-not-nil)))) + (if (memq (car tmp2) tmp3) + (progn (setcar lap0 (car tmp2)) + (setcdr lap0 (cdr tmp2)) + (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s" + (car lap0) tmp2 lap0)) + ;; Get rid of the -else-pop's and jump one step further. + (or (eq 'TAG (car (nth 1 tmp))) + (setcdr tmp (cons (byte-compile-make-tag) + (cdr tmp)))) + (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>" + (car lap0) tmp2 (nth 1 tmp3)) + (setcar lap0 (nth 1 tmp3)) + (setcdr lap0 (nth 1 tmp))) + (setq keep-going t)) + ;; + ;; const goto-X ... X: goto-if-* --> whatever + ;; const goto-X ... X: discard --> whatever + ;; + ((and (eq (car lap0) 'byte-constant) + (eq (car lap1) 'byte-goto) + (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap))))) + (eval-when-compile + (cons 'byte-discard byte-conditional-ops))) + (not (eq lap1 (car tmp)))) + (setq tmp2 (car tmp)) + (cond ((when (consp (cdr lap0)) + (memq (car tmp2) + (if (null (car (cdr lap0))) + '(byte-goto-if-nil byte-goto-if-nil-else-pop) + '(byte-goto-if-not-nil + byte-goto-if-not-nil-else-pop)))) + (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s" + lap0 tmp2 lap0 tmp2) + (setcar lap1 (car tmp2)) + (setcdr lap1 (cdr tmp2)) + ;; Let next step fix the (const,goto-if*) sequence. + (setq rest (cons nil rest)) + (setq keep-going t)) + ((or (consp (cdr lap0)) + (eq (car tmp2) 'byte-discard)) + ;; Jump one step further + (byte-compile-log-lap + " %s goto [%s]\t-->\t<deleted> goto <skip>" + lap0 tmp2) (or (eq 'TAG (car (nth 1 tmp))) (setcdr tmp (cons (byte-compile-make-tag) (cdr tmp)))) - (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>" - (car lap0) tmp2 (nth 1 tmp3)) - (setcar lap0 (nth 1 tmp3)) - (setcdr lap0 (nth 1 tmp))) - (setq keep-going t)) - ;; - ;; const goto-X ... X: goto-if-* --> whatever - ;; const goto-X ... X: discard --> whatever - ;; - ((and (eq (car lap0) 'byte-constant) - (eq (car lap1) 'byte-goto) - (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap))))) - (eval-when-compile - (cons 'byte-discard byte-conditional-ops))) - (not (eq lap1 (car tmp)))) - (setq tmp2 (car tmp)) - (cond ((when (consp (cdr lap0)) - (memq (car tmp2) - (if (null (car (cdr lap0))) - '(byte-goto-if-nil byte-goto-if-nil-else-pop) - '(byte-goto-if-not-nil - byte-goto-if-not-nil-else-pop)))) - (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s" - lap0 tmp2 lap0 tmp2) - (setcar lap1 (car tmp2)) - (setcdr lap1 (cdr tmp2)) - ;; Let next step fix the (const,goto-if*) sequence. - (setq rest (cons nil rest)) - (setq keep-going t)) - ((or (consp (cdr lap0)) - (eq (car tmp2) 'byte-discard)) - ;; Jump one step further - (byte-compile-log-lap - " %s goto [%s]\t-->\t<deleted> goto <skip>" - lap0 tmp2) - (or (eq 'TAG (car (nth 1 tmp))) - (setcdr tmp (cons (byte-compile-make-tag) - (cdr tmp)))) - (setcdr lap1 (car (cdr tmp))) - (setq lap (delq lap0 lap)) - (setq keep-going t)))) - ;; - ;; X: varref-Y ... varset-Y goto-X --> - ;; X: varref-Y Z: ... dup varset-Y goto-Z - ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) - ;; (This is so usual for while loops that it is worth handling). - ;; - ;; Here again, we could do it for stack-ref/stack-set, but - ;; that's replacing a stack-ref-Y with a stack-ref-0, which - ;; is a very minor improvement (if any), at the cost of - ;; more stack use and more byte-code. Let's not do it. - ;; - ((and (eq (car lap1) 'byte-varset) - (eq (car lap2) 'byte-goto) - (not (memq (cdr lap2) rest)) ;Backwards jump - (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap))))) - 'byte-varref) - (eq (cdr (car tmp)) (cdr lap1)) - (not (memq (car (cdr lap1)) byte-boolean-vars))) - ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp)) - (let ((newtag (byte-compile-make-tag))) - (byte-compile-log-lap - " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s" - (nth 1 (cdr lap2)) (car tmp) - lap1 lap2 - (nth 1 (cdr lap2)) (car tmp) - (nth 1 newtag) 'byte-dup lap1 - (cons 'byte-goto newtag) - ) - (setcdr rest (cons (cons 'byte-dup 0) (cdr rest))) - (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp)))) - (setq add-depth 1) - (setq keep-going t)) - ;; - ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y: - ;; (This can pull the loop test to the end of the loop) - ;; - ((and (eq (car lap0) 'byte-goto) - (eq (car lap1) 'TAG) - (eq lap1 - (cdr (car (setq tmp (cdr (memq (cdr lap0) lap)))))) - (memq (car (car tmp)) - '(byte-goto byte-goto-if-nil byte-goto-if-not-nil - byte-goto-if-nil-else-pop))) -;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional" -;; lap0 lap1 (cdr lap0) (car tmp)) - (let ((newtag (byte-compile-make-tag))) - (byte-compile-log-lap - "%s %s: ... %s: %s\t-->\t%s ... %s:" - lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp) - (cons (cdr (assq (car (car tmp)) - '((byte-goto-if-nil . byte-goto-if-not-nil) - (byte-goto-if-not-nil . byte-goto-if-nil) - (byte-goto-if-nil-else-pop . - byte-goto-if-not-nil-else-pop) - (byte-goto-if-not-nil-else-pop . - byte-goto-if-nil-else-pop)))) - newtag) - - (nth 1 newtag) - ) - (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp))) - (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop) - ;; We can handle this case but not the -if-not-nil case, - ;; because we won't know which non-nil constant to push. - (setcdr rest (cons (cons 'byte-constant - (byte-compile-get-constant nil)) - (cdr rest)))) - (setcar lap0 (nth 1 (memq (car (car tmp)) - '(byte-goto-if-nil-else-pop - byte-goto-if-not-nil - byte-goto-if-nil - byte-goto-if-not-nil - byte-goto byte-goto)))) - ) - (setq keep-going t)) - ) + (setcdr lap1 (car (cdr tmp))) + (setq lap (delq lap0 lap)) + (setq keep-going t)))) + ;; + ;; X: varref-Y ... varset-Y goto-X --> + ;; X: varref-Y Z: ... dup varset-Y goto-Z + ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) + ;; (This is so usual for while loops that it is worth handling). + ;; + ;; Here again, we could do it for stack-ref/stack-set, but + ;; that's replacing a stack-ref-Y with a stack-ref-0, which + ;; is a very minor improvement (if any), at the cost of + ;; more stack use and more byte-code. Let's not do it. + ;; + ((and (eq (car lap1) 'byte-varset) + (eq (car lap2) 'byte-goto) + (not (memq (cdr lap2) rest)) ;Backwards jump + (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap))))) + 'byte-varref) + (eq (cdr (car tmp)) (cdr lap1)) + (not (memq (car (cdr lap1)) byte-boolean-vars))) + ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp)) + (let ((newtag (byte-compile-make-tag))) + (byte-compile-log-lap + " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s" + (nth 1 (cdr lap2)) (car tmp) + lap1 lap2 + (nth 1 (cdr lap2)) (car tmp) + (nth 1 newtag) 'byte-dup lap1 + (cons 'byte-goto newtag) + ) + (setcdr rest (cons (cons 'byte-dup 0) (cdr rest))) + (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp)))) + (setq add-depth 1) + (setq keep-going t)) + ;; + ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y: + ;; (This can pull the loop test to the end of the loop) + ;; + ((and (eq (car lap0) 'byte-goto) + (eq (car lap1) 'TAG) + (eq lap1 + (cdr (car (setq tmp (cdr (memq (cdr lap0) lap)))))) + (memq (car (car tmp)) + '(byte-goto byte-goto-if-nil byte-goto-if-not-nil + byte-goto-if-nil-else-pop))) + ;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional" + ;; lap0 lap1 (cdr lap0) (car tmp)) + (let ((newtag (byte-compile-make-tag))) + (byte-compile-log-lap + "%s %s: ... %s: %s\t-->\t%s ... %s:" + lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp) + (cons (cdr (assq (car (car tmp)) + '((byte-goto-if-nil . byte-goto-if-not-nil) + (byte-goto-if-not-nil . byte-goto-if-nil) + (byte-goto-if-nil-else-pop . + byte-goto-if-not-nil-else-pop) + (byte-goto-if-not-nil-else-pop . + byte-goto-if-nil-else-pop)))) + newtag) + + (nth 1 newtag) + ) + (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp))) + (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop) + ;; We can handle this case but not the -if-not-nil case, + ;; because we won't know which non-nil constant to push. + (setcdr rest (cons (cons 'byte-constant + (byte-compile-get-constant nil)) + (cdr rest)))) + (setcar lap0 (nth 1 (memq (car (car tmp)) + '(byte-goto-if-nil-else-pop + byte-goto-if-not-nil + byte-goto-if-nil + byte-goto-if-not-nil + byte-goto byte-goto)))) + ) + (setq keep-going t)) + + ;; + ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos + ;; stack-set-M [discard/discardN ...] --> discardN + ;; + ((and (eq (car lap0) 'byte-stack-set) + (memq (car lap1) '(byte-discard byte-discardN)) + (progn + ;; See if enough discard operations follow to expose or + ;; destroy the value stored by the stack-set. + (setq tmp (cdr rest)) + (setq tmp2 (1- (cdr lap0))) + (setq tmp3 0) + (while (memq (car (car tmp)) '(byte-discard byte-discardN)) + (setq tmp3 + (+ tmp3 (if (eq (car (car tmp)) 'byte-discard) + 1 + (cdr (car tmp))))) + (setq tmp (cdr tmp))) + (>= tmp3 tmp2))) + ;; Do the optimization. + (setq lap (delq lap0 lap)) + (setcar lap1 + (if (= tmp2 tmp3) + ;; The value stored is the new TOS, so pop one more + ;; value (to get rid of the old value) using the + ;; TOS-preserving discard operator. + 'byte-discardN-preserve-tos + ;; Otherwise, the value stored is lost, so just use a + ;; normal discard. + 'byte-discardN)) + (setcdr lap1 (1+ tmp3)) + (setcdr (cdr rest) tmp) + (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s" + lap0 lap1)) + + ;; + ;; discardN-preserve-tos return --> return + ;; dup return --> return + ;; stack-set-N return --> return ; where N is TOS-1 + ;; + ((and (eq (car lap1) 'byte-return) + (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup)) + (and (eq (car lap0) 'byte-stack-set) + (= (cdr lap0) 1)))) + (setq keep-going t) + ;; The byte-code interpreter will pop the stack for us, so + ;; we can just leave stuff on it. + (setq lap (delq lap0 lap)) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1)) + + ;; + ;; goto-X ... X: discard ==> discard goto-Y ... X: discard Y: + ;; + ((and (eq (car lap0) 'byte-goto) + (setq tmp (cdr (memq (cdr lap0) lap))) + (memq (caar tmp) '(byte-discard byte-discardN + byte-discardN-preserve-tos))) + (byte-compile-log-lap + " goto-X .. X: \t-->\t%s goto-X.. X: %s Y:" + (car tmp) (car tmp)) + (setq keep-going t) + (let* ((newtag (byte-compile-make-tag)) + ;; Make a copy, since we sometimes modify insts in-place! + (newdiscard (cons (caar tmp) (cdar tmp))) + (newjmp (cons (car lap0) newtag))) + (push newtag (cdr tmp)) ;Push new tag after the discard. + (setcar rest newdiscard) + (push newjmp (cdr rest)))) + + ;; + ;; const discardN-preserve-tos ==> discardN const + ;; + ((and (eq (car lap0) 'byte-constant) + (eq (car lap1) 'byte-discardN-preserve-tos)) + (setq keep-going t) + (let ((newdiscard (cons 'byte-discardN (cdr lap1)))) + (byte-compile-log-lap + " %s %s\t-->\t%s %s" lap0 lap1 newdiscard lap0) + (setf (car rest) newdiscard) + (setf (cadr rest) lap0))) + ) (setq rest (cdr rest))) ) ;; Cleanup stage: @@ -2098,41 +2168,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (setcdr lap1 (+ (cdr lap1) (cdr lap0)))) ;; - ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos - ;; stack-set-M [discard/discardN ...] --> discardN - ;; - ((and (eq (car lap0) 'byte-stack-set) - (memq (car lap1) '(byte-discard byte-discardN)) - (progn - ;; See if enough discard operations follow to expose or - ;; destroy the value stored by the stack-set. - (setq tmp (cdr rest)) - (setq tmp2 (1- (cdr lap0))) - (setq tmp3 0) - (while (memq (car (car tmp)) '(byte-discard byte-discardN)) - (setq tmp3 - (+ tmp3 (if (eq (car (car tmp)) 'byte-discard) - 1 - (cdr (car tmp))))) - (setq tmp (cdr tmp))) - (>= tmp3 tmp2))) - ;; Do the optimization. - (setq lap (delq lap0 lap)) - (setcar lap1 - (if (= tmp2 tmp3) - ;; The value stored is the new TOS, so pop one more - ;; value (to get rid of the old value) using the - ;; TOS-preserving discard operator. - 'byte-discardN-preserve-tos - ;; Otherwise, the value stored is lost, so just use a - ;; normal discard. - 'byte-discardN)) - (setcdr lap1 (1+ tmp3)) - (setcdr (cdr rest) tmp) - (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s" - lap0 lap1)) - - ;; ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y --> ;; discardN-(X+Y) ;; @@ -2159,20 +2194,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (setq lap (delq lap0 lap)) (setcdr lap1 (+ (cdr lap0) (cdr lap1))) (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest))) - - ;; - ;; discardN-preserve-tos return --> return - ;; dup return --> return - ;; stack-set-N return --> return ; where N is TOS-1 - ;; - ((and (eq (car lap1) 'byte-return) - (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup)) - (and (eq (car lap0) 'byte-stack-set) - (= (cdr lap0) 1)))) - ;; The byte-code interpreter will pop the stack for us, so - ;; we can just leave stuff on it. - (setq lap (delq lap0 lap)) - (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1)) ) (setq rest (cdr rest))) (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth))) @@ -2195,7 +2216,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (or noninteractive (message "compiling %s...done" x))) '(byte-optimize-form byte-optimize-body - byte-optimize-predicate + byte-optimize-constant-args byte-optimize-binary-predicate ;; Inserted some more than necessary, to speed it up. byte-optimize-form-code-walker diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 3ca32bf4211..88f362d24f0 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -82,65 +82,84 @@ The return value of this function is not used." ;; We define macro-declaration-alist here because it is needed to ;; handle declarations in macro definitions and this is the first file -;; loaded by loadup.el that uses declarations in macros. +;; loaded by loadup.el that uses declarations in macros. We specify +;; the values as named aliases so that `describe-variable' prints +;; something useful; cf. Bug#40491. We can only use backquotes inside +;; the lambdas and not for those properties that are used by functions +;; loaded before backquote.el. + +(defalias 'byte-run--set-advertised-calling-convention + #'(lambda (f _args arglist when) + (list 'set-advertised-calling-convention + (list 'quote f) (list 'quote arglist) (list 'quote when)))) + +(defalias 'byte-run--set-obsolete + #'(lambda (f _args new-name when) + (list 'make-obsolete + (list 'quote f) (list 'quote new-name) (list 'quote when)))) + +(defalias 'byte-run--set-interactive-only + #'(lambda (f _args instead) + (list 'function-put (list 'quote f) + ''interactive-only (list 'quote instead)))) + +(defalias 'byte-run--set-pure + #'(lambda (f _args val) + (list 'function-put (list 'quote f) + ''pure (list 'quote val)))) + +(defalias 'byte-run--set-side-effect-free + #'(lambda (f _args val) + (list 'function-put (list 'quote f) + ''side-effect-free (list 'quote val)))) + +(defalias 'byte-run--set-compiler-macro + #'(lambda (f args compiler-function) + (if (not (eq (car-safe compiler-function) 'lambda)) + `(eval-and-compile + (function-put ',f 'compiler-macro #',compiler-function)) + (let ((cfname (intern (concat (symbol-name f) "--anon-cmacro"))) + ;; Avoid cadr/cddr so we can use `compiler-macro' before + ;; defining cadr/cddr. + (data (cdr compiler-function))) + `(progn + (eval-and-compile + (function-put ',f 'compiler-macro #',cfname)) + ;; Don't autoload the compiler-macro itself, since the + ;; macroexpander will find this file via `f's autoload, + ;; if needed. + :autoload-end + (eval-and-compile + (defun ,cfname (,@(car data) ,@args) + ,@(cdr data)))))))) + +(defalias 'byte-run--set-doc-string + #'(lambda (f _args pos) + (list 'function-put (list 'quote f) + ''doc-string-elt (list 'quote pos)))) + +(defalias 'byte-run--set-indent + #'(lambda (f _args val) + (list 'function-put (list 'quote f) + ''lisp-indent-function (list 'quote val)))) ;; Add any new entries to info node `(elisp)Declare Form'. (defvar defun-declarations-alist (list - ;; We can only use backquotes inside the lambdas and not for those - ;; properties that are used by functions loaded before backquote.el. (list 'advertised-calling-convention - #'(lambda (f _args arglist when) - (list 'set-advertised-calling-convention - (list 'quote f) (list 'quote arglist) (list 'quote when)))) - (list 'obsolete - #'(lambda (f _args new-name when) - (list 'make-obsolete - (list 'quote f) (list 'quote new-name) (list 'quote when)))) - (list 'interactive-only - #'(lambda (f _args instead) - (list 'function-put (list 'quote f) - ''interactive-only (list 'quote instead)))) + #'byte-run--set-advertised-calling-convention) + (list 'obsolete #'byte-run--set-obsolete) + (list 'interactive-only #'byte-run--set-interactive-only) ;; FIXME: Merge `pure' and `side-effect-free'. - (list 'pure - #'(lambda (f _args val) - (list 'function-put (list 'quote f) - ''pure (list 'quote val))) + (list 'pure #'byte-run--set-pure "If non-nil, the compiler can replace calls with their return value. This may shift errors from run-time to compile-time.") - (list 'side-effect-free - #'(lambda (f _args val) - (list 'function-put (list 'quote f) - ''side-effect-free (list 'quote val))) + (list 'side-effect-free #'byte-run--set-side-effect-free "If non-nil, calls can be ignored if their value is unused. If `error-free', drop calls even if `byte-compile-delete-errors' is nil.") - (list 'compiler-macro - #'(lambda (f args compiler-function) - (if (not (eq (car-safe compiler-function) 'lambda)) - `(eval-and-compile - (function-put ',f 'compiler-macro #',compiler-function)) - (let ((cfname (intern (concat (symbol-name f) "--anon-cmacro"))) - ;; Avoid cadr/cddr so we can use `compiler-macro' before - ;; defining cadr/cddr. - (data (cdr compiler-function))) - `(progn - (eval-and-compile - (function-put ',f 'compiler-macro #',cfname)) - ;; Don't autoload the compiler-macro itself, since the - ;; macroexpander will find this file via `f's autoload, - ;; if needed. - :autoload-end - (eval-and-compile - (defun ,cfname (,@(car data) ,@args) - ,@(cdr data)))))))) - (list 'doc-string - #'(lambda (f _args pos) - (list 'function-put (list 'quote f) - ''doc-string-elt (list 'quote pos)))) - (list 'indent - #'(lambda (f _args val) - (list 'function-put (list 'quote f) - ''lisp-indent-function (list 'quote val))))) + (list 'compiler-macro #'byte-run--set-compiler-macro) + (list 'doc-string #'byte-run--set-doc-string) + (list 'indent #'byte-run--set-indent)) "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, @@ -150,18 +169,22 @@ to set this property. This is used by `declare'.") +(defalias 'byte-run--set-debug + #'(lambda (name _args spec) + (list 'progn :autoload-end + (list 'put (list 'quote name) + ''edebug-form-spec (list 'quote spec))))) + +(defalias 'byte-run--set-no-font-lock-keyword + #'(lambda (name _args val) + (list 'function-put (list 'quote name) + ''no-font-lock-keyword (list 'quote val)))) + (defvar macro-declarations-alist (cons - (list 'debug - #'(lambda (name _args spec) - (list 'progn :autoload-end - (list 'put (list 'quote name) - ''edebug-form-spec (list 'quote spec))))) + (list 'debug #'byte-run--set-debug) (cons - (list 'no-font-lock-keyword - #'(lambda (name _args val) - (list 'function-put (list 'quote name) - ''no-font-lock-keyword (list 'quote val)))) + (list 'no-font-lock-keyword #'byte-run--set-no-font-lock-keyword) defun-declarations-alist)) "List associating properties of macros to their macro expansion. Each element of the list takes the form (PROP FUN) where FUN is a function. @@ -209,8 +232,11 @@ The return value is undefined. #'(lambda (x) (let ((f (cdr (assq (car x) macro-declarations-alist)))) (if f (apply (car f) name arglist (cdr x)) - (message "Warning: Unknown macro property %S in %S" - (car x) name)))) + (macroexp--warn-and-return + (format-message + "Unknown macro property %S in %S" + (car x) name) + nil)))) decls))) ;; Refresh font-lock if this is a new macro, or it is an ;; existing macro whose 'no-font-lock-keyword declaration @@ -278,9 +304,12 @@ The return value is undefined. (cdr body) body))) nil) - (t (message "Warning: Unknown defun property `%S' in %S" - (car x) name))))) - decls)) + (t + (macroexp--warn-and-return + (format-message "Unknown defun property `%S' in %S" + (car x) name) + nil))))) + decls)) (def (list 'defalias (list 'quote name) (list 'function @@ -349,7 +378,7 @@ convention was modified." (puthash (indirect-function function) signature advertised-signature-table)) -(defun make-obsolete (obsolete-name current-name &optional when) +(defun make-obsolete (obsolete-name current-name when) "Make the byte-compiler warn that function OBSOLETE-NAME is obsolete. OBSOLETE-NAME should be a function name or macro name (a symbol). @@ -358,17 +387,14 @@ If CURRENT-NAME is a string, that is the `use instead' message \(it should end with a period, and not start with a capital). WHEN should be a string indicating when the function was first made obsolete, for example a date or a release number." - (declare (advertised-calling-convention - ;; New code should always provide the `when' argument. - (obsolete-name current-name when) "23.1")) (put obsolete-name 'byte-obsolete-info ;; The second entry used to hold the `byte-compile' handler, but ;; is not used any more nowadays. (purecopy (list current-name nil when))) obsolete-name) -(defmacro define-obsolete-function-alias (obsolete-name current-name - &optional when docstring) +(defmacro define-obsolete-function-alias ( obsolete-name current-name when + &optional docstring) "Set OBSOLETE-NAME's function definition to CURRENT-NAME and mark it obsolete. \(define-obsolete-function-alias \\='old-fun \\='new-fun \"22.1\" \"old-fun's doc.\") @@ -382,15 +408,13 @@ WHEN should be a string indicating when the function was first made obsolete, for example a date or a release number. See the docstrings of `defalias' and `make-obsolete' for more details." - (declare (doc-string 4) - (advertised-calling-convention - ;; New code should always provide the `when' argument. - (obsolete-name current-name when &optional docstring) "23.1")) + (declare (doc-string 4)) `(progn (defalias ,obsolete-name ,current-name ,docstring) (make-obsolete ,obsolete-name ,current-name ,when))) -(defun make-obsolete-variable (obsolete-name current-name &optional when access-type) +(defun make-obsolete-variable ( obsolete-name current-name when + &optional access-type) "Make the byte-compiler warn that 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. @@ -398,18 +422,24 @@ WHEN should be a string indicating when the variable was first made obsolete, for example a date or a release number. ACCESS-TYPE if non-nil should specify the kind of access that will trigger obsolescence warnings; it can be either `get' or `set'." - (declare (advertised-calling-convention - ;; New code should always provide the `when' argument. - (obsolete-name current-name when &optional access-type) "23.1")) (put obsolete-name 'byte-obsolete-variable (purecopy (list current-name access-type when))) obsolete-name) -(defmacro define-obsolete-variable-alias (obsolete-name current-name - &optional when docstring) +(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. -This uses `defvaralias' and `make-obsolete-variable' (which see). + +WHEN should be a string indicating when the variable was first +made obsolete, for example a date or a release number. + +This macro evaluates all its parameters, and both OBSOLETE-NAME +and CURRENT-NAME should be symbols, so a typical usage would look like: + + (define-obsolete-variable-alias 'foo-thing 'bar-thing \"27.1\") + +This macro uses `defvaralias' and `make-obsolete-variable' (which see). See the Info node `(elisp)Variable Aliases' for more details. If CURRENT-NAME is a defcustom or a defvar (more generally, any variable @@ -423,17 +453,11 @@ dumped with Emacs). This is so that any user customizations are applied before the defcustom tries to initialize the variable (this is due to the way `defvaralias' works). -WHEN should be a string indicating when the variable was first -made obsolete, for example a date or a release number. - For the benefit of Customize, if OBSOLETE-NAME has any of the following properties, they are copied to CURRENT-NAME, if it does not already have them: `saved-value', `saved-variable-comment'." - (declare (doc-string 4) - (advertised-calling-convention - ;; New code should always provide the `when' argument. - (obsolete-name current-name when &optional docstring) "23.1")) + (declare (doc-string 4)) `(progn (defvaralias ,obsolete-name ,current-name ,docstring) ;; See Bug#4706. @@ -553,13 +577,26 @@ Otherwise, return nil. For internal use only." (mapconcat (lambda (char) (format "`?\\%c'" char)) sorted ", "))))) +(defun byte-compile-info (string &optional message type) + "Format STRING in a way that looks pleasing in the compilation output. +If MESSAGE, output the message, too. + +If TYPE, it should be a string that says what the information +type is. This defaults to \"INFO\"." + (let ((string (format " %-9s%s" (or type "INFO") string))) + (when message + (message "%s" string)) + string)) + (defun byte-compile-info-string (&rest args) "Format ARGS in a way that looks pleasing in the compilation output." - (format " %-9s%s" "INFO" (apply #'format args))) + (declare (obsolete byte-compile-info "28.1")) + (byte-compile-info (apply #'format args))) (defun byte-compile-info-message (&rest args) "Message format ARGS in a way that looks pleasing in the compilation output." - (message "%s" (apply #'byte-compile-info-string args))) + (declare (obsolete byte-compile-info "28.1")) + (byte-compile-info (apply #'format args) t)) ;; I nuked this because it's not a good idea for users to think of using it. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 9dc6a3037de..9429d6a0d5d 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -144,7 +144,7 @@ is hard-coded in various places in Emacs.)" ;; Eg is_elc in Fload. :type 'regexp) -(defcustom byte-compile-dest-file-function nil +(defcustom byte-compile-dest-file-function #'byte-compile--default-dest-file "Function for the function `byte-compile-dest-file' to call. It should take one argument, the name of an Emacs Lisp source file name, and return the name of the compiled file. @@ -177,14 +177,16 @@ function to do the work. Otherwise, if FILENAME matches `emacs-lisp-file-regexp' (by default, files with the extension \".el\"), replaces the matching part (and anything after it) with \".elc\"; otherwise adds \".elc\"." - (if byte-compile-dest-file-function - (funcall byte-compile-dest-file-function filename) - (setq filename (file-name-sans-versions - (byte-compiler-base-file-name filename))) - (cond ((string-match emacs-lisp-file-regexp filename) - (concat (substring filename 0 (match-beginning 0)) ".elc")) - (t (concat filename ".elc"))))) -) + (funcall (or byte-compile-dest-file-function + #'byte-compile--default-dest-file) + filename))) + +(defun byte-compile--default-dest-file (filename) + (setq filename (file-name-sans-versions + (byte-compiler-base-file-name filename))) + (cond ((string-match emacs-lisp-file-regexp filename) + (concat (substring filename 0 (match-beginning 0)) ".elc")) + (t (concat filename ".elc")))) ;; This can be the 'byte-compile property of any symbol. (autoload 'byte-compile-inline-expand "byte-opt") @@ -268,6 +270,13 @@ This option is enabled by default because it reduces Emacs memory usage." (defconst byte-compile-log-buffer "*Compile-Log*" "Name of the byte-compiler's log buffer.") +(defvar byte-compile--known-dynamic-vars nil + "Variables known to be declared as dynamic, for warning purposes. +Each element is (VAR . FILE), indicating that VAR is declared in FILE.") + +(defvar byte-compile--seen-defvars nil + "All dynamic variable declarations seen so far.") + (defcustom byte-optimize-log nil "If non-nil, the byte-compiler will log its optimizations. If this is `source', then only source-level optimizations will be logged. @@ -284,13 +293,14 @@ The information is logged to `byte-compile-log-buffer'." ;; This needs to be autoloaded because it needs to be available to ;; Emacs before the byte compiler is loaded, otherwise Emacs will not ;; know that this variable is marked as safe until it is too late. -;; (See https://lists.gnu.org/archive/html/emacs-devel/2018-01/msg00261.html ) +;; (See https://lists.gnu.org/r/emacs-devel/2018-01/msg00261.html ) ;;;###autoload(put 'byte-compile-error-on-warn 'safe-local-variable 'booleanp) (defconst byte-compile-warning-types '(redefine callargs free-vars unresolved - obsolete noruntime cl-functions interactive-only - make-local mapcar constants suspicious lexical) + obsolete noruntime interactive-only + make-local mapcar constants suspicious lexical lexical-dynamic + docstrings) "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). @@ -305,14 +315,16 @@ Elements of the list may be: obsolete obsolete variables and functions. noruntime functions that may not be defined at runtime (typically defined only under `eval-when-compile'). - cl-functions calls to runtime functions (as distinguished from macros and - aliases) from the old CL package (not the newer cl-lib). interactive-only commands that normally shouldn't be called from Lisp code. lexical global/dynamic variables lacking a prefix. + lexical-dynamic + lexically bound variable declared dynamic elsewhere make-local calls to make-variable-buffer-local that may be incorrect. mapcar mapcar called for effect. constants let-binding of, or assignment to, constants/nonvariables. + docstrings docstrings that are too wide (longer than 80 characters, + or `fill-column', whichever is bigger) suspicious constructs that usually don't do what the coder wanted. If the list begins with `not', then the remaining elements specify warnings to @@ -698,7 +710,8 @@ Each element is (INDEX . VALUE)") ;; These store their argument in the next two bytes (byte-defop 129 1 byte-constant2 - "for reference to a constant with vector index >= byte-constant-limit") + "for reference to a constant with vector +index >= byte-constant-limit") (byte-defop 130 0 byte-goto "for unconditional jump") (byte-defop 131 -1 byte-goto-if-nil "to pop value and jump if it's nil") (byte-defop 132 -1 byte-goto-if-not-nil "to pop value and jump if it's not nil") @@ -718,15 +731,19 @@ otherwise pop it") (byte-defop 139 0 byte-save-window-excursion-OBSOLETE "to make a binding to record entire window configuration") (byte-defop 140 0 byte-save-restriction - "to make a binding to record the current buffer clipping restrictions") -(byte-defop 141 -1 byte-catch - "for catch. Takes, on stack, the tag and an expression for the body") + "to make a binding to record the current buffer clipping +restrictions") +(byte-defop 141 -1 byte-catch-OBSOLETE ; Not generated since Emacs 25. + "for catch. Takes, on stack, the tag and an expression for +the body") (byte-defop 142 -1 byte-unwind-protect - "for unwind-protect. Takes, on stack, an expression for the unwind-action") + "for unwind-protect. Takes, on stack, an expression for +the unwind-action") ;; For condition-case. Takes, on stack, the variable to bind, ;; an expression for the body, and a list of clauses. -(byte-defop 143 -2 byte-condition-case) +;; Not generated since Emacs 25. +(byte-defop 143 -2 byte-condition-case-OBSOLETE) (byte-defop 144 0 byte-temp-output-buffer-setup-OBSOLETE) (byte-defop 145 -1 byte-temp-output-buffer-show-OBSOLETE) @@ -781,8 +798,8 @@ otherwise pop it") (defconst byte-discardN-preserve-tos byte-discardN) (byte-defop 183 -2 byte-switch - "to take a hash table and a value from the stack, and jump to the address -the value maps to, if any.") + "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 @@ -958,11 +975,6 @@ CONST2 may be evaluated multiple times." ;;; compile-time evaluation -(defun byte-compile-cl-file-p (file) - "Return non-nil if FILE is one of the CL files." - (and (stringp file) - (string-match "^cl\\.el" (file-name-nondirectory file)))) - (defun byte-compile-eval (form) "Eval FORM and mark the functions defined therein. Each function's symbol gets added to `byte-compile-noruntime-functions'." @@ -993,18 +1005,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (when (and (symbolp s) (not (memq s old-autoloads))) (push s byte-compile-noruntime-functions)) (when (and (consp s) (eq t (car s))) - (push (cdr s) old-autoloads))))))) - (when (byte-compile-warning-enabled-p 'cl-functions) - (let ((hist-new load-history)) - ;; Go through load-history, looking for the cl files. - ;; Since new files are added at the start of load-history, - ;; we scan the new history until the tail matches the old. - (while (and (not byte-compile-cl-functions) - hist-new (not (eq hist-new hist-orig))) - ;; We used to check if the file had already been loaded, - ;; but it is better to check non-nil byte-compile-cl-functions. - (and (byte-compile-cl-file-p (car (pop hist-new))) - (byte-compile-find-cl-functions)))))))) + (push (cdr s) old-autoloads)))))))))) (defun byte-compile-eval-before-compile (form) "Evaluate FORM for `eval-and-compile'." @@ -1015,9 +1016,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." ;; There are other ways to do this nowadays. (let ((tem current-load-list)) (while (not (eq tem hist-nil-orig)) - (when (equal (car tem) '(require . cl)) - (byte-compile-disable-warning 'cl-functions)) - (setq tem (cdr tem))))))) + (setq tem (cdr tem))))))) ;;; byte compiler messages @@ -1201,7 +1200,7 @@ message buffer `default-directory'." byte-compile-last-warned-form)))) (insert (format "\nIn %s:\n" form))) (when level - (insert (format "%s%s" file pos)))) + (insert (format "%s%s " file pos)))) (setq byte-compile-last-logged-file byte-compile-current-file byte-compile-last-warned-form byte-compile-current-form) entry) @@ -1567,43 +1566,79 @@ extra args." (if (equal sig1 '(1 . 1)) "argument" "arguments") (byte-compile-arglist-signature-string sig2))))))) -(defvar byte-compile-cl-functions nil - "List of functions defined in CL.") - -;; Can't just add this to cl-load-hook, because that runs just before -;; the forms from cl.el get added to load-history. -(defun byte-compile-find-cl-functions () - (unless byte-compile-cl-functions - (dolist (elt load-history) - (and (byte-compile-cl-file-p (car elt)) - (dolist (e (cdr elt)) - ;; Includes the cl-foo functions that cl autoloads. - (when (memq (car-safe e) '(autoload defun)) - (push (cdr e) byte-compile-cl-functions))))))) - -(defun byte-compile-cl-warn (form) - "Warn if FORM is a call of a function from the CL package." - (let ((func (car-safe form))) - (if (and byte-compile-cl-functions - (memq func byte-compile-cl-functions) - ;; Aliases which won't have been expanded at this point. - ;; These aren't all aliases of subrs, so not trivial to - ;; avoid hardwiring the list. - (not (memq func - '(cl--block-wrapper cl--block-throw - multiple-value-call nth-value - copy-seq first second rest endp cl-member - ;; These are included in generated code - ;; that can't be called except at compile time - ;; or unless cl is loaded anyway. - cl--defsubst-expand cl-struct-setf-expander - ;; These would sometimes be warned about - ;; but such warnings are never useful, - ;; so don't warn about them. - macroexpand - cl--compiling-file)))) - (byte-compile-warn "function `%s' from cl package called at runtime" - func))) +(defvar byte-compile--wide-docstring-substitution-len 3 + "Substitution width used in `byte-compile--wide-docstring-p'. +This is a heuristic for guessing the width of a documentation +string: `byte-compile--wide-docstring-p' assumes that any +`substitute-command-keys' command substitutions are this long.") + +(defun byte-compile--wide-docstring-p (docstring col) + "Return t if string DOCSTRING is wider than COL. +Ignore all `substitute-command-keys' substitutions, except for +the `\\\\=[command]' ones that are assumed to be of length +`byte-compile--wide-docstring-substitution-len'. Also ignore +URLs." + (string-match + (format "^.\\{%s,\\}$" (int-to-string (1+ col))) + (replace-regexp-in-string + (rx (or + ;; Ignore some URLs. + (seq "http" (? "s") "://" (* anychar)) + ;; Ignore these `substitute-command-keys' substitutions. + (seq "\\" (or "=" + (seq "<" (* (not ">")) ">") + (seq "{" (* (not "}")) "}"))))) + "" + ;; Heuristic: assume these substitutions are of some length N. + (replace-regexp-in-string + (rx "\\" (or (seq "[" (* (not "]")) "]"))) + (make-string byte-compile--wide-docstring-substitution-len ?x) + docstring)))) + +(defcustom byte-compile-docstring-max-column 80 + "Recommended maximum width of doc string lines. +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 + :version "28.1") + +(defun byte-compile-docstring-length-warn (form) + "Warn if documentation string of FORM is too wide. +It is too wide if it has any lines longer than the largest of +`fill-column' and `byte-compile-docstring-max-column'." + ;; This has some limitations that it would be nice to fix: + ;; 1. We don't try to handle defuns. It is somewhat tricky to get + ;; it right since `defun' is a macro. Also, some macros + ;; themselves produce defuns (e.g. `define-derived-mode'). + ;; 2. We assume that any `subsititute-command-keys' command replacement has a + ;; given length. We can't reliably do these replacements, since the value + ;; of the keymaps in general can't be known at compile time. + (when (byte-compile-warning-enabled-p 'docstrings) + (let ((col (max byte-compile-docstring-max-column fill-column)) + kind name docs) + (pcase (car form) + ((or 'autoload 'custom-declare-variable 'defalias + 'defconst 'define-abbrev-table + 'defvar 'defvaralias) + (setq kind (nth 0 form)) + (setq name (nth 1 form)) + (setq docs (nth 3 form))) + ;; Here is how one could add lambda's here: + ;; ('lambda + ;; (setq kind "") ; can't be "function", unfortunately + ;; (setq docs (and (stringp (nth 2 form)) + ;; (nth 2 form)))) + ) + (when (and (consp name) (eq (car name) 'quote)) + (setq name (cadr name))) + (setq name (if name (format " `%s'" name) "")) + (when (and kind docs (stringp docs) + (byte-compile--wide-docstring-p docs col)) + (byte-compile-warn "%s%s docstring wider than %s characters" + kind name col)))) form) (defun byte-compile-print-syms (str1 strn syms) @@ -1703,7 +1738,6 @@ extra args." (and (markerp warning-series) (eq (marker-buffer warning-series) (get-buffer byte-compile-log-buffer))))) - (byte-compile-find-cl-functions) (if (or (eq warning-series 'byte-compile-warning-series) warning-series-started) ;; warning-series does come from compilation, @@ -1736,7 +1770,7 @@ Files in subdirectories of DIRECTORY are processed also." (byte-recompile-directory directory nil t)) ;;;###autoload -(defun byte-recompile-directory (directory &optional arg force) +(defun byte-recompile-directory (directory &optional arg force follow-symlinks) "Recompile every `.el' file in DIRECTORY that needs recompilation. This happens when a `.elc' file exists but is older than the `.el' file. Files in subdirectories of DIRECTORY are processed also. @@ -1749,7 +1783,11 @@ compile it. A nonzero ARG also means ask about each subdirectory before scanning it. If the third argument FORCE is non-nil, recompile every `.el' file -that already has a `.elc' file." +that already has a `.elc' file. + +This command will normally not follow symlinks when compiling +files. If FOLLOW-SYMLINKS is non-nil, symlinked `.el' files will +also be compiled." (interactive "DByte recompile directory: \nP") (if arg (setq arg (prefix-numeric-value arg))) (if noninteractive @@ -1782,7 +1820,8 @@ that already has a `.elc' file." (if (file-directory-p source) (and (not (member file '("RCS" "CVS"))) (not (eq ?\. (aref file 0))) - (not (file-symlink-p source)) + (or follow-symlinks + (not (file-symlink-p source))) ;; This file is a subdirectory. Handle them differently. (or (null arg) (eq 0 arg) (y-or-n-p (concat "Check " source "? "))) @@ -1835,10 +1874,9 @@ compile FILENAME. If optional argument ARG is 0, it compiles the input file even if the `.elc' file does not exist. Any other non-nil value of ARG means to ask the user. -If optional argument LOAD is non-nil, loads the file after compiling. - If compilation is needed, this functions returns the result of `byte-compile-file'; otherwise it returns `no-byte-compile'." + (declare (advertised-calling-convention (filename &optional force arg) "28.1")) (interactive (let ((file buffer-file-name) (file-name nil) @@ -1855,22 +1893,34 @@ If compilation is needed, this functions returns the result of (let ((dest (byte-compile-dest-file filename)) ;; Expand now so we get the current buffer's defaults (filename (expand-file-name filename))) - (if (if (file-exists-p dest) - ;; File was already compiled - ;; Compile if forced to, or filename newer - (or force - (file-newer-than-file-p filename dest)) - (and arg - (or (eq 0 arg) - (y-or-n-p (concat "Compile " - filename "? "))))) - (progn - (if (and noninteractive (not byte-compile-verbose)) - (message "Compiling %s..." filename)) - (byte-compile-file filename load)) + (prog1 + (if (if (and dest (file-exists-p dest)) + ;; File was already compiled + ;; Compile if forced to, or filename newer + (or force + (file-newer-than-file-p filename dest)) + (and arg + (or (eq 0 arg) + (y-or-n-p (concat "Compile " + filename "? "))))) + (progn + (if (and noninteractive (not byte-compile-verbose)) + (message "Compiling %s..." filename)) + (byte-compile-file filename)) + 'no-byte-compile) (when load - (load (if (file-exists-p dest) dest filename))) - 'no-byte-compile))) + (load (if (and dest (file-exists-p dest)) dest filename)))))) + +(defun byte-compile--load-dynvars (file) + (and file (not (equal file "")) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (let ((vars nil) + var) + (while (ignore-errors (setq var (read (current-buffer)))) + (push var vars)) + vars)))) (defvar byte-compile-level 0 ; bug#13787 "Depth of a recursive byte compilation.") @@ -1880,8 +1930,10 @@ If compilation is needed, this functions returns the result of "Compile a file of Lisp code named FILENAME into a file of byte code. The output file's name is generated by passing FILENAME to the function `byte-compile-dest-file' (which see). -With prefix arg (noninteractively: 2nd arg), LOAD the file after compiling. -The value is non-nil if there were no errors, nil if errors." +The value is non-nil if there were no errors, nil if errors. + +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) @@ -1910,8 +1962,11 @@ The value is non-nil if there were no errors, nil if errors." (let ((byte-compile-current-file filename) (byte-compile-current-group nil) (set-auto-coding-for-load t) + (byte-compile--seen-defvars nil) + (byte-compile--known-dynamic-vars + (byte-compile--load-dynvars (getenv "EMACS_DYNVARS_FILE"))) target-file input-buffer output-buffer - byte-compile-dest-file) + byte-compile-dest-file byte-compiler-error-flag) (setq target-file (byte-compile-dest-file filename)) (setq byte-compile-dest-file target-file) (with-current-buffer @@ -1964,7 +2019,7 @@ The value is non-nil if there were no errors, nil if errors." ;; (message "%s not compiled because of `no-byte-compile: %s'" ;; (byte-compile-abbreviate-file filename) ;; (with-current-buffer input-buffer no-byte-compile)) - (when (file-exists-p target-file) + (when (and target-file (file-exists-p target-file)) (message "%s deleted because of `no-byte-compile: %s'" (byte-compile-abbreviate-file target-file) (buffer-local-value 'no-byte-compile input-buffer)) @@ -1973,7 +2028,6 @@ The value is non-nil if there were no errors, nil if errors." 'no-byte-compile) (when byte-compile-verbose (message "Compiling %s..." filename)) - (setq byte-compiler-error-flag nil) ;; It is important that input-buffer not be current at this call, ;; so that the value of point set in input-buffer ;; within byte-compile-from-buffer lingers in that buffer. @@ -1989,36 +2043,54 @@ The value is non-nil if there were no errors, nil if errors." (with-current-buffer output-buffer (goto-char (point-max)) (insert "\n") ; aaah, unix. - (if (file-writable-p target-file) - ;; We must disable any code conversion here. - (progn - (let* ((coding-system-for-write 'no-conversion) - ;; Write to a tempfile so that if another Emacs - ;; process is trying to load target-file (eg in a - ;; parallel bootstrap), it does not risk getting a - ;; half-finished file. (Bug#4196) - (tempfile - (make-temp-file (expand-file-name target-file))) - (default-modes (default-file-modes)) - (temp-modes (logand default-modes #o600)) - (desired-modes (logand default-modes #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)) - (write-region (point-min) (point-max) tempfile nil 1) - ;; This has the intentional side effect that any - ;; hard-links to target-file continue to - ;; point to the old file (this makes it possible - ;; for installed files to share disk space with - ;; the build tree, without causing problems when - ;; emacs-lisp files in the build tree are - ;; recompiled). Previously this was accomplished by - ;; deleting target-file before writing it. - (rename-file tempfile target-file t)) - (or noninteractive (message "Wrote %s" target-file))) + (cond + ((null target-file) nil) ;We only wanted the warnings! + ((and (file-writable-p target-file) + ;; We attempt to create a temporary file in the + ;; target directory, so the target directory must be + ;; writable. + (file-writable-p + (file-name-directory + ;; Need to expand in case TARGET-FILE doesn't + ;; include a directory (Bug#45287). + (expand-file-name target-file)))) + ;; We must disable any code conversion here. + (let* ((coding-system-for-write 'no-conversion) + ;; Write to a tempfile so that if another Emacs + ;; process is trying to load target-file (eg in a + ;; parallel bootstrap), it does not risk getting a + ;; half-finished file. (Bug#4196) + (tempfile + (make-temp-file (expand-file-name target-file))) + (default-modes (default-file-modes)) + (temp-modes (logand default-modes #o600)) + (desired-modes (logand default-modes #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) + ;; This has the intentional side effect that any + ;; hard-links to target-file continue to + ;; point to the old file (this makes it possible + ;; for installed files to share disk space with + ;; the build tree, without causing problems when + ;; emacs-lisp files in the build tree are + ;; recompiled). Previously this was accomplished by + ;; deleting target-file before writing it. + (rename-file tempfile target-file t)) + (or noninteractive (message "Wrote %s" target-file))) + ((file-writable-p target-file) + ;; In case the target directory isn't writable (see e.g. Bug#44631), + ;; try writing to the output file directly. We must disable any + ;; code conversion here. + (let ((coding-system-for-write 'no-conversion)) + (with-file-modes (logand (default-file-modes) #o666) + (write-region (point-min) (point-max) target-file nil 1))) + (or noninteractive (message "Wrote %s" target-file))) + (t ;; This is just to give a better error message than write-region (let ((exists (file-exists-p target-file))) (signal (if exists 'file-error 'file-missing) @@ -2026,7 +2098,7 @@ The value is non-nil if there were no errors, nil if errors." (if exists "Cannot overwrite file" "Directory not writable or nonexistent") - target-file)))) + target-file))))) (kill-buffer (current-buffer))) (if (and byte-compile-generate-call-tree (or (eq t byte-compile-generate-call-tree) @@ -2034,8 +2106,17 @@ The value is non-nil if there were no errors, nil if errors." filename)))) (save-excursion (display-call-tree filename))) + (let ((gen-dynvars (getenv "EMACS_GENERATE_DYNVARS"))) + (when (and gen-dynvars (not (equal gen-dynvars "")) + byte-compile--seen-defvars) + (let ((dynvar-file (concat target-file ".dynvars"))) + (message "Generating %s" dynvar-file) + (with-temp-buffer + (dolist (var (delete-dups byte-compile--seen-defvars)) + (insert (format "%S\n" (cons var filename)))) + (write-region (point-min) (point-max) dynvar-file))))) (if load - (load target-file)) + (load target-file)) t)))) ;;; compiling a single function @@ -2139,55 +2220,13 @@ With argument ARG, insert value in current buffer after the form." ;; Make warnings about unresolved functions ;; give the end of the file as their position. (setq byte-compile-last-position (point-max)) - (byte-compile-warn-about-unresolved-functions)) - ;; Fix up the header at the front of the output - ;; if the buffer contains multibyte characters. - (and byte-compile-current-file - (with-current-buffer byte-compile--outbuffer - (byte-compile-fix-header byte-compile-current-file)))) + (byte-compile-warn-about-unresolved-functions))) byte-compile--outbuffer))) -(defun byte-compile-fix-header (_filename) - "If the current buffer has any multibyte characters, insert a version test." - (when (< (point-max) (position-bytes (point-max))) - (goto-char (point-min)) - ;; Find the comment that describes the version condition. - (search-forward "\n;;; This file uses") - (narrow-to-region (line-beginning-position) (point-max)) - ;; Find the first line of ballast semicolons. - (search-forward ";;;;;;;;;;") - (beginning-of-line) - (narrow-to-region (point-min) (point)) - (let ((old-header-end (point)) - (minimum-version "23") - delta) - (delete-region (point-min) (point-max)) - (insert - ";;; This file contains utf-8 non-ASCII characters,\n" - ";;; and so cannot be loaded into Emacs 22 or earlier.\n" - ;; Have to check if emacs-version is bound so that this works - ;; in files loaded early in loadup.el. - "(and (boundp 'emacs-version)\n" - ;; If there is a name at the end of emacs-version, - ;; don't try to check the version number. - " (< (aref emacs-version (1- (length emacs-version))) ?A)\n" - (format " (string-lessp emacs-version \"%s\")\n" minimum-version) - ;; Because the header must fit in a fixed width, we cannot - ;; insert arbitrary-length file names (Bug#11585). - " (error \"`%s' was compiled for " - (format "Emacs %s or later\" #$))\n\n" minimum-version)) - ;; Now compensate for any change in size, to make sure all - ;; positions in the file remain valid. - (setq delta (- (point-max) old-header-end)) - (goto-char (point-max)) - (widen) - (delete-char delta)))) - (defun byte-compile-insert-header (_filename outbuffer) "Insert a header at the start of OUTBUFFER. Call from the source buffer." - (let ((dynamic-docstrings byte-compile-dynamic-docstrings) - (dynamic byte-compile-dynamic) + (let ((dynamic byte-compile-dynamic) (optimize byte-optimize)) (with-current-buffer outbuffer (goto-char (point-min)) @@ -2201,7 +2240,19 @@ Call from the source buffer." ;; 0 string ;ELC GNU Emacs Lisp compiled file, ;; >4 byte x version %d (insert - ";ELC" 23 "\000\000\000\n" + ";ELC" + (let ((version + (if (zerop emacs-minor-version) + ;; Let's allow silently loading into Emacs-27 + ;; files compiled with Emacs-28.0.NN since the two can + ;; be almost identical (e.g. right after cutting the + ;; release branch) and people running the development + ;; branch can be presumed to know that it's risky anyway. + (1- emacs-major-version) emacs-major-version))) + ;; Make sure the version is a plain byte that doesn't end the comment! + (cl-assert (and (> version 13) (< version 128))) + version) + "\000\000\000\n" ";;; Compiled\n" ";;; in Emacs version " emacs-version "\n" ";;; with" @@ -2213,19 +2264,7 @@ Call from the source buffer." ".\n" (if dynamic ";;; Function definitions are lazy-loaded.\n" "") - "\n;;; This file uses " - (if dynamic-docstrings - "dynamic docstrings, first added in Emacs 19.29" - "opcodes that do not exist in Emacs 18") - ".\n\n" - ;; Note that byte-compile-fix-header may change this. - ";;; This file does not contain utf-8 non-ASCII characters,\n" - ";;; and so can be loaded in Emacs versions earlier than 23.\n\n" - ;; Insert semicolons as ballast, so that byte-compile-fix-header - ;; can delete them so as to keep the buffer positions - ;; constant for the actual compiled code. - ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n" - ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n\n")))) + "\n\n")))) (defun byte-compile-output-file-form (form) ;; Write the given form to the output buffer, being careful of docstrings @@ -2449,7 +2488,8 @@ list that represents a doc string reference. (delq (assq funsym byte-compile-unresolved-functions) byte-compile-unresolved-functions))))) (if (stringp (nth 3 form)) - form + (prog1 form + (byte-compile-docstring-length-warn form)) ;; No doc string, so we can compile this as a normal form. (byte-compile-keep-pending form 'byte-compile-normal-call))) @@ -2465,8 +2505,10 @@ list that represents a doc string reference. (when (memq sym byte-compile-lexical-variables) (setq byte-compile-lexical-variables (delq sym byte-compile-lexical-variables)) - (byte-compile-warn "Variable `%S' declared after its first use" sym)) - (push sym byte-compile-bound-variables)) + (when (byte-compile-warning-enabled-p 'lexical sym) + (byte-compile-warn "Variable `%S' declared after its first use" sym))) + (push sym byte-compile-bound-variables) + (push sym byte-compile--seen-defvars)) (defun byte-compile-file-form-defvar (form) (let ((sym (nth 1 form))) @@ -2476,6 +2518,7 @@ list that represents a doc string reference. (if (and (null (cddr form)) ;No `value' provided. (eq (car form) 'defvar)) ;Just a declaration. nil + (byte-compile-docstring-length-warn form) (cond ((consp (nth 2 form)) (setq form (copy-sequence form)) (setcar (cdr (cdr form)) @@ -2499,6 +2542,7 @@ list that represents a doc string reference. (if (byte-compile-warning-enabled-p 'suspicious) (byte-compile-warn "Alias for `%S' should be declared before its referent" newname))))) + (byte-compile-docstring-length-warn form) (byte-compile-keep-pending form)) (put 'custom-declare-variable 'byte-hunk-handler @@ -2511,8 +2555,7 @@ list that represents a doc string reference. (put 'require 'byte-hunk-handler 'byte-compile-file-form-require) (defun byte-compile-file-form-require (form) (let ((args (mapcar 'eval (cdr form))) - (hist-orig load-history) - hist-new prov-cons) + hist-new prov-cons) (apply 'require args) ;; Record the functions defined by the require in `byte-compile-new-defuns'. @@ -2525,21 +2568,7 @@ list that represents a doc string reference. (dolist (x (car hist-new)) (when (and (consp x) (memq (car x) '(defun t))) - (push (cdr x) byte-compile-new-defuns)))) - - (when (byte-compile-warning-enabled-p 'cl-functions) - ;; Detect (require 'cl) in a way that works even if cl is already loaded. - (if (member (car args) '("cl" cl)) - (progn - (byte-compile-warn "cl package required at runtime") - (byte-compile-disable-warning 'cl-functions)) - ;; We may have required something that causes cl to be loaded, eg - ;; the uncompiled version of a file that requires cl when compiling. - (setq hist-new load-history) - (while (and (not byte-compile-cl-functions) - hist-new (not (eq hist-new hist-orig))) - (and (byte-compile-cl-file-p (car (pop hist-new))) - (byte-compile-find-cl-functions)))))) + (push (cdr x) byte-compile-new-defuns))))) (byte-compile-keep-pending form 'byte-compile-normal-call)) (put 'progn 'byte-hunk-handler 'byte-compile-file-form-progn) @@ -2576,7 +2605,8 @@ list that represents a doc string reference. ;; and similar macros cleaner. (put 'eval 'byte-hunk-handler 'byte-compile-file-form-eval) (defun byte-compile-file-form-eval (form) - (if (eq (car-safe (nth 1 form)) 'quote) + (if (and (eq (car-safe (nth 1 form)) 'quote) + (equal (nth 2 form) lexical-binding)) (nth 1 (nth 1 form)) (byte-compile-keep-pending form))) @@ -2872,6 +2902,16 @@ If FORM is a lambda or a macro, byte-compile it as a function." (ash nonrest 8) (ash rest 7))))) +(defun byte-compile--warn-lexical-dynamic (var context) + (when (byte-compile-warning-enabled-p 'lexical-dynamic var) + (byte-compile-warn + "`%s' lexically bound in %s here but declared dynamic in: %s" + var context + (mapconcat #'identity + (mapcan (lambda (v) (and (eq var (car v)) + (list (cdr v)))) + byte-compile--known-dynamic-vars) + ", ")))) (defun byte-compile-lambda (fun &optional add-lambda reserved-csts) "Byte-compile a lambda-expression and return a valid function. @@ -2886,6 +2926,7 @@ for symbols generated by the byte compiler itself." (unless (eq 'lambda (car-safe fun)) (error "Not a lambda list: %S" fun)) (byte-compile-set-symbol-position 'lambda)) + (byte-compile-docstring-length-warn fun) (byte-compile-check-lambda-list (nth 1 fun)) (let* ((arglist (nth 1 fun)) (arglistvars (byte-compile-arglist-vars arglist)) @@ -2900,6 +2941,10 @@ for symbols generated by the byte compiler itself." (if (cdr body) (setq body (cdr body)))))) (int (assq 'interactive body))) + (when lexical-binding + (dolist (var arglistvars) + (when (assq var byte-compile--known-dynamic-vars) + (byte-compile--warn-lexical-dynamic var 'lambda)))) ;; Process the interactive spec. (when int (byte-compile-set-symbol-position 'interactive) @@ -3189,7 +3234,7 @@ for symbols generated by the byte compiler itself." run-hook-with-args-until-failure)) (pcase (cdr form) (`(',var . ,_) - (when (assq var byte-compile-lexical-variables) + (when (memq var byte-compile-lexical-variables) (byte-compile-report-error (format-message "%s cannot use lexical var `%s'" fn var)))))) ;; Warn about using obsolete hooks. @@ -3215,7 +3260,8 @@ for symbols generated by the byte compiler itself." (t ".")))) (if (eq (car-safe (symbol-function (car form))) 'macro) (byte-compile-report-error - (format "Forgot to expand macro %s in %S" (car form) form))) + (format "`%s' defined after use in %S (missing `require' of a library file?)" + (car form) form))) (if (and handler ;; Make sure that function exists. (and (functionp handler) @@ -3224,9 +3270,7 @@ for symbols generated by the byte compiler itself." ;; differently now). (not (eq handler 'cl-byte-compile-compiler-macro)))) (funcall handler form) - (byte-compile-normal-call form)) - (if (byte-compile-warning-enabled-p 'cl-functions) - (byte-compile-cl-warn form)))) + (byte-compile-normal-call form)))) ((and (byte-code-function-p (car form)) (memq byte-optimize '(t lap))) (byte-compile-unfold-bcf form)) @@ -3398,10 +3442,11 @@ for symbols generated by the byte compiler itself." (and od (not (memq var byte-compile-not-obsolete-vars)) (not (memq var byte-compile-global-not-obsolete-vars)) - (or (pcase (nth 1 od) - ('set (not (eq access-type 'reference))) - ('get (eq access-type 'reference)) - (_ t))))) + (not (memq var byte-compile-lexical-variables)) + (pcase (nth 1 od) + ('set (not (eq access-type 'reference))) + ('get (eq access-type 'reference)) + (_ t)))) (byte-compile-warn-obsolete var)))) (defsubst byte-compile-dynamic-variable-op (base-op var) @@ -3417,6 +3462,27 @@ for symbols generated by the byte compiler itself." (push var byte-compile-bound-variables) (byte-compile-dynamic-variable-op 'byte-varbind var)) +(defun byte-compile-free-vars-warn (var &optional assignment) + "Warn if symbol VAR refers to a free variable. +VAR must not be lexically bound. +If optional argument ASSIGNMENT is non-nil, this is treated as an +assignment (i.e. `setq'). " + (unless (or (not (byte-compile-warning-enabled-p 'free-vars var)) + (boundp var) + (memq var byte-compile-bound-variables) + (memq var (if assignment + byte-compile-free-assignments + byte-compile-free-references))) + (let* ((varname (prin1-to-string var)) + (desc (if assignment "assignment" "reference")) + (suggestions (help-uni-confusable-suggestions varname))) + (byte-compile-warn "%s to free variable `%s'%s" + desc varname + (if suggestions (concat "\n " suggestions) ""))) + (push var (if assignment + byte-compile-free-assignments + byte-compile-free-references)))) + (defun byte-compile-variable-ref (var) "Generate code to push the value of the variable VAR on the stack." (byte-compile-check-variable var 'reference) @@ -3425,15 +3491,7 @@ for symbols generated by the byte compiler itself." ;; VAR is lexically bound (byte-compile-stack-ref (cdr lex-binding)) ;; VAR is dynamically bound - (unless (or (not (byte-compile-warning-enabled-p 'free-vars var)) - (boundp var) - (memq var byte-compile-bound-variables) - (memq var byte-compile-free-references)) - (let* ((varname (prin1-to-string var)) - (suggestions (help-uni-confusable-suggestions varname))) - (byte-compile-warn "reference to free variable `%s'%s" varname - (if suggestions (concat "\n " suggestions) ""))) - (push var byte-compile-free-references)) + (byte-compile-free-vars-warn var) (byte-compile-dynamic-variable-op 'byte-varref var)))) (defun byte-compile-variable-set (var) @@ -3444,15 +3502,7 @@ for symbols generated by the byte compiler itself." ;; VAR is lexically bound. (byte-compile-stack-set (cdr lex-binding)) ;; VAR is dynamically bound. - (unless (or (not (byte-compile-warning-enabled-p 'free-vars var)) - (boundp var) - (memq var byte-compile-bound-variables) - (memq var byte-compile-free-assignments)) - (let* ((varname (prin1-to-string var)) - (suggestions (help-uni-confusable-suggestions varname))) - (byte-compile-warn "assignment to free variable `%s'%s" varname - (if suggestions (concat "\n " suggestions) ""))) - (push var byte-compile-free-assignments)) + (byte-compile-free-vars-warn var t) (byte-compile-dynamic-variable-op 'byte-varset var)))) (defmacro byte-compile-get-constant (const) @@ -3463,7 +3513,7 @@ for symbols generated by the byte compiler itself." (if (equal-including-properties (car elt) ,const) (setq result elt))) result) - (assq ,const byte-compile-constants)) + (assoc ,const byte-compile-constants #'eql)) (car (setq byte-compile-constants (cons (list ,const) byte-compile-constants))))) @@ -3491,7 +3541,7 @@ the opcode to be used. If function is a list, the first element is the function and the second element is the bytecode-symbol. The second element may be nil, meaning there is no opcode. COMPILE-HANDLER is the function to use to compile this byte-op, or -may be the abbreviations 0, 1, 2, 3, 0-1, or 1-2. +may be the abbreviations 0, 1, 2, 2-and, 3, 0-1, 1-2, 1-3, or 2-3. If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (let (opcode) (if (symbolp function) @@ -3510,6 +3560,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (0-1 . byte-compile-zero-or-one-arg) (1-2 . byte-compile-one-or-two-args) (2-3 . byte-compile-two-or-three-args) + (1-3 . byte-compile-one-to-three-args) ))) compile-handler (intern (concat "byte-compile-" @@ -3620,10 +3671,10 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-defop-compiler (% byte-rem) 2) (byte-defop-compiler aset 3) -(byte-defop-compiler max byte-compile-associative) -(byte-defop-compiler min byte-compile-associative) -(byte-defop-compiler (+ byte-plus) byte-compile-associative) -(byte-defop-compiler (* byte-mult) byte-compile-associative) +(byte-defop-compiler max byte-compile-min-max) +(byte-defop-compiler min byte-compile-min-max) +(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) @@ -3694,6 +3745,13 @@ These implicitly `and' together a bunch of two-arg bytecodes." ((= len 4) (byte-compile-three-args form)) (t (byte-compile-subr-wrong-args form "2-3"))))) +(defun byte-compile-one-to-three-args (form) + (let ((len (length form))) + (cond ((= len 2) (byte-compile-three-args (append form '(nil nil)))) + ((= len 3) (byte-compile-three-args (append form '(nil)))) + ((= len 4) (byte-compile-three-args form)) + (t (byte-compile-subr-wrong-args form "1-3"))))) + (defun byte-compile-noop (_form) (byte-compile-constant nil)) @@ -3763,30 +3821,36 @@ discarding." (if byte-compile--for-effect (setq byte-compile--for-effect nil) (byte-compile-out 'byte-constant (nth 1 form)))) -;; Compile a function that accepts one or more args and is right-associative. -;; We do it by left-associativity so that the operations -;; are done in the same order as in interpreted code. -;; We treat the one-arg case, as in (+ x), like (+ x 0). -;; in order to convert markers to numbers, and trigger expected errors. -(defun byte-compile-associative (form) +;; Compile a pure function that accepts zero or more numeric arguments +;; and has an opcode for the binary case. +;; Single-argument calls are assumed to be numeric identity and are +;; compiled as (* x 1) in order to convert markers to numbers and +;; trigger type errors. +(defun byte-compile-variadic-numeric (form) + (pcase (length form) + (1 + ;; No args: use the identity value for the operation. + (byte-compile-constant (eval form))) + (2 + ;; One arg: compile (OP x) as (* x 1). This is identity for + ;; all numerical values including -0.0, infinities and NaNs. + (byte-compile-form (nth 1 form)) + (byte-compile-constant 1) + (byte-compile-out (get '* 'byte-opcode) 0)) + (3 + (byte-compile-form (nth 1 form)) + (byte-compile-form (nth 2 form)) + (byte-compile-out (get (car form) 'byte-opcode) 0)) + (_ + ;; >2 args: compile as a single function call. + (byte-compile-normal-call form)))) + +(defun byte-compile-min-max (form) + "Byte-compile calls to `min' or `max'." (if (cdr form) - (let ((opcode (get (car form) 'byte-opcode)) - args) - (if (and (< 3 (length form)) - (memq opcode (list (get '+ 'byte-opcode) - (get '* 'byte-opcode)))) - ;; Don't use binary operations for > 2 operands, as that - ;; may cause overflow/truncation in float operations. - (byte-compile-normal-call form) - (setq args (copy-sequence (cdr form))) - (byte-compile-form (car args)) - (setq args (cdr args)) - (or args (setq args '(0) - opcode (get '+ 'byte-opcode))) - (dolist (arg args) - (byte-compile-form arg) - (byte-compile-out opcode 0)))) - (byte-compile-constant (eval form)))) + (byte-compile-variadic-numeric form) + ;; No args: warn and emit code that raises an error when executed. + (byte-compile-normal-call form))) ;; more complicated compiler macros @@ -3801,7 +3865,7 @@ discarding." (byte-defop-compiler indent-to) (byte-defop-compiler insert) (byte-defop-compiler-1 function byte-compile-function-form) -(byte-defop-compiler-1 - byte-compile-minus) +(byte-defop-compiler (- byte-diff) byte-compile-minus) (byte-defop-compiler (/ byte-quo) byte-compile-quo) (byte-defop-compiler nconc) @@ -3868,30 +3932,17 @@ discarding." ((byte-compile-normal-call form))))) (defun byte-compile-minus (form) - (let ((len (length form))) - (cond - ((= 1 len) (byte-compile-constant 0)) - ((= 2 len) - (byte-compile-form (cadr form)) - (byte-compile-out 'byte-negate 0)) - ((= 3 len) - (byte-compile-form (nth 1 form)) - (byte-compile-form (nth 2 form)) - (byte-compile-out 'byte-diff 0)) - ;; Don't use binary operations for > 2 operands, as that may - ;; cause overflow/truncation in float operations. - (t (byte-compile-normal-call form))))) + (if (/= (length form) 2) + (byte-compile-variadic-numeric form) + (byte-compile-form (cadr form)) + (byte-compile-out 'byte-negate 0))) (defun byte-compile-quo (form) - (let ((len (length form))) - (cond ((< len 2) - (byte-compile-subr-wrong-args form "1 or more")) - ((= len 3) - (byte-compile-two-args form)) - (t - ;; Don't use binary operations for > 2 operands, as that - ;; may cause overflow/truncation in float operations. - (byte-compile-normal-call form))))) + (if (= (length form) 3) + (byte-compile-two-args form) + ;; N-ary `/' is not the left-reduction of binary `/' because if any + ;; argument is a float, then everything is done in floating-point. + (byte-compile-normal-call form))) (defun byte-compile-nconc (form) (let ((len (length form))) @@ -4418,6 +4469,8 @@ Return non-nil if the TOS value was popped." ;; VAR is a simple stack-allocated lexical variable. (progn (push (assq var init-lexenv) byte-compile--lexical-environment) + (when (assq var byte-compile--known-dynamic-vars) + (byte-compile--warn-lexical-dynamic var 'let)) nil) ;; VAR should be dynamically bound. (while (assq var byte-compile--lexical-environment) @@ -4534,96 +4587,25 @@ binding slots have been popped." ;; (byte-defop-compiler-1 save-window-excursion) ;Obsolete: now a macro. ;; (byte-defop-compiler-1 with-output-to-temp-buffer) ;Obsolete: now a macro. -(defvar byte-compile--use-old-handlers nil - "If nil, use new byte codes introduced in Emacs-24.4.") - (defun byte-compile-catch (form) (byte-compile-form (car (cdr form))) - (if (not byte-compile--use-old-handlers) - (let ((endtag (byte-compile-make-tag))) - (byte-compile-goto 'byte-pushcatch endtag) - (byte-compile-body (cddr form) nil) - (byte-compile-out 'byte-pophandler) - (byte-compile-out-tag endtag)) - (pcase (cddr form) - (`(:fun-body ,f) - (byte-compile-form `(list 'funcall ,f))) - (body - (byte-compile-push-constant - (byte-compile-top-level (cons 'progn body) byte-compile--for-effect)))) - (byte-compile-out 'byte-catch 0))) + (let ((endtag (byte-compile-make-tag))) + (byte-compile-goto 'byte-pushcatch endtag) + (byte-compile-body (cddr form) nil) + (byte-compile-out 'byte-pophandler) + (byte-compile-out-tag endtag))) (defun byte-compile-unwind-protect (form) (pcase (cddr form) (`(:fun-body ,f) - (byte-compile-form - (if byte-compile--use-old-handlers `(list (list 'funcall ,f)) f))) + (byte-compile-form f)) (handlers - (if byte-compile--use-old-handlers - (byte-compile-push-constant - (byte-compile-top-level-body handlers t)) - (byte-compile-form `#'(lambda () ,@handlers))))) + (byte-compile-form `#'(lambda () ,@handlers)))) (byte-compile-out 'byte-unwind-protect 0) (byte-compile-form-do-effect (car (cdr form))) (byte-compile-out 'byte-unbind 1)) (defun byte-compile-condition-case (form) - (if byte-compile--use-old-handlers - (byte-compile-condition-case--old form) - (byte-compile-condition-case--new form))) - -(defun byte-compile-condition-case--old (form) - (let* ((var (nth 1 form)) - (fun-bodies (eq var :fun-body)) - (byte-compile-bound-variables - (if (and var (not fun-bodies)) - (cons var byte-compile-bound-variables) - byte-compile-bound-variables))) - (byte-compile-set-symbol-position 'condition-case) - (unless (symbolp var) - (byte-compile-warn - "`%s' is not a variable-name or nil (in condition-case)" var)) - (if fun-bodies (setq var (make-symbol "err"))) - (byte-compile-push-constant var) - (if fun-bodies - (byte-compile-form `(list 'funcall ,(nth 2 form))) - (byte-compile-push-constant - (byte-compile-top-level (nth 2 form) byte-compile--for-effect))) - (let ((compiled-clauses - (mapcar - (lambda (clause) - (let ((condition (car clause))) - (cond ((not (or (symbolp condition) - (and (listp condition) - (let ((ok t)) - (dolist (sym condition) - (if (not (symbolp sym)) - (setq ok nil))) - ok)))) - (byte-compile-warn - "`%S' is not a condition name or list of such (in condition-case)" - condition)) - ;; (not (or (eq condition 't) - ;; (and (stringp (get condition 'error-message)) - ;; (consp (get condition - ;; 'error-conditions))))) - ;; (byte-compile-warn - ;; "`%s' is not a known condition name - ;; (in condition-case)" - ;; condition)) - ) - (if fun-bodies - `(list ',condition (list 'funcall ,(cadr clause) ',var)) - (cons condition - (byte-compile-top-level-body - (cdr clause) byte-compile--for-effect))))) - (cdr (cdr (cdr form)))))) - (if fun-bodies - (byte-compile-form `(list ,@compiled-clauses)) - (byte-compile-push-constant compiled-clauses))) - (byte-compile-out 'byte-condition-case 0))) - -(defun byte-compile-condition-case--new (form) (let* ((var (nth 1 form)) (body (nth 2 form)) (depth byte-compile-depth) @@ -4726,6 +4708,7 @@ binding slots have been popped." (byte-compile-warning-enabled-p 'lexical (nth 1 form))) (byte-compile-warn "global/dynamic var `%s' lacks a prefix" (nth 1 form))) + (byte-compile-docstring-length-warn form) (let ((fun (nth 0 form)) (var (nth 1 form)) (value (nth 2 form)) @@ -4800,6 +4783,7 @@ binding slots have been popped." ;; - `arg' is the expression to which it is defined. ;; - `rest' is the rest of the arguments. (`(,_ ',name ,arg . ,rest) + (byte-compile-docstring-length-warn form) (pcase-let* ;; `macro' is non-nil if it defines a macro. ;; `fun' is the function part of `arg' (defaults to `arg'). @@ -4861,6 +4845,14 @@ binding slots have been popped." (defun byte-compile-form-make-variable-buffer-local (form) (byte-compile-keep-pending form 'byte-compile-normal-call)) +;; Make `make-local-variable' declare the variable locally +;; dynamic - this suppresses some unnecessary warnings +(byte-defop-compiler-1 make-local-variable + byte-compile-make-local-variable) +(defun byte-compile-make-local-variable (form) + (pcase form (`(,_ ',var) (byte-compile--declare-var var))) + (byte-compile-normal-call form)) + (put 'function-put 'byte-hunk-handler 'byte-compile-define-symbol-prop) (put 'define-symbol-prop 'byte-hunk-handler 'byte-compile-define-symbol-prop) (defun byte-compile-define-symbol-prop (form) @@ -5309,6 +5301,8 @@ and corresponding effects." byte-compile-variable-ref)))) nil) +(make-obsolete-variable 'bytecomp-load-hook + "use `with-eval-after-load' instead." "28.1") (run-hooks 'bytecomp-load-hook) ;;; bytecomp.el ends here diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 5c76e47c377..e79583974a8 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -462,20 +462,7 @@ places where they originally did not directly appear." ;; and may be an invalid expression (e.g. ($# . 678)). (cdr forms))))) - ;condition-case - ((and `(condition-case ,var ,protected-form . ,handlers) - (guard byte-compile--use-old-handlers)) - (let ((newform (cconv--convert-function - () (list protected-form) env form))) - `(condition-case :fun-body ,newform - ,@(mapcar (lambda (handler) - (list (car handler) - (cconv--convert-function - (list (or var cconv--dummy-var)) - (cdr handler) env form))) - handlers)))) - - ; condition-case with new byte-codes. + ; condition-case (`(condition-case ,var ,protected-form . ,handlers) `(condition-case ,var ,(cconv-convert protected-form env extend) @@ -496,10 +483,8 @@ places where they originally did not directly appear." `((let ((,var (list ,var))) ,@body)))))) handlers)))) - (`(,(and head (or (and 'catch (guard byte-compile--use-old-handlers)) - 'unwind-protect)) - ,form . ,body) - `(,head ,(cconv-convert form env extend) + (`(unwind-protect ,form . ,body) + `(unwind-protect ,(cconv-convert form env extend) :fun-body ,(cconv--convert-function () body env form))) (`(setq . ,forms) ; setq special form @@ -718,15 +703,6 @@ and updates the data stored in ENV." (`(quote . ,_) nil) ; quote form (`(function . ,_) nil) ; same as quote - ((and `(condition-case ,var ,protected-form . ,handlers) - (guard byte-compile--use-old-handlers)) - ;; FIXME: The bytecode for condition-case forces us to wrap the - ;; form and handlers in closures. - (cconv--analyze-function () (list protected-form) env form) - (dolist (handler handlers) - (cconv--analyze-function (if var (list var)) (cdr handler) - env form))) - (`(condition-case ,var ,protected-form . ,handlers) (cconv-analyze-form protected-form env) (when (and var (symbolp var) (byte-compile-not-lexical-var-p var)) @@ -741,9 +717,7 @@ and updates the data stored in ENV." form "variable")))) ;; FIXME: The bytecode for unwind-protect forces us to wrap the unwind. - (`(,(or (and 'catch (guard byte-compile--use-old-handlers)) - 'unwind-protect) - ,form . ,body) + (`(unwind-protect ,form . ,body) (cconv-analyze-form form env) (cconv--analyze-function () body env form)) diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el index d2d9807c0a0..7d760ffc57f 100644 --- a/lisp/emacs-lisp/chart.el +++ b/lisp/emacs-lisp/chart.el @@ -4,7 +4,7 @@ ;; Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> -;; Version: 0.2 +;; Old-Version: 0.2 ;; Keywords: OO, chart, graph ;; This file is part of GNU Emacs. @@ -67,9 +67,8 @@ (define-obsolete-variable-alias 'chart-map 'chart-mode-map "24.1") (defvar chart-mode-map (make-sparse-keymap) "Keymap used in chart mode.") -(defvar chart-local-object nil +(defvar-local chart-local-object nil "Local variable containing the locally displayed chart object.") -(make-variable-buffer-local 'chart-local-object) (defvar chart-face-color-list '("red" "green" "blue" "cyan" "yellow" "purple") @@ -105,9 +104,7 @@ Useful if new Emacs is used on B&W display.") (car cl) "white")) (set-face-foreground nf "black") - (if (and chart-face-use-pixmaps - pl - (fboundp 'set-face-background-pixmap)) + (if (and chart-face-use-pixmaps pl) (condition-case nil (set-face-background-pixmap nf (car pl)) (error (message "Cannot set background pixmap %s" (car pl))))) @@ -122,7 +119,7 @@ too much in text characters anyways.") (define-derived-mode chart-mode special-mode "Chart" "Define a mode in Emacs for displaying a chart." (buffer-disable-undo) - (set (make-local-variable 'font-lock-global-modes) nil) + (setq-local font-lock-global-modes nil) (font-lock-mode -1) ;Isn't it off already? --Stef ) @@ -335,7 +332,8 @@ Automatically compensates for direction." (cl-defmethod chart-axis-draw ((a chart-axis-names) &optional dir margin zone _start _end) "Draw axis information based upon A range to be spread along the edge. Optional argument DIR is the direction of the chart. -Optional arguments MARGIN, ZONE, START and END specify boundaries of the drawing." +Optional arguments MARGIN, ZONE, START and END specify boundaries +of the drawing." (cl-call-next-method) ;; We prefer about 5 spaces between each value (let* ((i 0) diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el index bea9df9e2b2..7c2b23b4ec4 100644 --- a/lisp/emacs-lisp/check-declare.el +++ b/lisp/emacs-lisp/check-declare.el @@ -1,8 +1,9 @@ -;;; check-declare.el --- Check declare-function statements +;;; check-declare.el --- Check declare-function statements -*- lexical-binding: t; -*- ;; Copyright (C) 2007-2021 Free Software Foundation, Inc. ;; Author: Glenn Morris <rgm@gnu.org> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: lisp, tools, maint ;; This file is part of GNU Emacs. @@ -248,7 +249,7 @@ TYPE is a string giving the nature of the error. Optional LINE is the claim's line number; otherwise, search for the claim. Display warning in `check-declare-warning-buffer'." (let ((warning-prefix-function - (lambda (level entry) + (lambda (_level entry) (insert (format "%s:%d:" (file-relative-name file) (or line 0))) entry)) (warning-fill-prefix " ")) diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index d82e86196ac..9722792a5a5 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1997-1998, 2001-2021 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> -;; Version: 0.6.2 +;; Old-Version: 0.6.2 ;; Keywords: docs, maint, lisp ;; This file is part of GNU Emacs. @@ -37,7 +37,6 @@ ;; documentation whenever you evaluate Lisp code with C-M-x ;; or [menu-bar emacs-lisp eval-buffer]. Additional key-bindings ;; are also provided under C-c ? KEY -;; (require 'checkdoc) ;; (add-hook 'emacs-lisp-mode-hook 'checkdoc-minor-mode) ;; ;; Using `checkdoc': @@ -170,6 +169,7 @@ ;;; Code: (defvar checkdoc-version "0.6.2" "Release version of checkdoc you are currently running.") +(make-obsolete-variable 'checkdoc-version nil "28.1") (require 'cl-lib) (require 'help-mode) ;; for help-xref-info-regexp @@ -241,7 +241,12 @@ system. Possible values are: defun - Spell-check when style checking a single defun. buffer - Spell-check when style checking the whole buffer. interactive - Spell-check during any interactive check. - t - Always spell-check." + t - Always spell-check. + +There is a list of Lisp-specific words which checkdoc will +install into Ispell on the fly, but only if Ispell is not already +running. Use `ispell-kill-ispell' to make checkdoc restart it +with these words enabled." :type '(choice (const nil) (const defun) (const buffer) @@ -1248,13 +1253,8 @@ checking of documentation strings. ;;; Subst utils ;; -(defsubst checkdoc-run-hooks (hookvar &rest args) - "Run hooks in HOOKVAR with ARGS." - (if (fboundp 'run-hook-with-args-until-success) - (apply #'run-hook-with-args-until-success hookvar args) - ;; This method was similar to above. We ignore the warning - ;; since we will use the above for future Emacs versions - (apply #'run-hook-with-args hookvar args))) +(define-obsolete-function-alias 'checkdoc-run-hooks + #'run-hook-with-args-until-success "28.1") (defsubst checkdoc-create-common-verbs-regexp () "Rebuild the contents of `checkdoc-common-verbs-regexp'." @@ -1577,7 +1577,8 @@ mouse-[0-3]\\)\\)\\>")) ;; a prefix. (let ((disambiguate (completing-read - "Disambiguating Keyword (default variable): " + (format-prompt "Disambiguating Keyword" + "variable") '(("function") ("command") ("variable") ("option") ("symbol")) nil t nil nil "variable"))) @@ -1872,7 +1873,7 @@ Replace with \"%s\"? " original replace) ;; and reliance on the Ispell program. (checkdoc-ispell-docstring-engine e take-notes) ;; User supplied checks - (save-excursion (checkdoc-run-hooks 'checkdoc-style-functions fp e)) + (save-excursion (run-hook-with-args-until-success 'checkdoc-style-functions fp e)) ;; Done! ))) @@ -2361,7 +2362,9 @@ Code:, and others referenced in the style guide." (checkdoc-create-error (format "The footer should be: (provide '%s)\\n;;; %s%s ends here" fn fn fe) - (1- (point-max)) (point-max))))) + ;; The buffer may be empty. + (max (point-min) (1- (point-max))) + (point-max))))) err)) ;; The below checks will not return errors if the user says NO @@ -2383,7 +2386,7 @@ Code:, and others referenced in the style guide." err (or ;; Generic Full-file checks (should be comment related) - (checkdoc-run-hooks 'checkdoc-comment-style-functions) + (run-hook-with-args-until-success 'checkdoc-comment-style-functions) err)) ;; Done with full file comment checks err))) @@ -2592,7 +2595,7 @@ This function will not modify `match-data'." ;; going on. (if checkdoc-bouncy-flag (message "%s -> done" question)) (delete-region start end) - (insert replacewith) + (insert-before-markers replacewith) (if checkdoc-bouncy-flag (sit-for 0)) (setq ret t))) (delete-overlay o) @@ -2642,7 +2645,7 @@ function called to create the messages." (goto-char (point-max)) (let ((inhibit-read-only t)) (insert "\n\n\C-l\n*** " label ": " - check-type " V " checkdoc-version))))) + check-type))))) (defun checkdoc-error (point msg) "Store POINT and MSG as errors in the checkdoc diagnostic buffer." diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 9c9da4a0f90..28ce6b115a4 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -72,8 +72,7 @@ strings case-insensitively." (cond ((eq x y) t) ((stringp x) (and (stringp y) (= (length x) (length y)) - (or (string-equal x y) - (string-equal (downcase x) (downcase y))))) ;Lazy but simple! + (eq (compare-strings x nil nil y nil nil t) t))) ((numberp x) (and (numberp y) (= x y))) ((consp x) @@ -202,15 +201,18 @@ the elements themselves. ;;;###autoload (defun cl-some (cl-pred cl-seq &rest cl-rest) - "Return true if PREDICATE is true of any element of SEQ or SEQs. -If so, return the true (non-nil) value returned by PREDICATE. + "Say whether PREDICATE is true for any element in the SEQ sequences. +More specifically, the return value of this function will be the +same as the first return value of PREDICATE where PREDICATE has a +non-nil value. + \n(fn PREDICATE SEQ...)" (if (or cl-rest (nlistp cl-seq)) (catch 'cl-some - (apply 'cl-map nil - (function (lambda (&rest cl-x) - (let ((cl-res (apply cl-pred cl-x))) - (if cl-res (throw 'cl-some cl-res))))) + (apply #'cl-map nil + (lambda (&rest cl-x) + (let ((cl-res (apply cl-pred cl-x))) + (if cl-res (throw 'cl-some cl-res)))) cl-seq cl-rest) nil) (let ((cl-x nil)) (while (and cl-seq (not (setq cl-x (funcall cl-pred (pop cl-seq)))))) @@ -222,9 +224,9 @@ If so, return the true (non-nil) value returned by PREDICATE. \n(fn PREDICATE SEQ...)" (if (or cl-rest (nlistp cl-seq)) (catch 'cl-every - (apply 'cl-map nil - (function (lambda (&rest cl-x) - (or (apply cl-pred cl-x) (throw 'cl-every nil)))) + (apply #'cl-map nil + (lambda (&rest cl-x) + (or (apply cl-pred cl-x) (throw 'cl-every nil))) cl-seq cl-rest) t) (while (and cl-seq (funcall cl-pred (car cl-seq))) (setq cl-seq (cdr cl-seq))) @@ -247,14 +249,13 @@ If so, return the true (non-nil) value returned by PREDICATE. (or cl-base (setq cl-base (copy-sequence [0]))) (map-keymap - (function - (lambda (cl-key cl-bind) - (aset cl-base (1- (length cl-base)) cl-key) - (if (keymapp cl-bind) - (cl--map-keymap-recursively - cl-func-rec cl-bind - (vconcat cl-base (list 0))) - (funcall cl-func-rec cl-base cl-bind)))) + (lambda (cl-key cl-bind) + (aset cl-base (1- (length cl-base)) cl-key) + (if (keymapp cl-bind) + (cl--map-keymap-recursively + cl-func-rec cl-bind + (vconcat cl-base (list 0))) + (funcall cl-func-rec cl-base cl-bind))) cl-map)) ;;;###autoload @@ -553,10 +554,9 @@ too large if positive or too small if negative)." (seq-subseq seq start end)) ;;;###autoload -(defun cl-concatenate (type &rest sequences) +(defalias 'cl-concatenate #'seq-concatenate "Concatenate, into a sequence of type TYPE, the argument SEQUENCEs. -\n(fn TYPE SEQUENCE...)" - (apply #'seq-concatenate type sequences)) +\n(fn TYPE SEQUENCE...)") ;;; List functions. @@ -912,6 +912,8 @@ Outputs to the current buffer." (mapc #'cl--describe-class-slot cslots)))) +(make-obsolete-variable 'cl-extra-load-hook + "use `with-eval-after-load' instead." "28.1") (run-hooks 'cl-extra-load-hook) ;; Local variables: diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 9dbcadec3ce..8e36dbe4a36 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -211,7 +211,16 @@ DEFAULT-BODY, if present, is used as the body of a default method. [&rest [&or ("declare" &rest sexp) (":argument-precedence-order" &rest sexp) - (&define ":method" [&rest atom] + (&define ":method" + ;; FIXME: The `:unique' + ;; construct works around + ;; Bug#42672. We'd rather want + ;; names like those generated by + ;; `cl-defmethod', but that + ;; requires larger changes to + ;; Edebug. + :unique "cl-generic-:method@" + [&rest cl-generic-method-qualifier] cl-generic-method-args lambda-doc def-body)]] def-body))) @@ -295,15 +304,6 @@ the specializer used will be the one returned by BODY." (lambda ,args ,@body)))) (eval-and-compile ;Needed while compiling the cl-defmethod calls below! - (defun cl--generic-fgrep (vars sexp) ;Copied from pcase.el. - "Check which of the symbols VARS appear in SEXP." - (let ((res '())) - (while (consp sexp) - (dolist (var (cl--generic-fgrep vars (pop sexp))) - (unless (memq var res) (push var res)))) - (and (memq sexp vars) (not (memq sexp res)) (push sexp res)) - res)) - (defun cl--generic-split-args (args) "Return (SPEC-ARGS . PLAIN-ARGS)." (let ((plain-args ()) @@ -366,11 +366,11 @@ the specializer used will be the one returned by BODY." ;; is used. ;; FIXME: Also, optimize the case where call-next-method is ;; only called with explicit arguments. - (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody))) + (uses-cnm (macroexp--fgrep `((,cnm) (,nmp)) nbody))) (cons (not (not uses-cnm)) `#'(lambda (,@(if uses-cnm (list cnm)) ,@args) ,@(car parsed-body) - ,(if (not (memq nmp uses-cnm)) + ,(if (not (assq nmp uses-cnm)) nbody `(let ((,nmp (lambda () (cl--generic-isnot-nnm-p ,cnm)))) @@ -401,8 +401,18 @@ the specializer used will be the one returned by BODY." ;;;###autoload (defmacro cl-defmethod (name args &rest body) "Define a new method for generic function NAME. -I.e. it defines the implementation of NAME to use for invocations where the -values of the dispatch arguments match the specified TYPEs. +This it defines an implementation of NAME to use for invocations +of specific types of arguments. + +ARGS is a list of dispatch arguments (see `cl-defun'), but where +each variable element is either just a single variable name VAR, +or a list on the form (VAR TYPE). + +For instance: + + (cl-defmethod foo (bar (format-string string) &optional zot) + (format format-string bar)) + The dispatch arguments have to be among the mandatory arguments, and all methods of NAME have to use the same set of arguments for dispatch. Each dispatch argument and TYPE are specified in ARGS where the corresponding @@ -432,9 +442,8 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (&define ; this means we are defining something [&or name ("setf" name :name setf)] ;; ^^ This is the methods symbol - [ &rest atom ] ; Multiple qualifiers are allowed. - ; Like in CLOS spec, we support - ; any non-list values. + [ &rest cl-generic-method-qualifier ] + ;; Multiple qualifiers are allowed. cl-generic-method-args ; arguments lambda-doc ; documentation string def-body))) ; part to be debugged @@ -599,11 +608,11 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (lambda (,@fixedargs &rest args) (let ,bindings (apply (cl--generic-with-memoization - (gethash ,tag-exp method-cache) - (cl--generic-cache-miss - generic ',dispatch-arg dispatches-left methods - ,(if (cdr typescodes) - `(append ,@typescodes) (car typescodes)))) + (gethash ,tag-exp method-cache) + (cl--generic-cache-miss + generic ',dispatch-arg dispatches-left methods + ,(if (cdr typescodes) + `(append ,@typescodes) (car typescodes)))) ,@fixedargs args))))))))) (defun cl--generic-make-function (generic) @@ -793,8 +802,8 @@ It should return a function that expects the same arguments as the methods, and GENERIC is the generic function (mostly used for its name). METHODS is the list of the selected methods. The METHODS list is sorted from most specific first to most generic last. -The function can use `cl-generic-call-method' to create functions that call those -methods.") +The function can use `cl-generic-call-method' to create functions that call +those methods.") (unless (ignore-errors (cl-generic-generalizers t)) ;; Temporary definition to let the next defmethod succeed. @@ -1092,7 +1101,8 @@ These match if the argument is a cons cell whose car is `eql' to VAL." (if (not (eq (car-safe specializer) 'head)) (cl-call-next-method) (cl--generic-with-memoization - (gethash (cadr specializer) cl--generic-head-used) specializer) + (gethash (cadr specializer) cl--generic-head-used) + specializer) (list cl--generic-head-generalizer))) (cl--generic-prefill-dispatchers 0 (head eql)) diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el index a26598fab33..7d0bfc88b15 100644 --- a/lisp/emacs-lisp/cl-indent.el +++ b/lisp/emacs-lisp/cl-indent.el @@ -46,14 +46,12 @@ "Maximum depth to backtrack out from a sublist for structured indentation. If this variable is 0, no backtracking will occur and forms such as `flet' may not be correctly indented." - :type 'integer - :group 'lisp-indent) + :type 'integer) (defcustom lisp-tag-indentation 1 "Indentation of tags relative to containing list. This variable is used by the function `lisp-indent-tagbody'." - :type 'integer - :group 'lisp-indent) + :type 'integer) (defcustom lisp-tag-body-indentation 3 "Indentation of non-tagged lines relative to containing list. @@ -64,32 +62,30 @@ the special form. If the value is t, the body of tags will be indented as a block at the same indentation as the first s-expression following the tag. In this case, any forms before the first tag are indented by `lisp-body-indent'." - :type 'integer - :group 'lisp-indent) + :type 'integer) (defcustom lisp-backquote-indentation t "Whether or not to indent backquoted lists as code. If nil, indent backquoted lists as data, i.e., like quoted lists." - :type 'boolean - :group 'lisp-indent) + :type 'boolean) -(defcustom lisp-loop-keyword-indentation 3 +(defcustom lisp-loop-keyword-indentation 6 "Indentation of loop keywords in extended loop forms." :type 'integer - :group 'lisp-indent) + :version "28.1") -(defcustom lisp-loop-forms-indentation 5 +(defcustom lisp-loop-forms-indentation 6 "Indentation of forms in extended loop forms." :type 'integer - :group 'lisp-indent) + :version "28.1") -(defcustom lisp-simple-loop-indentation 3 +(defcustom lisp-simple-loop-indentation 1 "Indentation of forms in simple loop forms." :type 'integer - :group 'lisp-indent) + :version "28.1") (defcustom lisp-lambda-list-keyword-alignment nil "Whether to vertically align lambda-list keywords together. @@ -107,16 +103,14 @@ If non-nil, alignment is done with the first keyword &key key1 key2) #|...|#)" :version "24.1" - :type 'boolean - :group 'lisp-indent) + :type 'boolean) (defcustom lisp-lambda-list-keyword-parameter-indentation 2 "Indentation of lambda list keyword parameters. See `lisp-lambda-list-keyword-parameter-alignment' for more information." :version "24.1" - :type 'integer - :group 'lisp-indent) + :type 'integer) (defcustom lisp-lambda-list-keyword-parameter-alignment nil "Whether to vertically align lambda-list keyword parameters together. @@ -135,8 +129,7 @@ If non-nil, alignment is done with the first parameter key3 key4) #|...|#)" :version "24.1" - :type 'boolean - :group 'lisp-indent) + :type 'boolean) (defcustom lisp-indent-backquote-substitution-mode t "How to indent substitutions in backquotes. @@ -148,8 +141,7 @@ In any case, do not backtrack beyond a backquote substitution. Until Emacs 25.1, the nil behavior was hard-wired." :version "25.1" - :type '(choice (const corrected) (const nil) (const t)) - :group 'lisp-indent) + :type '(choice (const corrected) (const nil) (const t))) (defvar lisp-indent-defun-method '(4 &lambda &body) diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index b669ee9981a..3bf3fd21ded 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -619,8 +619,11 @@ If ALIST is non-nil, the new pairs are prepended to it." (macroexp-let2* nil ((start from) (end to)) (funcall do `(substring ,getter ,start ,end) (lambda (v) - (funcall setter `(cl--set-substring - ,getter ,start ,end ,v)))))))) + (macroexp-let2 nil v v + `(progn + ,(funcall setter `(cl--set-substring + ,getter ,start ,end ,v)) + ,v)))))))) ;;; Miscellaneous. @@ -660,6 +663,7 @@ This can be needed when using code byte-compiled using the old macro-expansion of `cl-defstruct' that used vectors objects instead of record objects." :global t + :group 'tools (cond (cl-old-struct-compat-mode (advice-add 'type-of :around #'cl--old-struct-type-of)) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 339e4998dd6..c2bf02ccece 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -75,7 +75,7 @@ ;; one, you may want to amend the other, too. ;;;###autoload (define-obsolete-function-alias 'cl--compiler-macro-cXXr - 'internal--compiler-macro-cXXr "25.1") + #'internal--compiler-macro-cXXr "25.1") ;;; Some predicates for analyzing Lisp forms. ;; These are used by various @@ -199,7 +199,7 @@ The name is made by appending a number to PREFIX, default \"T\"." [&optional ["&key" [cl-&key-arg &rest cl-&key-arg] &optional "&allow-other-keys"]] [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] + &or (cl-lambda-arg &optional def-form) arg]] . [&or arg nil]))) (def-edebug-spec cl-&optional-arg @@ -219,7 +219,7 @@ The name is made by appending a number to PREFIX, default \"T\"." [&optional ["&key" cl-&key-arg &rest cl-&key-arg &optional "&allow-other-keys"]] [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] + &or (cl-lambda-arg &optional def-form) arg]] . [&or arg nil]))) (def-edebug-spec cl-type-spec sexp) @@ -328,8 +328,7 @@ FORM is of the form (ARGS . BODY)." (setq cl--bind-lets (nreverse cl--bind-lets)) ;; (cl-assert (eq :dummy (nth 1 (car cl--bind-lets)))) (list '&rest (car (pop cl--bind-lets)))))))) - `(nil - (,@(nreverse simple-args) ,@rest-args) + `((,@(nreverse simple-args) ,@rest-args) ,@header ,(macroexp-let* cl--bind-lets (macroexp-progn @@ -366,9 +365,7 @@ more details. def-body)) (doc-string 3) (indent 2)) - (let* ((res (cl--transform-lambda (cons args body) name)) - (form `(defun ,name ,@(cdr res)))) - (if (car res) `(progn ,(car res) ,form) form))) + `(defun ,name ,@(cl--transform-lambda (cons args body) name))) ;;;###autoload (defmacro cl-iter-defun (name args &rest body) @@ -387,9 +384,7 @@ and BODY is implicitly surrounded by (cl-block NAME ...). (doc-string 3) (indent 2)) (require 'generator) - (let* ((res (cl--transform-lambda (cons args body) name)) - (form `(iter-defun ,name ,@(cdr res)))) - (if (car res) `(progn ,(car res) ,form) form))) + `(iter-defun ,name ,@(cl--transform-lambda (cons args body) name))) ;; The lambda list for macros is different from that of normal lambdas. ;; Note that &environment is only allowed as first or last items in the @@ -407,7 +402,7 @@ and BODY is implicitly surrounded by (cl-block NAME ...). arg]] &optional "&allow-other-keys"]] [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] + &or (cl-macro-arg &optional def-form) arg]] [&optional "&environment" arg] ))) @@ -426,7 +421,7 @@ and BODY is implicitly surrounded by (cl-block NAME ...). arg]] &optional "&allow-other-keys"]] [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] + &or (cl-macro-arg &optional def-form) arg]] . [&or arg nil]))) ;;;###autoload @@ -455,9 +450,7 @@ more details. (&define name cl-macro-list cl-declarations-or-string def-body)) (doc-string 3) (indent 2)) - (let* ((res (cl--transform-lambda (cons args body) name)) - (form `(defmacro ,name ,@(cdr res)))) - (if (car res) `(progn ,(car res) ,form) form))) + `(defmacro ,name ,@(cl--transform-lambda (cons args body) name))) (def-edebug-spec cl-lambda-expr (&define ("lambda" cl-lambda-list @@ -480,9 +473,7 @@ Like normal `function', except that if argument is a lambda form, its argument list allows full Common Lisp conventions." (declare (debug (&or symbolp cl-lambda-expr))) (if (eq (car-safe func) 'lambda) - (let* ((res (cl--transform-lambda (cdr func) 'cl-none)) - (form `(function (lambda . ,(cdr res))))) - (if (car res) `(progn ,(car res) ,form) form)) + `(function (lambda . ,(cl--transform-lambda (cdr func) 'cl-none))) `(function ,func))) (defun cl--make-usage-var (x) @@ -723,9 +714,9 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level. (let ((comp (or (memq 'compile when) (memq :compile-toplevel when))) (cl--not-toplevel t)) (if (or (memq 'load when) (memq :load-toplevel when)) - (if comp (cons 'progn (mapcar 'cl--compile-time-too body)) + (if comp (cons 'progn (mapcar #'cl--compile-time-too body)) `(if nil nil ,@body)) - (progn (if comp (eval (cons 'progn body))) nil))) + (progn (if comp (eval (cons 'progn body) lexical-binding)) nil))) (and (or (memq 'eval when) (memq :execute when)) (cons 'progn body)))) @@ -734,13 +725,13 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level. (setq form (macroexpand form (cons '(cl-eval-when) byte-compile-macro-environment)))) (cond ((eq (car-safe form) 'progn) - (cons 'progn (mapcar 'cl--compile-time-too (cdr form)))) + (cons 'progn (mapcar #'cl--compile-time-too (cdr form)))) ((eq (car-safe form) 'cl-eval-when) (let ((when (nth 1 form))) (if (or (memq 'eval when) (memq :execute when)) `(cl-eval-when (compile ,@when) ,@(cddr form)) form))) - (t (eval form) form))) + (t (eval form lexical-binding) form))) ;;;###autoload (defmacro cl-load-time-value (form &optional _read-only) @@ -766,7 +757,7 @@ The result of the body appears to the compiler as a quoted constant." ;; temp is set before we use it. (print set byte-compile--outbuffer)) temp) - `',(eval form))) + `',(eval form lexical-binding))) ;;; Conditional control structures. @@ -828,16 +819,15 @@ final clause, and matches if no other keys match. (cons 'cond (mapcar - (function - (lambda (c) - (cons (cond ((eq (car c) 'otherwise) t) - ((eq (car c) 'cl--ecase-error-flag) - `(error "cl-etypecase failed: %s, %s" - ,temp ',(reverse type-list))) - (t - (push (car c) type-list) - `(cl-typep ,temp ',(car c)))) - (or (cdr c) '(nil))))) + (lambda (c) + (cons (cond ((eq (car c) 'otherwise) t) + ((eq (car c) 'cl--ecase-error-flag) + `(error "cl-etypecase failed: %s, %s" + ,temp ',(reverse type-list))) + (t + (push (car c) type-list) + `(cl-typep ,temp ',(car c)))) + (or (cdr c) '(nil)))) clauses))))) ;;;###autoload @@ -889,7 +879,7 @@ This is compatible with Common Lisp, but note that `defun' and ;;; The "cl-loop" macro. (defvar cl--loop-args) (defvar cl--loop-accum-var) (defvar cl--loop-accum-vars) -(defvar cl--loop-bindings) (defvar cl--loop-body) +(defvar cl--loop-bindings) (defvar cl--loop-body) (defvar cl--loop-conditions) (defvar cl--loop-finally) (defvar cl--loop-finish-flag) ;Symbol set to nil to exit the loop? (defvar cl--loop-first-flag) @@ -910,7 +900,8 @@ This is compatible with Common Lisp, but note that `defun' and "The Common Lisp `loop' macro. Valid clauses include: For clauses: - for VAR from/upfrom/downfrom EXPR1 to/upto/downto/above/below EXPR2 [by EXPR3] + for VAR from/upfrom/downfrom EXPR1 to/upto/downto/above/below EXPR2 + [by EXPR3] for VAR = EXPR1 then EXPR2 for VAR in/on/in-ref LIST [by FUNC] for VAR across/across-ref ARRAY @@ -966,7 +957,8 @@ For more details, see Info node `(cl)Loop Facility'. (cl--loop-accum-var nil) (cl--loop-accum-vars nil) (cl--loop-initially nil) (cl--loop-finally nil) (cl--loop-iterator-function nil) (cl--loop-first-flag nil) - (cl--loop-symbol-macs nil)) + (cl--loop-symbol-macs nil) + (cl--loop-conditions nil)) ;; Here is more or less how those dynbind vars are used after looping ;; over cl--parse-loop-clause: ;; @@ -1034,6 +1026,13 @@ For more details, see Info node `(cl)Loop Facility'. (list `(cl-symbol-macrolet ,cl--loop-symbol-macs ,@body)))) `(cl-block ,cl--loop-name ,@body))))) +(defmacro cl--push-clause-loop-body (clause) + "Apply CLAUSE to both `cl--loop-conditions' and `cl--loop-body'." + (macroexp-let2 nil sym clause + `(progn + (push ,sym cl--loop-conditions) + (push ,sym cl--loop-body)))) + ;; Below is a complete spec for cl-loop, in several parts that correspond ;; to the syntax given in CLtL2. The specs do more than specify where ;; the forms are; it also specifies, as much as Edebug allows, all the @@ -1184,8 +1183,6 @@ For more details, see Info node `(cl)Loop Facility'. ;; (def-edebug-spec loop-d-type-spec ;; (&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec)) - - (defun cl--parse-loop-clause () ; uses loop-* (let ((word (pop cl--loop-args)) (hash-types '(hash-key hash-keys hash-value hash-values)) @@ -1264,11 +1261,11 @@ For more details, see Info node `(cl)Loop Facility'. (if end-var (push (list end-var end) loop-for-bindings)) (if step-var (push (list step-var step) loop-for-bindings)) - (if end - (push (list - (if down (if excl '> '>=) (if excl '< '<=)) - var (or end-var end)) - cl--loop-body)) + (when end + (cl--push-clause-loop-body + (list + (if down (if excl '> '>=) (if excl '< '<=)) + var (or end-var end)))) (push (list var (list (if down '- '+) var (or step-var step 1))) loop-for-steps))) @@ -1278,7 +1275,7 @@ For more details, see Info node `(cl)Loop Facility'. (temp (if (and on (symbolp var)) var (make-symbol "--cl-var--")))) (push (list temp (pop cl--loop-args)) loop-for-bindings) - (push `(consp ,temp) cl--loop-body) + (cl--push-clause-loop-body `(consp ,temp)) (if (eq word 'in-ref) (push (list var `(car ,temp)) cl--loop-symbol-macs) (or (eq temp var) @@ -1301,33 +1298,31 @@ For more details, see Info node `(cl)Loop Facility'. ((eq word '=) (let* ((start (pop cl--loop-args)) (then (if (eq (car cl--loop-args) 'then) - (cl--pop2 cl--loop-args) start))) + (cl--pop2 cl--loop-args) start)) + (first-assign (or cl--loop-first-flag + (setq cl--loop-first-flag + (make-symbol "--cl-var--"))))) (push (list var nil) loop-for-bindings) (if (or ands (eq (car cl--loop-args) 'and)) (progn - (push `(,var - (if ,(or cl--loop-first-flag - (setq cl--loop-first-flag - (make-symbol "--cl-var--"))) - ,start ,var)) - loop-for-sets) - (push (list var then) loop-for-steps)) - (push (list var - (if (eq start then) start - `(if ,(or cl--loop-first-flag - (setq cl--loop-first-flag - (make-symbol "--cl-var--"))) - ,start ,then))) - loop-for-sets)))) + (push `(,var (if ,first-assign ,start ,var)) loop-for-sets) + (push `(,var (if ,(car (cl--loop-build-ands + (nreverse cl--loop-conditions))) + ,then ,var)) + loop-for-steps)) + (push (if (eq start then) + `(,var ,then) + `(,var (if ,first-assign ,start ,then))) + loop-for-sets)))) ((memq word '(across across-ref)) (let ((temp-vec (make-symbol "--cl-vec--")) (temp-idx (make-symbol "--cl-idx--"))) (push (list temp-vec (pop cl--loop-args)) loop-for-bindings) (push (list temp-idx -1) loop-for-bindings) - (push `(< (setq ,temp-idx (1+ ,temp-idx)) - (length ,temp-vec)) - cl--loop-body) + (push `(setq ,temp-idx (1+ ,temp-idx)) cl--loop-body) + (cl--push-clause-loop-body + `(< ,temp-idx (length ,temp-vec))) (if (eq word 'across-ref) (push (list var `(aref ,temp-vec ,temp-idx)) cl--loop-symbol-macs) @@ -1351,17 +1346,16 @@ For more details, see Info node `(cl)Loop Facility'. (push (list temp-seq seq) loop-for-bindings) (push (list temp-idx 0) loop-for-bindings) (if ref - (let ((temp-len (make-symbol "--cl-len--"))) + (let ((temp-len (make-symbol "--cl-len--"))) (push (list temp-len `(length ,temp-seq)) loop-for-bindings) (push (list var `(elt ,temp-seq ,temp-idx)) cl--loop-symbol-macs) - (push `(< ,temp-idx ,temp-len) cl--loop-body)) + (cl--push-clause-loop-body `(< ,temp-idx ,temp-len))) (push (list var nil) loop-for-bindings) - (push `(and ,temp-seq - (or (consp ,temp-seq) - (< ,temp-idx (length ,temp-seq)))) - cl--loop-body) + (cl--push-clause-loop-body `(and ,temp-seq + (or (consp ,temp-seq) + (< ,temp-idx (length ,temp-seq))))) (push (list var `(if (consp ,temp-seq) (pop ,temp-seq) (aref ,temp-seq ,temp-idx))) @@ -1457,9 +1451,8 @@ For more details, see Info node `(cl)Loop Facility'. (push (list var '(selected-frame)) loop-for-bindings) (push (list temp nil) loop-for-bindings) - (push `(prog1 (not (eq ,var ,temp)) - (or ,temp (setq ,temp ,var))) - cl--loop-body) + (cl--push-clause-loop-body `(prog1 (not (eq ,var ,temp)) + (or ,temp (setq ,temp ,var)))) (push (list var `(next-frame ,var)) loop-for-steps))) @@ -1480,9 +1473,8 @@ For more details, see Info node `(cl)Loop Facility'. (push (list minip `(minibufferp (window-buffer ,var))) loop-for-bindings) (push (list temp nil) loop-for-bindings) - (push `(prog1 (not (eq ,var ,temp)) - (or ,temp (setq ,temp ,var))) - cl--loop-body) + (cl--push-clause-loop-body `(prog1 (not (eq ,var ,temp)) + (or ,temp (setq ,temp ,var)))) (push (list var `(next-window ,var ,minip)) loop-for-steps))) @@ -1498,17 +1490,17 @@ For more details, see Info node `(cl)Loop Facility'. (pop cl--loop-args)) (if (and ands loop-for-bindings) (push (nreverse loop-for-bindings) cl--loop-bindings) - (setq cl--loop-bindings (nconc (mapcar 'list loop-for-bindings) - cl--loop-bindings))) + (setq cl--loop-bindings (nconc (mapcar #'list loop-for-bindings) + cl--loop-bindings))) (if loop-for-sets (push `(progn ,(cl--loop-let (nreverse loop-for-sets) 'setq ands) t) cl--loop-body)) - (if loop-for-steps - (push (cons (if ands 'cl-psetq 'setq) - (apply 'append (nreverse loop-for-steps))) - cl--loop-steps)))) + (when loop-for-steps + (push (cons (if ands 'cl-psetq 'setq) + (apply #'append (nreverse loop-for-steps))) + cl--loop-steps)))) ((eq word 'repeat) (let ((temp (make-symbol "--cl-var--"))) @@ -1700,7 +1692,7 @@ If BODY is `setq', then use SPECS for assignments rather than for bindings." (push binding new)))) (if (eq body 'setq) (let ((set (cons (if par 'cl-psetq 'setq) - (apply 'nconc (nreverse new))))) + (apply #'nconc (nreverse new))))) (if temps `(let* ,(nreverse temps) ,set) set)) `(,(if par 'let 'let*) ,(nconc (nreverse temps) (nreverse new)) ,@body)))) @@ -1826,7 +1818,7 @@ For more details, see `cl-do*' description in Info node `(cl) Iteration'. (and sets (list (cons (if (or star (not (cdr sets))) 'setq 'cl-psetq) - (apply 'append sets)))))) + (apply #'append sets)))))) ,@(or (cdr endtest) '(nil))))) ;;;###autoload @@ -2024,7 +2016,12 @@ info node `(cl) Function Bindings' for details. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" (declare (indent 1) - (debug ((&rest [&or (&define name function-form) (cl-defun)]) + (debug ((&rest [&or (&define name :unique "cl-flet@" function-form) + (&define name :unique "cl-flet@" + cl-lambda-list + cl-declarations-or-string + [&optional ("interactive" interactive)] + def-body)]) cl-declarations body))) (let ((binds ()) (newenv macroexpand-all-environment)) (dolist (binding bindings) @@ -2063,10 +2060,99 @@ Like `cl-flet' but the definitions can refer to previous ones. ((null (cdr bindings)) `(cl-flet ,bindings ,@body)) (t `(cl-flet (,(pop bindings)) (cl-flet* ,bindings ,@body))))) +(defun cl--self-tco (var fargs body) + ;; This tries to "optimize" tail calls for the specific case + ;; of recursive self-calls by replacing them with a `while' loop. + ;; It is quite far from a general tail-call optimization, since it doesn't + ;; even handle mutually recursive functions. + (letrec + ((done nil) ;; Non-nil if some TCO happened. + (retvar (make-symbol "retval")) + (ofargs (mapcar (lambda (s) (if (memq s cl--lambda-list-keywords) s + (make-symbol (symbol-name s)))) + fargs)) + (opt-exps (lambda (exps) ;; `exps' is in tail position! + (append (butlast exps) + (list (funcall opt (car (last exps))))))) + (opt + (lambda (exp) ;; `exp' is in tail position! + (pcase exp + ;; FIXME: Optimize `apply'? + (`(funcall ,(pred (eq var)) . ,aargs) + ;; This is a self-recursive call in tail position. + (let ((sets nil) + (fargs ofargs)) + (while fargs + (pcase (pop fargs) + ('&rest + (push (pop fargs) sets) + (push `(list . ,aargs) sets) + ;; (cl-assert (null fargs)) + ) + ('&optional nil) + (farg + (push farg sets) + (push (pop aargs) sets)))) + (setq done t) + `(progn (setq . ,(nreverse sets)) + :recurse))) + (`(progn . ,exps) `(progn . ,(funcall opt-exps exps))) + (`(if ,cond ,then . ,else) + `(if ,cond ,(funcall opt then) . ,(funcall opt-exps else))) + (`(cond . ,conds) + (let ((cs '())) + (while conds + (pcase (pop conds) + (`(,exp) + (push (if conds + ;; This returns the value of `exp' but it's + ;; only in tail position if it's the + ;; last condition. + `((setq ,retvar ,exp) nil) + `(,(funcall opt exp))) + cs)) + (exps + (push (funcall opt-exps exps) cs)))) + (if (eq t (caar cs)) + `(cond . ,(nreverse cs)) + `(cond ,@(nreverse cs) (t (setq ,retvar nil)))))) + ((and `(,(or 'let 'let*) ,bindings . ,exps) + (guard + ;; Note: it's OK for this `let' to shadow any + ;; of the formal arguments since we will only + ;; setq the fresh new `ofargs' vars instead ;-) + (let ((shadowings + (mapcar (lambda (b) (if (consp b) (car b) b)) bindings))) + ;; If `var' is shadowed, then it clearly can't be + ;; tail-called any more. + (not (memq var shadowings))))) + `(,(car exp) ,bindings . ,(funcall opt-exps exps))) + (_ + `(progn (setq ,retvar ,exp) nil)))))) + + (let ((optimized-body (funcall opt-exps body))) + (if (not done) + (cons fargs body) + ;; We use two sets of vars: `ofargs' and `fargs' because we need + ;; to be careful that if a closure captures a formal argument + ;; in one iteration, it needs to capture a different binding + ;; then that of other iterations, e.g. + (cons + ofargs + `((let (,retvar) + (while (let ,(delq nil + (cl-mapcar + (lambda (a oa) + (unless (memq a cl--lambda-list-keywords) + (list a oa))) + fargs ofargs)) + . ,optimized-body)) + ,retvar))))))) + ;;;###autoload (defmacro cl-labels (bindings &rest body) - "Make local (recursive) function definitions. -Each definition can take the form (FUNC ARGLIST BODY...) where + "Make local (recursive) function definitions. ++BINDINGS is a list of definitions of the form (FUNC ARGLIST BODY...) where FUNC is the function name, ARGLIST its arguments, and BODY the forms of the function body. FUNC is defined in any BODY, as well as FORM, so you can write recursive and mutually recursive @@ -2078,17 +2164,33 @@ details. (let ((binds ()) (newenv macroexpand-all-environment)) (dolist (binding bindings) (let ((var (make-symbol (format "--cl-%s--" (car binding))))) - (push (list var `(cl-function (lambda . ,(cdr binding)))) binds) + (push (cons var (cdr binding)) binds) (push (cons (car binding) (lambda (&rest args) (if (eq (car args) cl--labels-magic) (list cl--labels-magic var) (cl-list* 'funcall var args)))) newenv))) - (macroexpand-all `(letrec ,(nreverse binds) ,@body) - ;; Don't override lexical-let's macro-expander. - (if (assq 'function newenv) newenv - (cons (cons 'function #'cl--labels-convert) newenv))))) + ;; Don't override lexical-let's macro-expander. + (unless (assq 'function newenv) + (push (cons 'function #'cl--labels-convert) newenv)) + ;; Perform self-tail call elimination. + (setq binds (mapcar + (lambda (bind) + (pcase-let* + ((`(,var ,sargs . ,sbody) bind) + (`(function (lambda ,fargs . ,ebody)) + (macroexpand-all `(cl-function (lambda ,sargs . ,sbody)) + newenv)) + (`(,ofargs . ,obody) + (cl--self-tco var fargs ebody))) + `(,var (function (lambda ,ofargs . ,obody))))) + (nreverse binds))) + `(letrec ,binds + . ,(macroexp-unprogn + (macroexpand-all + (macroexp-progn body) + newenv))))) ;; The following ought to have a better definition for use with newer ;; byte compilers. @@ -2105,10 +2207,9 @@ This is like `cl-flet', but for macros instead of functions. (if (null bindings) (macroexp-progn body) (let* ((name (caar bindings)) (res (cl--transform-lambda (cdar bindings) name))) - (eval (car res)) (macroexpand-all (macroexp-progn body) (cons (cons name - (eval `(cl-function (lambda ,@(cdr res))) t)) + (eval `(function (lambda ,@res)) t)) macroexpand-all-environment)))))) (defun cl--sm-macroexpand (orig-fun exp &optional env) @@ -2472,7 +2573,7 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'. \(fn PLACE...)" (declare (debug (&rest place))) - (if (not (memq nil (mapcar 'symbolp args))) + (if (not (memq nil (mapcar #'symbolp args))) (and (cdr args) (let ((sets nil) (first (car args))) @@ -2703,7 +2804,7 @@ Each SLOT may instead take the form (SNAME SDEFAULT SOPTIONS...), where SDEFAULT is the default value of that slot and SOPTIONS are keyword-value pairs for that slot. Supported keywords for slots are: -- `:read-only': If this has a non-nil value, that slot cannot be set via `setf'. +- `:read-only': If this has a non-nil value, that slot cannot be set via `setf'. - `:documentation': this is a docstring describing the slot. - `:type': the type of the field; currently only used for documentation. @@ -2767,7 +2868,7 @@ Supported keywords for slots are: (unless (cl--struct-name-p name) (signal 'wrong-type-argument (list 'cl-struct-name-p name 'name))) (setq descs (cons '(cl-tag-slot) - (mapcar (function (lambda (x) (if (consp x) x (list x)))) + (mapcar (lambda (x) (if (consp x) x (list x))) descs))) (while opts (let ((opt (if (consp (car opts)) (caar opts) (car opts))) @@ -2794,9 +2895,8 @@ Supported keywords for slots are: ;; we include EIEIO classes rather than cl-structs! (when include-name (error "Can't :include more than once")) (setq include-name (car args)) - (setq include-descs (mapcar (function - (lambda (x) - (if (consp x) x (list x)))) + (setq include-descs (mapcar (lambda (x) + (if (consp x) x (list x))) (cdr args)))) ((eq opt :print-function) (setq print-func (car args))) @@ -2872,7 +2972,9 @@ Supported keywords for slots are: (append pred-form '(t)) `(and ,pred-form t))) forms) - (push `(put ',name 'cl-deftype-satisfies ',predicate) forms)) + (push `(eval-and-compile + (put ',name 'cl-deftype-satisfies ',predicate)) + forms)) (let ((pos 0) (descp descs)) (while descp (let* ((desc (pop descp)) @@ -2971,15 +3073,27 @@ Supported keywords for slots are: constrs)) (pcase-dolist (`(,cname ,args ,doc) constrs) (let* ((anames (cl--arglist-args args)) - (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d))) - slots defaults))) - (push `(,cldefsym ,cname + (make (cl-mapcar (lambda (s d) (if (memq s anames) s d)) + slots defaults)) + ;; `cl-defsubst' is fundamentally broken: it substitutes + ;; its arguments into the body's `sexp' much too naively + ;; when inlinling, which results in various problems. + ;; For example it generates broken code if your + ;; argument's name happens to be the same as some + ;; function used within the body. + ;; E.g. (cl-defsubst sm-foo (list) (list list)) + ;; will expand `(sm-foo 1)' to `(1 1)' rather than to `(list t)'! + ;; Try to catch this known case! + (con-fun (or type #'record)) + (unsafe-cl-defsubst + (or (memq con-fun args) (assq con-fun args)))) + (push `(,(if unsafe-cl-defsubst 'cl-defun cldefsym) ,cname (&cl-defs (nil ,@descs) ,@args) ,(if (stringp doc) doc (format "Constructor for objects of type `%s'." name)) ,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) '((declare (side-effect-free t)))) - (,(or type #'record) ,@make)) + (,con-fun ,@make)) forms))) (if print-auto (nconc print-func (list '(princ ")" cl-s) t))) ;; Don't bother adding to cl-custom-print-functions since it's not used @@ -3132,13 +3246,35 @@ Of course, we really can't know that for sure, so it's just a heuristic." (or (cdr (assq sym byte-compile-function-environment)) (cdr (assq sym byte-compile-macro-environment)))))) -(put 'null 'cl-deftype-satisfies #'null) -(put 'atom 'cl-deftype-satisfies #'atom) -(put 'real 'cl-deftype-satisfies #'numberp) -(put 'fixnum 'cl-deftype-satisfies #'integerp) -(put 'base-char 'cl-deftype-satisfies #'characterp) -(put 'character 'cl-deftype-satisfies #'natnump) - +(pcase-dolist (`(,type . ,pred) + ;; Mostly kept in alphabetical order. + '((array . arrayp) + (atom . atom) + (base-char . characterp) + (boolean . booleanp) + (bool-vector . bool-vector-p) + (buffer . bufferp) + (character . natnump) + (char-table . char-table-p) + (hash-table . hash-table-p) + (cons . consp) + (fixnum . integerp) + (float . floatp) + (function . functionp) + (integer . integerp) + (keyword . keywordp) + (list . listp) + (number . numberp) + (null . null) + (real . numberp) + (sequence . sequencep) + (string . stringp) + (symbol . symbolp) + (vector . vectorp) + ;; FIXME: Do we really want to consider this a type? + (integer-or-marker . integer-or-marker-p) + )) + (put type 'cl-deftype-satisfies pred)) ;;;###autoload (define-inline cl-typep (val type) @@ -3207,7 +3343,10 @@ STRING is an optional description of the desired type." (macroexp-let2 macroexp-copyable-p temp form `(progn (or (cl-typep ,temp ',type) (signal 'wrong-type-argument - (list ,(or string `',type) ,temp ',form))) + (list ,(or string `',(if (eq 'satisfies + (car-safe type)) + (cadr type) type)) + ,temp ',form))) nil)))) ;;;###autoload @@ -3349,8 +3488,8 @@ macro that returns its `&whole' argument." (put y 'side-effect-free t)) ;;; Things that are inline. -(cl-proclaim '(inline cl-acons cl-map cl-concatenate cl-notany - cl-notevery cl-revappend cl-nreconc gethash)) +(cl-proclaim '(inline cl-acons cl-map cl-notany cl-notevery cl-revappend + cl-nreconc gethash)) ;;; Things that are side-effect-free. (mapc (lambda (x) (function-put x 'side-effect-free t)) @@ -3395,6 +3534,8 @@ STRUCT and SLOT-NAME are symbols. INST is a structure instance." (nth (cl-struct-slot-offset ,struct-type ,slot-name) ,inst) (aref ,inst (cl-struct-slot-offset ,struct-type ,slot-name))))))) +(make-obsolete-variable 'cl-macs-load-hook + "use `with-eval-after-load' instead." "28.1") (run-hooks 'cl-macs-load-hook) ;; Local variables: diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index 7cf02dfedd8..348da59fd97 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -33,8 +33,6 @@ ;;; Code: -(require 'button) - (defvar cl-print-readably nil "If non-nil, try and make sure the result can be `read'.") diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index f5d745c1c84..329bd7c1b3b 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -69,10 +69,9 @@ (list 'or (list 'memq '(car cl-keys-temp) (list 'quote (mapcar - (function - (lambda (x) - (if (consp x) - (car x) x))) + (lambda (x) + (if (consp x) + (car x) x)) (append kwords other-keys)))) '(car (cdr (memq (quote :allow-other-keys) @@ -668,9 +667,9 @@ This is a destructive function; it reuses the storage of SEQ if possible. (cl--parsing-keywords (:key) () (if (memq cl-key '(nil identity)) (sort cl-seq cl-pred) - (sort cl-seq (function (lambda (cl-x cl-y) - (funcall cl-pred (funcall cl-key cl-x) - (funcall cl-key cl-y))))))))) + (sort cl-seq (lambda (cl-x cl-y) + (funcall cl-pred (funcall cl-key cl-x) + (funcall cl-key cl-y)))))))) ;;;###autoload (defun cl-stable-sort (cl-seq cl-pred &rest cl-keys) @@ -1042,6 +1041,8 @@ Atoms are compared by `eql'; cons cells are compared recursively. (and (not (consp cl-x)) (not (consp cl-y)) (cl--check-match cl-x cl-y))) +(make-obsolete-variable 'cl-seq-load-hook + "use `with-eval-after-load' instead." "28.1") (run-hooks 'cl-seq-load-hook) ;; Local variables: diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el index 915fa0c4548..a9baef39a9a 100644 --- a/lisp/emacs-lisp/copyright.el +++ b/lisp/emacs-lisp/copyright.el @@ -1,4 +1,4 @@ -;;; copyright.el --- update the copyright notice in current buffer +;;; copyright.el --- update the copyright notice in current buffer -*- lexical-binding: t -*- ;; Copyright (C) 1991-1995, 1998, 2001-2021 Free Software Foundation, ;; Inc. @@ -37,14 +37,12 @@ (defcustom copyright-limit 2000 "Don't try to update copyright beyond this position unless interactive. A value of nil means to search whole buffer." - :group 'copyright :type '(choice (integer :tag "Limit") (const :tag "No limit"))) (defcustom copyright-at-end-flag nil "Non-nil means to search backwards from the end of the buffer for copyright. This is useful for ChangeLogs." - :group 'copyright :type 'boolean :version "23.1") ;;;###autoload(put 'copyright-at-end-flag 'safe-local-variable 'booleanp) @@ -56,7 +54,6 @@ This is useful for ChangeLogs." \\([1-9]\\([-0-9, ';/*%#\n\t]\\|\\s<\\|\\s>\\)*[0-9]+\\)" "What your copyright notice looks like. The second \\( \\) construct must match the years." - :group 'copyright :type 'regexp) (defcustom copyright-names-regexp "" @@ -64,7 +61,6 @@ The second \\( \\) construct must match the years." Only copyright lines where the name matches this regexp will be updated. This allows you to avoid adding years to a copyright notice belonging to someone else or to a group for which you do not work." - :group 'copyright :type 'regexp) ;; The worst that can happen is a malicious regexp that overflows in @@ -76,7 +72,6 @@ someone else or to a group for which you do not work." "\\(\\s *\\)\\([1-9]\\([-0-9, ';/*%#\n\t]\\|\\s<\\|\\s>\\)*[0-9]+\\)" "Match additional copyright notice years. The second \\( \\) construct must match the years." - :group 'copyright :type 'regexp) ;; See "Copyright Notices" in maintain.info. @@ -87,7 +82,6 @@ The second \\( \\) construct must match the years." For example: 2005, 2006, 2007, 2008 might be replaced with 2005-2008. If you use ranges, you should add an explanatory note in a README file. The function `copyright-fix-years' respects this variable." - :group 'copyright :type 'boolean :version "24.1") @@ -96,7 +90,6 @@ The function `copyright-fix-years' respects this variable." (defcustom copyright-query 'function "If non-nil, ask user before changing copyright. When this is `function', only ask when called non-interactively." - :group 'copyright :type '(choice (const :tag "Do not ask") (const :tag "Ask unless interactive" function) (other :tag "Ask" t))) @@ -263,7 +256,7 @@ interactively." (match-string-no-properties 1) copyright-current-gpl-version))))) (replace-match copyright-current-gpl-version t t nil 1)))) - (set (make-local-variable 'copyright-update) nil))) + (setq-local copyright-update nil))) ;; If a write-file-hook returns non-nil, the file is presumed to be written. nil)) diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index 76e1633d4b5..e106815817e 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -1,4 +1,4 @@ -;;; crm.el --- read multiple strings with completion +;;; crm.el --- read multiple strings with completion -*- lexical-binding: t; -*- ;; Copyright (C) 1985-1986, 1993-2021 Free Software Foundation, Inc. @@ -270,12 +270,6 @@ with empty strings removed." (remove-hook 'choose-completion-string-functions 'crm--choose-completion-string))) -(define-obsolete-function-alias 'crm-minibuffer-complete 'crm-complete "23.1") -(define-obsolete-function-alias - 'crm-minibuffer-completion-help 'crm-completion-help "23.1") -(define-obsolete-function-alias - 'crm-minibuffer-complete-and-exit 'crm-complete-and-exit "23.1") - ;; testing and debugging ;; (defun crm-init-test-environ () ;; "Set up some variables for testing." diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 5b3cbcd5be3..d9da0db4551 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -29,7 +29,6 @@ (require 'cl-lib) (require 'backtrace) -(require 'button) (defgroup debugger nil "Debuggers and related commands for Emacs." @@ -670,9 +669,7 @@ Redefining FUNCTION also cancels it." (when (special-form-p fn) (setq fn nil)) (setq val (completing-read - (if fn - (format "Debug on entry to function (default %s): " fn) - "Debug on entry to function: ") + (format-prompt "Debug on entry to function" fn) obarray #'(lambda (symbol) (and (fboundp symbol) @@ -775,8 +772,7 @@ another symbol also cancels it." (let* ((var-at-point (variable-at-point)) (var (and (symbolp var-at-point) var-at-point)) (val (completing-read - (concat "Debug when setting variable" - (if var (format " (default %s): " var) ": ")) + (format-prompt "Debug when setting variable" var) obarray #'boundp t nil nil (and var (symbol-name var))))) (list (if (equal val "") var (intern val))))) diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index 0a799923c32..54528b2fb91 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -1,4 +1,4 @@ -;;; derived.el --- allow inheritance of major modes +;;; derived.el --- allow inheritance of major modes -*- lexical-binding: t; -*- ;; (formerly mode-clone.el) ;; Copyright (C) 1993-1994, 1999, 2001-2021 Free Software Foundation, @@ -306,11 +306,13 @@ No problems result if this variable is not bound. ;; Use a default docstring. (setq docstring (if (null parent) - ;; FIXME filling. - (format "Major-mode.\nUses keymap `%s'%s%s." map - (if abbrev (format "%s abbrev table `%s'" - (if syntax "," " and") abbrev) "") - (if syntax (format " and syntax-table `%s'" syntax) "")) + (concat + "Major-mode.\n" + (internal--format-docstring-line + "Uses keymap `%s'%s%s." map + (if abbrev (format "%s abbrev table `%s'" + (if syntax "," " and") abbrev) "") + (if syntax (format " and syntax-table `%s'" syntax) ""))) (format "Major mode derived from `%s' by `define-derived-mode'. It inherits all of the parent's attributes, but has its own keymap%s: @@ -336,20 +338,22 @@ which more-or-less shadow%s %s's corresponding table%s." (unless (string-match (regexp-quote (symbol-name hook)) docstring) ;; Make sure the docstring mentions the mode's hook. (setq docstring - (concat docstring - (if (null parent) - "\n\nThis mode " - (concat - "\n\nIn addition to any hooks its parent mode " - (if (string-match (format "[`‘]%s['’]" - (regexp-quote - (symbol-name parent))) - docstring) - nil - (format "`%s' " parent)) - "might have run,\nthis mode ")) - (format "runs the hook `%s'" hook) - ", as the final or penultimate step\nduring initialization."))) + (concat docstring "\n\n" + (internal--format-docstring-line + "%s%s%s" + (if (null parent) + "This mode " + (concat + "In addition to any hooks its parent mode " + (if (string-match (format "[`‘]%s['’]" + (regexp-quote + (symbol-name parent))) + docstring) + nil + (format "`%s' " parent)) + "might have run, this mode ")) + (format "runs the hook `%s'" hook) + ", as the final or penultimate step during initialization.")))) (unless (string-match "\\\\[{[]" docstring) ;; And don't forget to put the mode's keymap. @@ -364,6 +368,7 @@ which more-or-less shadow%s %s's corresponding table%s." (defsubst derived-mode-setup-function-name (mode) "Construct a setup-function name based on a MODE name." + (declare (obsolete nil "28.1")) (intern (concat (symbol-name mode) "-setup"))) diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index d91900351db..0d2890999a4 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -57,10 +57,9 @@ If OBJECT is not already compiled, we compile it, but do not redefine OBJECT if it is a symbol." (interactive (let* ((fn (function-called-at-point)) - (prompt (if fn (format "Disassemble function (default %s): " fn) - "Disassemble function: ")) (def (and fn (symbol-name fn)))) - (list (intern (completing-read prompt obarray 'fboundp t nil nil def)) + (list (intern (completing-read (format-prompt "Disassemble function" fn) + obarray 'fboundp t nil nil def)) nil 0 t))) (if (and (consp object) (not (functionp object))) (setq object `(lambda () ,object))) diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 7b8affd132e..54c0cf08b78 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -1,4 +1,4 @@ -;;; easy-mmode.el --- easy definition for major and minor modes +;;; easy-mmode.el --- easy definition for major and minor modes -*- lexical-binding: t; -*- ;; Copyright (C) 1997, 2000-2021 Free Software Foundation, Inc. @@ -84,10 +84,16 @@ replacing its case-insensitive matches with the literal string in LIGHTER." (defconst easy-mmode--arg-docstring " -If called interactively, enable %s if ARG is positive, and -disable it if ARG is zero or negative. If called from Lisp, -also enable the mode if ARG is omitted or nil, and toggle it -if ARG is `toggle'; disable the mode otherwise.") +If called interactively, toggle `%s'. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. +Enable the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +The mode's hook is called both when the mode is enabled and when +it is disabled.") (defun easy-mmode--mode-docstring (doc mode-pretty-name keymap-sym) (let ((doc (or doc (format "Toggle %s on or off. @@ -158,9 +164,6 @@ BODY contains code to execute each time the mode is enabled or disabled. the minor mode is global): :group GROUP Custom group name to use in all generated `defcustom' forms. - Defaults to MODE without the possible trailing \"-mode\". - Don't use this default group name unless you have written a - `defgroup' to define that group properly. :global GLOBAL If non-nil specifies that the minor mode is not meant to be buffer-local, so don't make the variable MODE buffer-local. By default, the mode is buffer-local. @@ -263,12 +266,6 @@ For example, you could write (unless initialize (setq initialize '(:initialize 'custom-initialize-default))) - (unless group - ;; We might as well provide a best-guess default group. - (setq group - `(:group ',(intern (replace-regexp-in-string - "-mode\\'" "" mode-name))))) - ;; TODO? Mark booleans as safe if booleanp? Eg abbrev-mode. (unless type (setq type '(:type 'boolean))) @@ -281,9 +278,10 @@ For example, you could write ((not globalp) `(progn :autoload-end - (defvar ,mode ,init-value ,(format "Non-nil if %s is enabled. -Use the command `%s' to change this variable." pretty-name mode)) - (make-variable-buffer-local ',mode))) + (defvar-local ,mode ,init-value + ,(concat (format "Non-nil if %s is enabled.\n" pretty-name) + (internal--format-docstring-line + "Use the command `%s' to change this variable." mode))))) (t (let ((base-doc-string (concat "Non-nil if %s is enabled. @@ -307,13 +305,18 @@ or call the function `%s'.")))) ,(easy-mmode--mode-docstring doc pretty-name keymap-sym) ;; Use `toggle' rather than (if ,mode 0 1) so that using ;; repeat-command still does the toggling correctly. - (interactive (list (or current-prefix-arg 'toggle))) + (interactive (list (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + 'toggle))) (let ((,last-message (current-message))) (,@setter - (if (eq arg 'toggle) - (not ,getter) - ;; A nil argument also means ON now. - (> (prefix-numeric-value arg) 0))) + (cond ((eq arg 'toggle) + (not ,getter)) + ((and (numberp arg) + (< arg 1)) + nil) + (t + t))) ,@body ;; The on/off hooks are here for backward compatibility only. (run-hooks ',hook (if ,getter ',hook-on ',hook-off)) @@ -345,6 +348,9 @@ 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. + (put ',hook 'custom-type 'hook) + (put ',hook 'standard-value (list nil)) ;; Define the minor-mode keymap. ,(unless (symbolp keymap) ;nil is also a symbol. @@ -378,18 +384,21 @@ No problems result if this variable is not bound. (defmacro define-globalized-minor-mode (global-mode mode turn-on &rest body) "Make a global mode GLOBAL-MODE corresponding to buffer-local minor MODE. TURN-ON is a function that will be called with no args in every buffer - and that should try to turn MODE on if applicable for that buffer. -Each of KEY VALUE is a pair of CL-style keyword arguments. As - the minor mode defined by this function is always global, any - :global keyword is ignored. Other keywords have the same - meaning as in `define-minor-mode', which see. In particular, - :group specifies the custom group. The most useful keywords - are those that are passed on to the `defcustom'. It normally - makes no sense to pass the :lighter or :keymap keywords to - `define-globalized-minor-mode', since these are usually passed - to the buffer-local version of the minor mode. +and that should try to turn MODE on if applicable for that buffer. + +Each of KEY VALUE is a pair of CL-style keyword arguments. :predicate +specifies which major modes the globalized minor mode should be switched on +in. As the minor mode defined by this function is always global, any +:global keyword is ignored. Other keywords have the same meaning as in +`define-minor-mode', which see. In particular, :group specifies the custom +group. The most useful keywords are those that are passed on to the +`defcustom'. It normally makes no sense to pass the :lighter or :keymap +keywords to `define-globalized-minor-mode', since these are usually passed +to the buffer-local version of the minor mode. + BODY contains code to execute each time the mode is enabled or disabled. - It is executed after toggling the mode, and before running GLOBAL-MODE-hook. +It is executed after toggling the mode, and before running +GLOBAL-MODE-hook. If MODE's set-up depends on the major mode in effect when it was enabled, then disabling and reenabling MODE should make MODE work @@ -418,7 +427,11 @@ on if the hook has explicitly disabled it. (minor-MODE-hook (intern (concat mode-name "-hook"))) (MODE-set-explicitly (intern (concat mode-name "-set-explicitly"))) (MODE-major-mode (intern (concat (symbol-name mode) "-major-mode"))) - keyw) + (MODE-predicate (intern (concat (replace-regexp-in-string + "-mode\\'" "" global-mode-name) + "-modes"))) + (turn-on-function `#',turn-on) + keyw predicate) ;; Check keys. (while (keywordp (setq keyw (car body))) @@ -426,29 +439,41 @@ on if the hook has explicitly disabled it. (pcase keyw (:group (setq group (nconc group (list :group (pop body))))) (:global (pop body)) + (:predicate + (setq predicate (list (pop body))) + (setq turn-on-function + `(lambda () + (require 'easy-mmode) + (when (easy-mmode--globalized-predicate-p ,(car predicate)) + (funcall ,turn-on-function))))) (_ (push keyw extra-keywords) (push (pop body) extra-keywords)))) `(progn (progn (put ',global-mode 'globalized-minor-mode t) :autoload-end - (defvar ,MODE-major-mode nil) - (make-variable-buffer-local ',MODE-major-mode)) + (defvar-local ,MODE-major-mode nil)) ;; The actual global minor-mode (define-minor-mode ,global-mode - ;; Very short lines to avoid too long lines in the generated - ;; doc string. - ,(format "Toggle %s in all buffers. -With prefix ARG, enable %s if ARG is positive; -otherwise, disable it. If called from Lisp, enable the mode if -ARG is omitted or nil. - -%s is enabled in all buffers where -`%s' would do it. -See `%s' for more information on %s." - pretty-name pretty-global-name - pretty-name turn-on mode pretty-name) - :global t ,@group ,@(nreverse extra-keywords) + ,(concat (format "Toggle %s in all buffers.\n" pretty-name) + (internal--format-docstring-line + "With prefix ARG, enable %s if ARG is positive; otherwise, \ +disable it. If called from Lisp, enable the mode if ARG is omitted or nil.\n\n" + pretty-global-name) + (internal--format-docstring-line + "%s is enabled in all buffers where `%s' would do it.\n\n" + pretty-name turn-on) + (internal--format-docstring-line + "See `%s' for more information on %s." + mode pretty-name) + (if predicate + (concat + "\n\n" + (internal--format-docstring-line + "`%s' is used to control which modes this minor mode is used in." + MODE-predicate)) + "")) + :global t ,@group ,@(nreverse extra-keywords) ;; Setup hook to handle future mode changes and new buffers. (if ,global-mode @@ -464,9 +489,28 @@ See `%s' for more information on %s." ;; Go through existing buffers. (dolist (buf (buffer-list)) (with-current-buffer buf - (if ,global-mode (funcall #',turn-on) (when ,mode (,mode -1))))) + (if ,global-mode (funcall ,turn-on-function) + (when ,mode (,mode -1))))) ,@body) + ,(when predicate + `(defcustom ,MODE-predicate ,(car predicate) + ,(format "Which major modes `%s' is switched on in. +This variable can be either t (all major modes), nil (no major modes), +or a list of modes and (not modes) to switch use this minor mode or +not. For instance + + (c-mode (not message-mode mail-mode) text-mode) + +means \"use this mode in all modes derived from `c-mode', don't use in +modes derived from `message-mode' or `mail-mode', but do use in other +modes derived from `text-mode'\". An element with value t means \"use\" +and nil means \"don't use\". There's an implicit nil at the end of the +list." + mode) + :type '(repeat sexp) + :group ,group)) + ;; Autoloading define-globalized-minor-mode autoloads everything ;; up-to-here. :autoload-end @@ -500,8 +544,8 @@ See `%s' for more information on %s." (if ,mode (progn (,mode -1) - (funcall #',turn-on)) - (funcall #',turn-on)))) + (funcall ,turn-on-function)) + (funcall ,turn-on-function)))) (setq ,MODE-major-mode major-mode)))))) (put ',MODE-enable-in-buffers 'definition-name ',global-mode) @@ -516,6 +560,33 @@ See `%s' for more information on %s." (add-hook 'post-command-hook ',MODE-check-buffers)) (put ',MODE-cmhh 'definition-name ',global-mode)))) +(defun easy-mmode--globalized-predicate-p (predicate) + (cond + ((eq predicate t) + t) + ((eq predicate nil) + nil) + ((listp predicate) + ;; Legacy support for (not a b c). + (when (eq (car predicate) 'not) + (setq predicate (nconc (mapcar (lambda (e) (list 'not e)) + (cdr predicate)) + (list t)))) + (catch 'found + (dolist (elem predicate) + (cond + ((eq elem t) + (throw 'found t)) + ((eq elem nil) + (throw 'found nil)) + ((and (consp elem) + (eq (car elem) 'not)) + (when (apply #'derived-mode-p (cdr elem)) + (throw 'found nil))) + ((symbolp elem) + (when (derived-mode-p elem) + (throw 'found t))))))))) + ;;; ;;; easy-mmode-defmap ;;; diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el index b907716f252..5303da3746c 100644 --- a/lisp/emacs-lisp/easymenu.el +++ b/lisp/emacs-lisp/easymenu.el @@ -29,16 +29,6 @@ ;;; Code: -(defvar easy-menu-precalculate-equivalent-keybindings nil - "Determine when equivalent key bindings are computed for easy-menu menus. -It can take some time to calculate the equivalent key bindings that are shown -in a menu. If the variable is on, then this calculation gives a (maybe -noticeable) delay when a mode is first entered. If the variable is off, then -this delay will come when a menu is displayed the first time. If you never use -menus, turn this variable off, otherwise it is probably better to keep it on.") -(make-obsolete-variable - 'easy-menu-precalculate-equivalent-keybindings nil "23.1") - (defsubst easy-menu-intern (s) (if (stringp s) (intern s) s)) @@ -498,17 +488,14 @@ 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)) -;; XEmacs needs the following two functions to add and remove menus. -;; In Emacs this is done automatically when switching keymaps, so -;; here easy-menu-remove and easy-menu-add are a noops. -(defalias 'easy-menu-remove 'ignore +(define-obsolete-function-alias 'easy-menu-remove #'ignore "28.1" "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-add #'ignore +(define-obsolete-function-alias 'easy-menu-add #'ignore "28.1" "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 @@ -524,6 +511,7 @@ completely and menu filter functions can be expected to work. If BEFORE is non-nil, add before the item named BEFORE. If IN-MENU is non-nil, follow MENU-PATH in IN-MENU. This is a compatibility function; use `easy-menu-add-item'." + (declare (obsolete easy-menu-add-item "28.1")) (easy-menu-add-item (or in-menu (current-global-map)) (cons "menu-bar" menu-path) submenu before)) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 961d21aff9e..84191af88cc 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -309,9 +309,8 @@ A lambda list keyword is a symbol that starts with `&'." (defun edebug-sort-alist (alist function) ;; Return the ALIST sorted with comparison function FUNCTION. ;; This uses 'sort so the sorting is destructive. - (sort alist (function - (lambda (e1 e2) - (funcall function (car e1) (car e2)))))) + (sort alist (lambda (e1 e2) + (funcall function (car e1) (car e2))))) ;; Not used. '(defmacro edebug-save-restriction (&rest body) @@ -407,14 +406,13 @@ Return the result of the last expression in BODY." (if (listp window-info) (mapcar (lambda (one-window-info) (if one-window-info - (apply (function - (lambda (window buffer point start hscroll) - (if (edebug-window-live-p window) - (progn - (set-window-buffer window buffer) - (set-window-point window point) - (set-window-start window start) - (set-window-hscroll window hscroll))))) + (apply (lambda (window buffer point start hscroll) + (if (edebug-window-live-p window) + (progn + (set-window-buffer window buffer) + (set-window-point window point) + (set-window-start window start) + (set-window-hscroll window hscroll)))) one-window-info))) window-info) (set-window-configuration window-info))) @@ -555,7 +553,7 @@ already is one.)" ;; Compatibility with old versions. -(defalias 'edebug-all-defuns 'edebug-all-defs) +(define-obsolete-function-alias 'edebug-all-defuns #'edebug-all-defs "28.1") ;;;###autoload (defun edebug-all-defs () @@ -594,7 +592,7 @@ already is one.)" "A list of entries associating symbols with buffer regions. Each entry is an `edebug--form-data' struct with fields: SYMBOL, BEGIN-MARKER, and END-MARKER. The markers -are at the beginning and end of an entry level form and SYMBOL is +are at the beginning and end of an instrumented form and SYMBOL is a symbol that holds all edebug related information for the form on its property list. @@ -741,6 +739,21 @@ Maybe clear the markers and delete the symbol's edebug property?" ;;; Offsets for reader +(defun edebug-get-edebug-or-ghost (name) + "Get NAME's value of property `edebug' or property `ghost-edebug'. + +The idea is that should function NAME be recompiled whilst +debugging is in progress, property `edebug' will get set to a +marker. The needed data will then come from property +`ghost-edebug'." + (let ((e (get name 'edebug))) + (if (consp e) + e + (let ((g (get name 'ghost-edebug))) + (if (consp g) + g + e))))) + ;; Define a structure to represent offset positions of expressions. ;; Each offset structure looks like: (before . after) for constituents, ;; or for structures that have elements: (before <subexpressions> . after) @@ -1168,6 +1181,12 @@ purpose by adding an entry to this alist, and setting ;; Not edebugging this form, so reset the symbol's edebug ;; property to be just a marker at the definition's source code. ;; This only works for defs with simple names. + + ;; Preserve the `edebug' property in case there's + ;; debugging still under way. + (let ((ghost (get def-name 'edebug))) + (if (consp ghost) + (put def-name 'ghost-edebug ghost))) (put def-name 'edebug (point-marker)) ;; Also nil out dependent defs. '(mapcar (function @@ -1208,7 +1227,7 @@ purpose by adding an entry to this alist, and setting "Wrap the FORMS of a definition body." (if edebug-def-interactive `(let ((,(edebug-interactive-p-name) - (interactive-p))) + (called-interactively-p 'interactive))) ,(edebug-make-enter-wrapper forms)) (edebug-make-enter-wrapper forms))) @@ -1219,6 +1238,13 @@ purpose by adding an entry to this alist, and setting ;; since it wraps the list of forms with a call to `edebug-enter'. ;; Uses the dynamically bound vars edebug-def-name and edebug-def-args. ;; Do this after parsing since that may find a name. + (when (string-match-p (rx bos "edebug-anon" (+ digit) eos) + (symbol-name edebug-old-def-name)) + ;; FIXME: Due to Bug#42701, we reset an anonymous name so that + ;; backtracking doesn't generate duplicate definitions. It would + ;; be better to not define wrappers in the case of a non-matching + ;; specification branch to begin with. + (setq edebug-old-def-name nil)) (setq edebug-def-name (or edebug-def-name edebug-old-def-name (gensym "edebug-anon"))) `(edebug-enter @@ -1411,6 +1437,8 @@ contains a circular object." (cons window (window-start window))))) ;; Store the edebug data in symbol's property list. + ;; We actually want to remove this property entirely, but can't. + (put edebug-def-name 'ghost-edebug nil) (put edebug-def-name 'edebug ;; A struct or vector would be better here!! (list edebug-form-begin-marker @@ -1423,8 +1451,8 @@ contains a circular object." ))) (defun edebug--restore-breakpoints (name) - (let ((data (get name 'edebug))) - (when (listp data) + (let ((data (edebug-get-edebug-or-ghost name))) + (when (consp data) (let ((offsets (nth 2 data)) (breakpoints (nth 1 data)) (start (nth 0 data)) @@ -1702,18 +1730,22 @@ contains a circular object." (&define . edebug-match-&define) (name . edebug-match-name) (:name . edebug-match-colon-name) + (:unique . edebug-match-:unique) (arg . edebug-match-arg) (def-body . edebug-match-def-body) (def-form . edebug-match-def-form) ;; Less frequently used: ;; (function . edebug-match-function) (lambda-expr . edebug-match-lambda-expr) + (cl-generic-method-qualifier + . edebug-match-cl-generic-method-qualifier) (cl-generic-method-args . edebug-match-cl-generic-method-args) (cl-macrolet-expr . edebug-match-cl-macrolet-expr) (cl-macrolet-name . edebug-match-cl-macrolet-name) (cl-macrolet-body . edebug-match-cl-macrolet-body) (¬ . edebug-match-¬) (&key . edebug-match-&key) + (&error . edebug-match-&error) (place . edebug-match-place) (gate . edebug-match-gate) ;; (nil . edebug-match-nil) not this one - special case it. @@ -1832,9 +1864,6 @@ contains a circular object." ;; This means nothing matched, so it is OK. nil) ;; So, return nothing - -(def-edebug-spec &key edebug-match-&key) - (defun edebug-match-&key (cursor specs) ;; Following specs must look like (<name> <spec>) ... ;; where <name> is the name of a keyword, and spec is its spec. @@ -1847,6 +1876,15 @@ contains a circular object." (car (cdr pair)))) specs)))) +(defun edebug-match-&error (cursor specs) + ;; Signal an error, using the following string in the spec as argument. + (let ((error-string (car specs)) + (edebug-error-point (edebug-before-offset cursor))) + (goto-char edebug-error-point) + (error "%s" + (if (stringp error-string) + error-string + "String expected after &error in edebug-spec")))) (defun edebug-match-gate (_cursor) ;; Simply set the gate to prevent backtracking at this level. @@ -2005,6 +2043,27 @@ contains a circular object." spec)) nil) +(defun edebug-match-:unique (_cursor spec) + "Match a `:unique PREFIX' specifier. +SPEC is the symbol name prefix for `gensym'." + (let ((suffix (gensym spec))) + (setq edebug-def-name + (if edebug-def-name + ;; Construct a new name by appending to previous name. + (intern (format "%s@%s" edebug-def-name suffix)) + suffix))) + nil) + +(defun edebug-match-cl-generic-method-qualifier (cursor) + "Match a QUALIFIER for `cl-defmethod' at CURSOR." + (let ((args (edebug-top-element-required cursor "Expected qualifier"))) + ;; Like in CLOS spec, we support any non-list values. + (unless (atom args) (edebug-no-match cursor "Atom expected")) + ;; Append the arguments to `edebug-def-name' (Bug#42671). + (setq edebug-def-name (intern (format "%s %s" edebug-def-name args))) + (edebug-move-cursor cursor) + (list args))) + (defun edebug-match-cl-generic-method-args (cursor) (let ((args (edebug-top-element-required cursor "Expected arguments"))) (if (not (consp args)) @@ -2105,10 +2164,10 @@ into `edebug--cl-macrolet-defs' which is checked in `edebug-list-form-args'." (def-edebug-spec edebug-spec (&or + edebug-spec-list (vector &rest edebug-spec) ; matches a vector ("vector" &rest edebug-spec) ; matches a vector spec ("quote" symbolp) - edebug-spec-list stringp [edebug-lambda-list-keywordp &rest edebug-spec] [keywordp gate edebug-spec] @@ -2216,6 +2275,8 @@ into `edebug--cl-macrolet-defs' which is checked in `edebug-list-form-args'." (def-edebug-spec nested-backquote-form (&or + ("`" &error "Triply nested backquotes (without commas \"between\" them) \ +are too difficult to instrument") ;; Allow instrumentation of any , or ,@ contained within the (\, ...) or ;; (\,@ ...) matched on the next line. ([&or "," ",@"] backquote-form) @@ -2580,12 +2641,11 @@ See `edebug-behavior-alist' for implementations.") ;; window-start now stored with each function. -;;(defvar edebug-window-start nil) +;;(defvar-local edebug-window-start nil) ;; Remember where each buffers' window starts between edebug calls. ;; This is to avoid spurious recentering. ;; Does this still need to be buffer-local?? ;;(setq-default edebug-window-start nil) -;;(make-variable-buffer-local 'edebug-window-start) ;; Dynamically declared unbound vars @@ -2602,9 +2662,6 @@ See `edebug-behavior-alist' for implementations.") (defvar edebug-previous-result nil) ;; Last result returned. -;; Emacs 19 adds an arg to mark and mark-marker. -(defalias 'edebug-mark-marker 'mark-marker) - (defun edebug--display (value offset-index arg-mode) ;; edebug--display-1 is too big, we should split it. This function ;; here was just introduced to avoid making edebug--display-1 @@ -2755,6 +2812,7 @@ See `edebug-behavior-alist' for implementations.") (edebug-stop)) (edebug-overlay-arrow) + (edebug--overlay-breakpoints edebug-function) (unwind-protect (if (or edebug-stop @@ -2831,9 +2889,8 @@ See `edebug-behavior-alist' for implementations.") ;; But don't restore point if edebug-buffer is current buffer. (if (not (eq edebug-buffer edebug-outside-buffer)) (goto-char edebug-outside-point)) - (if (marker-buffer (edebug-mark-marker)) - ;; Does zmacs-regions need to be nil while doing set-marker? - (set-marker (edebug-mark-marker) edebug-outside-mark)) + (if (marker-buffer (mark-marker)) + (set-marker (mark-marker) edebug-outside-mark)) )) ; unwind-protect ;; None of the following is done if quit or signal occurs. @@ -2844,6 +2901,7 @@ See `edebug-behavior-alist' for implementations.") (goto-char edebug-buffer-outside-point)) ;; ... nothing more. ) + (edebug--overlay-breakpoints-remove (point-min) (point-max)) ;; Could be an option to keep eval display up. (if edebug-eval-buffer (kill-buffer edebug-eval-buffer)) (with-timeout-unsuspend edebug-with-timeout-suspend) @@ -3089,8 +3147,8 @@ before returning. The default is one second." (goto-char edebug-outside-point) (message "Current buffer: %s Point: %s Mark: %s" (current-buffer) (point) - (if (marker-buffer (edebug-mark-marker)) - (marker-position (edebug-mark-marker)) "<not set>")) + (if (marker-buffer (mark-marker)) + (marker-position (mark-marker)) "<not set>")) (sit-for arg) (edebug-pop-to-buffer edebug-buffer (car edebug-window-data))))) @@ -3118,7 +3176,7 @@ before returning. The default is one second." ;; Return (function . index) of the nearest edebug stop point. (let* ((edebug-def-name (edebug-form-data-symbol)) (edebug-data - (let ((data (get edebug-def-name 'edebug))) + (let ((data (edebug-get-edebug-or-ghost edebug-def-name))) (if (or (null data) (markerp data)) (error "%s is not instrumented for Edebug" edebug-def-name)) data)) ; we could do it automatically, if data is a marker. @@ -3155,7 +3213,7 @@ before returning. The default is one second." (if edebug-stop-point (let* ((edebug-def-name (car edebug-stop-point)) (index (cdr edebug-stop-point)) - (edebug-data (get edebug-def-name 'edebug)) + (edebug-data (edebug-get-edebug-or-ghost edebug-def-name)) ;; pull out parts of edebug-data (edebug-def-mark (car edebug-data)) @@ -3196,7 +3254,7 @@ the breakpoint." (if edebug-stop-point (let* ((edebug-def-name (car edebug-stop-point)) (index (cdr edebug-stop-point)) - (edebug-data (get edebug-def-name 'edebug)) + (edebug-data (edebug-get-edebug-or-ghost edebug-def-name)) ;; pull out parts of edebug-data (edebug-def-mark (car edebug-data)) @@ -3228,7 +3286,45 @@ the breakpoint." (setcar (cdr edebug-data) edebug-breakpoints) (goto-char position) - )))) + (edebug--overlay-breakpoints edebug-def-name))))) + +(define-fringe-bitmap 'edebug-breakpoint + "\x3c\x7e\xff\xff\xff\xff\x7e\x3c") + +(defun edebug--overlay-breakpoints (function) + (let* ((data (edebug-get-edebug-or-ghost function)) + (start (nth 0 data)) + (breakpoints (nth 1 data)) + (offsets (nth 2 data))) + ;; First remove all old breakpoint overlays. + (edebug--overlay-breakpoints-remove + start (+ start (aref offsets (1- (length offsets))))) + ;; Then make overlays for the breakpoints (but only when we are in + ;; edebug mode). + (when edebug-active + (dolist (breakpoint breakpoints) + (let* ((pos (+ start (aref offsets (car breakpoint)))) + (overlay (make-overlay pos (1+ pos))) + (face (if (nth 4 breakpoint) + (progn + (overlay-put overlay + 'help-echo "Disabled breakpoint") + (overlay-put overlay + 'face 'edebug-disabled-breakpoint)) + (overlay-put overlay 'help-echo "Breakpoint") + (overlay-put overlay 'face 'edebug-enabled-breakpoint)))) + (overlay-put overlay 'edebug t) + (let ((fringe (make-overlay pos pos))) + (overlay-put fringe 'edebug t) + (overlay-put fringe 'before-string + (propertize + "x" 'display + `(left-fringe edebug-breakpoint ,face))))))))) + +(defun edebug--overlay-breakpoints-remove (start end) + (dolist (overlay (overlays-in start end)) + (when (overlay-get overlay 'edebug) + (delete-overlay overlay)))) (defun edebug-set-breakpoint (arg) "Set the breakpoint of nearest sexp. @@ -3236,9 +3332,9 @@ With prefix argument, make it a temporary breakpoint." (interactive "P") ;; If the form hasn't been instrumented yet, do it now. (when (and (not edebug-active) - (let ((data (get (edebug--form-data-name - (edebug-get-form-data-entry (point))) - 'edebug))) + (let ((data (edebug-get-edebug-or-ghost + (edebug--form-data-name + (edebug-get-form-data-entry (point)))))) (or (null data) (markerp data)))) (edebug-defun)) (edebug-modify-breakpoint t nil arg)) @@ -3252,7 +3348,7 @@ With prefix argument, make it a temporary breakpoint." "Unset all the breakpoints in the current form." (interactive) (let* ((name (edebug-form-data-symbol)) - (breakpoints (nth 1 (get name 'edebug)))) + (breakpoints (nth 1 (edebug-get-edebug-or-ghost name)))) (unless breakpoints (user-error "There are no breakpoints in %s" name)) (save-excursion @@ -3268,12 +3364,13 @@ With prefix argument, make it a temporary breakpoint." (user-error "No stop point near point")) (let* ((name (car stop-point)) (index (cdr stop-point)) - (data (get name 'edebug)) + (data (edebug-get-edebug-or-ghost name)) (breakpoint (assq index (nth 1 data)))) (unless breakpoint (user-error "No breakpoint near point")) (setf (nth 4 breakpoint) - (not (nth 4 breakpoint)))))) + (not (nth 4 breakpoint))) + (edebug--overlay-breakpoints name)))) (defun edebug-set-global-break-condition (expression) "Set `edebug-global-break-condition' to EXPRESSION." @@ -3448,7 +3545,7 @@ instrument cannot be found, signal an error." (goto-char func-marker) (edebug-eval-top-level-form) (list func))) - ((consp func-marker) + ((and (consp func-marker) (consp (symbol-function func))) (message "%s is already instrumented." func) (list func)) (t @@ -3622,8 +3719,8 @@ Return the result of the last expression." ;; for us. (with-current-buffer edebug-outside-buffer ; of edebug-buffer (goto-char edebug-outside-point) - (if (marker-buffer (edebug-mark-marker)) - (set-marker (edebug-mark-marker) edebug-outside-mark)) + (if (marker-buffer (mark-marker)) + (set-marker (mark-marker) edebug-outside-mark)) ,@body) ;; Back to edebug-buffer. Restore rest of inside context. @@ -3667,7 +3764,6 @@ Return the result of the last expression." (prin1-to-string edebug-arg)) (cdr value) ", "))) -(defvar print-readably) ; defined by lemacs ;; Alternatively, we could change the definition of ;; edebug-safe-prin1-to-string to only use these if defined. @@ -3675,8 +3771,7 @@ Return the result of the last expression." (let ((print-escape-newlines t) (print-length (or edebug-print-length print-length)) (print-level (or edebug-print-level print-level)) - (print-circle (or edebug-print-circle print-circle)) - (print-readably nil)) ; lemacs uses this. + (print-circle (or edebug-print-circle print-circle))) (edebug-prin1-to-string value))) (defun edebug-compute-previous-result (previous-value) @@ -3920,7 +4015,6 @@ Options: `edebug-print-circle' `edebug-on-error' `edebug-on-quit' -`edebug-on-signal' `edebug-unwrap-results' `edebug-global-break-condition'" :lighter " *Debugging*" @@ -4223,7 +4317,7 @@ Save DEF-NAME, BEFORE-INDEX and AFTER-INDEX in FRAME." (let* ((index (backtrace-get-index)) (frame (nth index backtrace-frames))) (when (edebug--frame-def-name frame) - (let* ((data (get (edebug--frame-def-name frame) 'edebug)) + (let* ((data (edebug-get-edebug-or-ghost (edebug--frame-def-name frame))) (marker (nth 0 data)) (offsets (nth 2 data))) (pop-to-buffer (marker-buffer marker)) @@ -4307,7 +4401,7 @@ reinstrument it." (let* ((function (edebug-form-data-symbol)) (counts (get function 'edebug-freq-count)) (coverages (get function 'edebug-coverage)) - (data (get function 'edebug)) + (data (edebug-get-edebug-or-ghost function)) (def-mark (car data)) ; mark at def start (edebug-points (nth 2 data)) (i (1- (length edebug-points))) @@ -4360,7 +4454,6 @@ reinstrument it." (defun edebug-temp-display-freq-count () "Temporarily display the frequency count data for the current definition. It is removed when you hit any char." - ;; This seems not to work with Emacs 18.59. It undoes too far. (interactive) (let ((inhibit-read-only t)) (undo-boundary) @@ -4465,7 +4558,7 @@ With prefix argument, make it a temporary breakpoint." (if edebug-stop-point (let* ((edebug-def-name (car edebug-stop-point)) (index (cdr edebug-stop-point)) - (edebug-data (get edebug-def-name 'edebug)) + (edebug-data (edebug-get-edebug-or-ghost edebug-def-name)) (edebug-breakpoints (car (cdr edebug-data))) (edebug-break-data (assq index edebug-breakpoints)) (edebug-break-condition (car (cdr edebug-break-data))) @@ -4479,17 +4572,6 @@ With prefix argument, make it a temporary breakpoint." (edebug-modify-breakpoint t condition arg)) (easy-menu-define edebug-menu edebug-mode-map "Edebug menus" edebug-mode-menus) - -;;; Autoloading of Edebug accessories - -;; edebug-cl-read and cl-read are available from liberte@cs.uiuc.edu -(defun edebug--require-cl-read () - (require 'edebug-cl-read)) - -(if (featurep 'cl-read) - (add-hook 'edebug-setup-hook #'edebug--require-cl-read) - ;; The following causes edebug-cl-read to be loaded when you load cl-read.el. - (add-hook 'cl-read-load-hooks #'edebug--require-cl-read)) ;;; Finalize Loading @@ -4525,7 +4607,6 @@ With prefix argument, make it a temporary breakpoint." (run-with-idle-timer 0 nil #'(lambda () (unload-feature 'edebug))))) (remove-hook 'called-interactively-p-functions #'edebug--called-interactively-skip) - (remove-hook 'cl-read-load-hooks #'edebug--require-cl-read) (edebug-uninstall-read-eval-functions) ;; Continue standard unloading. nil) @@ -4579,5 +4660,7 @@ instrumentation for, defaulting to all functions." (message "Removed edebug instrumentation from %s" (mapconcat #'symbol-name functions ", "))) +(define-obsolete-function-alias 'edebug-mark-marker #'mark-marker "28.1") + (provide 'edebug) ;;; edebug.el ends here diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index f09144c6258..ec1077d447e 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -162,6 +162,59 @@ only one object ever exists." old))) +;;; Named object + +(defclass eieio-named () + ((object-name :initarg :object-name :initform nil)) + "Object with a name." + :abstract t) + +(cl-defmethod eieio-object-name-string ((obj eieio-named)) + "Return a string which is OBJ's name." + (or (slot-value obj 'object-name) + (cl-call-next-method))) + +(cl-defgeneric eieio-object-set-name-string (obj name) + "Set the string which is OBJ's NAME." + (declare (obsolete "inherit from `eieio-named' and use (setf (slot-value OBJ \\='object-name) NAME) instead" "25.1")) + (cl-check-type name string) + (setf (gethash obj eieio--object-names) name)) +(define-obsolete-function-alias + 'object-set-name-string 'eieio-object-set-name-string "24.4") + +(with-suppressed-warnings ((obsolete eieio-object-set-name-string)) + (cl-defmethod eieio-object-set-name-string ((obj eieio-named) name) + "Set the string which is OBJ's NAME." + (cl-check-type name string) + (eieio-oset obj 'object-name name))) + +(cl-defmethod clone ((obj eieio-named) &rest params) + "Clone OBJ, initializing `:parent' to OBJ. +All slots are unbound, except those initialized with PARAMS." + (let* ((newname (and (stringp (car params)) (pop params))) + (nobj (apply #'cl-call-next-method obj params)) + (nm (slot-value nobj 'object-name))) + (eieio-oset nobj 'object-name + (or newname + (if (equal nm (slot-value obj 'object-name)) + (save-match-data + (if (and nm (string-match "-\\([0-9]+\\)" nm)) + (let ((num (1+ (string-to-number + (match-string 1 nm))))) + (concat (substring nm 0 (match-beginning 0)) + "-" (int-to-string num))) + (concat nm "-1"))) + nm))) + nobj)) + +(cl-defmethod make-instance ((class (subclass eieio-named)) &rest args) + (if (not (stringp (car args))) + (cl-call-next-method) + (funcall (if eieio-backward-compatibility #'ignore #'message) + "Obsolete: name passed without :object-name to %S constructor" + class) + (apply #'cl-call-next-method class :object-name args))) + ;;; eieio-persistent ;; ;; For objects which must save themselves to disk. Provides an @@ -252,119 +305,102 @@ being pedantic." (error "Invalid object: %s is not an object of class %s nor a subclass" (car ret) class)) - (setq ret (eieio-persistent-convert-list-to-object ret)) + (setq ret (eieio-persistent-make-instance (car ret) (cdr ret))) (oset ret file filename)) (kill-buffer " *tmp eieio read*")) ret)) -(defun eieio-persistent-convert-list-to-object (inputlist) - "Convert the INPUTLIST, representing object creation to an object. -While it is possible to just `eval' the INPUTLIST, this code instead -validates the existing list, and explicitly creates objects instead of -calling eval. This avoids the possibility of accidentally running -malicious code. - -Note: This function recurses when a slot of :type of some object is -identified, and needing more object creation." - (let* ((objclass (nth 0 inputlist)) - ;; Earlier versions of `object-write' added a string name for - ;; the object, now obsolete. - (slots (nthcdr - (if (stringp (nth 1 inputlist)) 2 1) - inputlist)) - (createslots nil) - (class - (progn - ;; If OBJCLASS is an eieio autoload object, then we need to - ;; load it. - (eieio--full-class-object objclass)))) - - (while slots - (let ((initarg (car slots)) - (value (car (cdr slots)))) - - ;; Make sure that the value proposed for SLOT is valid. - ;; In addition, strip out quotes, list functions, and update - ;; object constructors as needed. - (setq value (eieio-persistent-validate/fix-slot-value - class (eieio--initarg-to-attribute class initarg) value)) - - (push initarg createslots) - (push value createslots) - ) - - (setq slots (cdr (cdr slots)))) - - (apply #'make-instance objclass (nreverse createslots)) - - ;;(eval inputlist) - )) - -(defun eieio-persistent-validate/fix-slot-value (class slot proposed-value) - "Validate that in CLASS, the SLOT with PROPOSED-VALUE is good, then fix. -A limited number of functions, such as quote, list, and valid object -constructor functions are considered valid. -Second, any text properties will be stripped from strings." +(cl-defgeneric eieio-persistent-make-instance (objclass inputlist) + "Convert INPUTLIST, representing slot values, to an instance of OBJCLASS. +Clean slot values, and possibly recursively create additional +objects found there." + (:method + ((objclass (subclass eieio-default-superclass)) inputlist) + + (let* ((name nil) + (slots (if (stringp (car inputlist)) + (progn + ;; Earlier versions of `object-write' added a + ;; string name for the object, now obsolete. + ;; Save as 'name' in case this object is subclass + ;; of eieio-named with no :object-name slot specified. + (setq name (car inputlist)) + (cdr inputlist)) + inputlist)) + (createslots nil)) + ;; If OBJCLASS is an eieio autoload object, then we need to + ;; load it (we don't need the return value). + (eieio--full-class-object objclass) + (while slots + (let ((initarg (car slots)) + (value (car (cdr slots)))) + + ;; Strip out quotes, list functions, and update object + ;; constructors as needed. + (setq value (eieio-persistent-fix-value value)) + + (push initarg createslots) + (push value createslots)) + + (setq slots (cdr (cdr slots)))) + + (let ((newobj (apply #'make-instance objclass (nreverse createslots)))) + + ;; Check for special case of subclass of `eieio-named', and do + ;; name assignment. + (when (and eieio-backward-compatibility + (object-of-class-p newobj 'eieio-named) + (not (oref newobj object-name)) + name) + (oset newobj object-name name)) + + newobj)))) + +(defun eieio-persistent-fix-value (proposed-value) + "Fix PROPOSED-VALUE. +Remove leading quotes from lists, and the symbol `list' from the +head of lists. Explicitly construct any objects found, and strip +any text properties from string values. + +This function will descend into the contents of lists, hash +tables, and vectors." (cond ((consp proposed-value) ;; Lists with something in them need special treatment. - (let* ((slot-idx (- (eieio--slot-name-index class slot) - (eval-when-compile eieio--object-num-slots))) - (type (cl--slot-descriptor-type (aref (eieio--class-slots class) - slot-idx))) - (classtype (eieio-persistent-slot-type-is-class-p type))) - - (cond ((eq (car proposed-value) 'quote) - (car (cdr proposed-value))) - - ;; An empty list sometimes shows up as (list), which is dumb, but - ;; we need to support it for backward compat. - ((and (eq (car proposed-value) 'list) - (= (length proposed-value) 1)) - nil) - - ;; List of object constructors. - ((and (eq (car proposed-value) 'list) - ;; 2nd item is a list. - (consp (car (cdr proposed-value))) - ;; 1st elt of 2nd item is a class name. - (class-p (car (car (cdr proposed-value)))) - ) - - ;; Check the value against the input class type. - ;; If something goes wrong, issue a smart warning - ;; about how a :type is needed for this to work. - (unless (and - ;; Do we have a type? - (consp classtype) (class-p (car classtype))) - (error "In save file, list of object constructors found, but no :type specified for slot %S of type %S" - slot classtype)) - - ;; We have a predicate, but it doesn't satisfy the predicate? - (dolist (PV (cdr proposed-value)) - (unless (child-of-class-p (car PV) (car classtype)) - (error "Invalid object: slot member %s does not match class %s" - (car PV) (car classtype)))) - - ;; We have a list of objects here. Lets load them - ;; in. - (let ((objlist nil)) - (dolist (subobj (cdr proposed-value)) - (push (eieio-persistent-convert-list-to-object subobj) - objlist)) - ;; return the list of objects ... reversed. - (nreverse objlist))) - ;; We have a slot with a single object that can be - ;; saved here. Recurse and evaluate that - ;; sub-object. - ((and classtype - (seq-some - (lambda (elt) - (child-of-class-p (car proposed-value) elt)) - (if (listp classtype) classtype (list classtype)))) - (eieio-persistent-convert-list-to-object - proposed-value)) - (t - proposed-value)))) + (cond ((eq (car proposed-value) 'quote) + (while (eq (car-safe proposed-value) 'quote) + (setq proposed-value (car (cdr proposed-value)))) + proposed-value) + + ;; An empty list sometimes shows up as (list), which is dumb, but + ;; we need to support it for backward compar. + ((and (eq (car proposed-value) 'list) + (= (length proposed-value) 1)) + nil) + + ;; List of object constructors. + ((and (eq (car proposed-value) 'list) + ;; 2nd item is a list. + (consp (car (cdr proposed-value))) + ;; 1st elt of 2nd item is a class name. + (class-p (car (car (cdr proposed-value))))) + + ;; We have a list of objects here. Lets load them + ;; in. + (let ((objlist nil)) + (dolist (subobj (cdr proposed-value)) + (push (eieio-persistent-make-instance + (car subobj) (cdr subobj)) + objlist)) + ;; return the list of objects ... reversed. + (nreverse objlist))) + ;; We have a slot with a single object that can be + ;; saved here. Recurse and evaluate that + ;; sub-object. + ((class-p (car proposed-value)) + (eieio-persistent-make-instance + (car proposed-value) (cdr proposed-value))) + (t + proposed-value))) ;; For hash-tables and vectors, the top-level `read' will not ;; "look inside" member values, so we need to do that ;; explicitly. Because `eieio-override-prin1' is recursive in @@ -375,10 +411,9 @@ Second, any text properties will be stripped from strings." (lambda (key value) (setf (gethash key proposed-value) (if (class-p (car-safe value)) - (eieio-persistent-convert-list-to-object - value) - (eieio-persistent-validate/fix-slot-value - class slot value)))) + (eieio-persistent-make-instance + (car value) (cdr value)) + (eieio-persistent-fix-value value)))) proposed-value) proposed-value) @@ -387,72 +422,18 @@ Second, any text properties will be stripped from strings." (let ((val (aref proposed-value i))) (aset proposed-value i (if (class-p (car-safe val)) - (eieio-persistent-convert-list-to-object - val) - (eieio-persistent-validate/fix-slot-value - class slot val))))) + (eieio-persistent-make-instance + (car val) (cdr val)) + (eieio-persistent-fix-value val))))) proposed-value) - ((stringp proposed-value) - ;; Else, check for strings, remove properties. - (substring-no-properties proposed-value)) - - (t - ;; Else, just return whatever the constant was. - proposed-value)) - ) - -(defun eieio-persistent-slot-type-is-class-p (type) - "Return the class referred to in TYPE. -If no class is referenced there, then return nil." - (cond ((class-p type) - ;; If the type is a class, then return it. - type) - ((and (eq 'list-of (car-safe type)) (class-p (cadr type))) - ;; If it is the type of a list of a class, then return that class and - ;; the type. - (cons (cadr type) type)) - - ((and (symbolp type) (get type 'cl-deftype-handler)) - ;; Macro-expand the type according to cl-deftype definitions. - (eieio-persistent-slot-type-is-class-p - (funcall (get type 'cl-deftype-handler)))) - - ;; FIXME: foo-child should not be a valid type! - ((and (symbolp type) (string-match "-child\\'" (symbol-name type)) - (class-p (intern-soft (substring (symbol-name type) 0 - (match-beginning 0))))) - (unless eieio-backward-compatibility - (error "Use of bogus %S type instead of %S" - type (intern-soft (substring (symbol-name type) 0 - (match-beginning 0))))) - ;; If it is the predicate ending with -child, then return - ;; that class. Unfortunately, in EIEIO, typep of just the - ;; class is the same as if we used -child, so no further work needed. - (intern-soft (substring (symbol-name type) 0 - (match-beginning 0)))) - ;; FIXME: foo-list should not be a valid type! - ((and (symbolp type) (string-match "-list\\'" (symbol-name type)) - (class-p (intern-soft (substring (symbol-name type) 0 - (match-beginning 0))))) - (unless eieio-backward-compatibility - (error "Use of bogus %S type instead of (list-of %S)" - type (intern-soft (substring (symbol-name type) 0 - (match-beginning 0))))) - ;; If it is the predicate ending with -list, then return - ;; that class and the predicate to use. - (cons (intern-soft (substring (symbol-name type) 0 - (match-beginning 0))) - type)) - - ((eq (car-safe type) 'or) - ;; If type is a list, and is an `or', return all valid class - ;; types within the `or' statement. - (seq-filter #'eieio-persistent-slot-type-is-class-p (cdr type))) + ((stringp proposed-value) + ;; Else, check for strings, remove properties. + (substring-no-properties proposed-value)) (t - ;; No match, not a class. - nil))) + ;; Else, just return whatever the constant was. + proposed-value))) (cl-defmethod object-write ((this eieio-persistent) &optional comment) "Write persistent object THIS out to the current stream. @@ -495,59 +476,6 @@ instance." ;; It should also set up some hooks to help it keep itself up to date. -;;; Named object - -(defclass eieio-named () - ((object-name :initarg :object-name :initform nil)) - "Object with a name." - :abstract t) - -(cl-defmethod eieio-object-name-string ((obj eieio-named)) - "Return a string which is OBJ's name." - (or (slot-value obj 'object-name) - (cl-call-next-method))) - -(cl-defgeneric eieio-object-set-name-string (obj name) - "Set the string which is OBJ's NAME." - (declare (obsolete "inherit from `eieio-named' and use (setf (slot-value OBJ \\='object-name) NAME) instead" "25.1")) - (cl-check-type name string) - (setf (gethash obj eieio--object-names) name)) -(define-obsolete-function-alias - 'object-set-name-string 'eieio-object-set-name-string "24.4") - -(with-suppressed-warnings ((obsolete eieio-object-set-name-string)) - (cl-defmethod eieio-object-set-name-string ((obj eieio-named) name) - "Set the string which is OBJ's NAME." - (cl-check-type name string) - (eieio-oset obj 'object-name name))) - -(cl-defmethod clone ((obj eieio-named) &rest params) - "Clone OBJ, initializing `:parent' to OBJ. -All slots are unbound, except those initialized with PARAMS." - (let* ((newname (and (stringp (car params)) (pop params))) - (nobj (apply #'cl-call-next-method obj params)) - (nm (slot-value nobj 'object-name))) - (eieio-oset nobj 'object-name - (or newname - (if (equal nm (slot-value obj 'object-name)) - (save-match-data - (if (and nm (string-match "-\\([0-9]+\\)" nm)) - (let ((num (1+ (string-to-number - (match-string 1 nm))))) - (concat (substring nm 0 (match-beginning 0)) - "-" (int-to-string num))) - (concat nm "-1"))) - nm))) - nobj)) - -(cl-defmethod make-instance ((class (subclass eieio-named)) &rest args) - (if (not (stringp (car args))) - (cl-call-next-method) - (funcall (if eieio-backward-compatibility #'ignore #'message) - "Obsolete: name passed without :object-name to %S constructor" - class) - (apply #'cl-call-next-method class :object-name args))) - (provide 'eieio-base) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index e73afabf9a0..a8361c0d4b4 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -215,7 +215,8 @@ It creates an autoload function for CNAME's constructor." ;; turn this into a usable self-pointing symbol (when eieio-backward-compatibility (set cname cname) - (make-obsolete-variable cname (format "use \\='%s instead" cname) + (make-obsolete-variable cname (format "\ +use \\='%s or turn off `eieio-backward-compatibility' instead" cname) "25.1")) (setf (cl--find-class cname) newc) @@ -587,8 +588,8 @@ If SKIPNIL is non-nil, then if default value is nil return t instead." (defun eieio--add-new-slot (newc slot init alloc &optional defaultoverride skipnil) "Add into NEWC attribute SLOT. -If a slot of that name already exists in NEWC, then do nothing. If it doesn't exist, -INIT is the initarg, if any. +If a slot of that name already exists in NEWC, then do nothing. +If it doesn't exist, INIT is the initarg, if any. Argument ALLOC specifies if the slot is allocated per instance, or per class. If optional DEFAULTOVERRIDE is non-nil, then if A exists in NEWC, we must override its value for a default. @@ -730,7 +731,8 @@ Argument FN is the function calling this verifier." (guard (not (memq name eieio--known-slot-names)))) (macroexp--warn-and-return (format-message "Unknown slot `%S'" name) exp 'compile-only)) - (_ exp))))) + (_ exp)))) + (gv-setter eieio-oset)) (cl-check-type slot symbol) (cl-check-type obj (or eieio-object class)) (let* ((class (cond ((symbolp obj) @@ -755,6 +757,7 @@ Argument FN is the function calling this verifier." (defun eieio-oref-default (obj slot) "Do the work for the macro `oref-default' with similar parameters. Fills in OBJ's SLOT with its default value." + (declare (gv-setter eieio-oset-default)) (cl-check-type obj (or eieio-object class)) (cl-check-type slot symbol) (let* ((cl (cond ((symbolp obj) (cl--find-class obj)) diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el index 24a34b2c012..184b99fdac6 100644 --- a/lisp/emacs-lisp/eieio-custom.el +++ b/lisp/emacs-lisp/eieio-custom.el @@ -33,7 +33,6 @@ (require 'eieio) (require 'widget) (require 'wid-edit) -(require 'custom) ;;; Compatibility @@ -366,8 +365,7 @@ These groups are specified with the `:group' slot flag." (widget-insert "\n\n") (widget-insert "Edit object " (eieio-object-name obj) "\n\n") ;; Create the widget editing the object. - (make-local-variable 'eieio-wo) - (setq eieio-wo (eieio-custom-widget-insert obj :eieio-group g)) + (setq-local eieio-wo (eieio-custom-widget-insert obj :eieio-group g)) ;;Now generate the apply buttons (widget-insert "\n") (eieio-custom-object-apply-reset obj) @@ -376,10 +374,8 @@ These groups are specified with the `:group' slot flag." ;;(widget-minor-mode) (goto-char (point-min)) (widget-forward 3) - (make-local-variable 'eieio-co) - (setq eieio-co obj) - (make-local-variable 'eieio-cog) - (setq eieio-cog g))) + (setq-local eieio-co obj) + (setq-local eieio-cog g))) (cl-defmethod eieio-custom-object-apply-reset ((_obj eieio-default-superclass)) "Insert an Apply and Reset button into the object editor. diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 6e14a38139e..e65f424cbab 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -1,4 +1,4 @@ -;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar) +;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar) -*- lexical-binding: t; -*- ;; Copyright (C) 1996, 1998-2003, 2005, 2008-2021 Free Software ;; Foundation, Inc. @@ -136,9 +136,9 @@ are not abstract." (def (symbol-function ctr))) (goto-char (point-min)) (prin1 ctr) - (insert (format " is an %s object constructor function" + (insert (format " is an %sobject constructor function" (if (autoloadp def) - "autoloaded" + "autoloaded " ""))) (when (and (autoloadp def) (null location)) @@ -278,14 +278,7 @@ are not abstract." (if eieio-class-speedbar-key-map nil - (if (not (featurep 'speedbar)) - (add-hook 'speedbar-load-hook (lambda () - (eieio-class-speedbar-make-map) - (speedbar-add-expansion-list - '("EIEIO" - eieio-class-speedbar-menu - eieio-class-speedbar-key-map - eieio-class-speedbar)))) + (with-eval-after-load 'speedbar (eieio-class-speedbar-make-map) (speedbar-add-expansion-list '("EIEIO" eieio-class-speedbar-menu diff --git a/lisp/emacs-lisp/eieio-speedbar.el b/lisp/emacs-lisp/eieio-speedbar.el index 92a9f2a8de6..8bf77e20dfa 100644 --- a/lisp/emacs-lisp/eieio-speedbar.el +++ b/lisp/emacs-lisp/eieio-speedbar.el @@ -140,11 +140,7 @@ MENU-VAR is the symbol containing an easymenu compatible menu part to use. MODENAME is a string used to identify this browser mode. FETCHER is a generic function used to fetch the base object list used when creating the speedbar display." - (if (not (featurep 'speedbar)) - (add-hook 'speedbar-load-hook - (list 'lambda nil - (list 'eieio-speedbar-create-engine - map-fn map-var menu-var modename fetcher))) + (with-eval-after-load 'speedbar (eieio-speedbar-create-engine map-fn map-var menu-var modename fetcher))) (defun eieio-speedbar-create-engine (map-fn map-var menu-var modename fetcher) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 131997a7ef0..a095ad0f6db 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -351,24 +351,20 @@ Elements of FIELDS can be of the form (NAME PAT) in which case the contents of field NAME is matched against PAT, or they can be of the form NAME which is a shorthand for (NAME NAME)." (declare (debug (&rest [&or (sexp pcase-PAT) sexp]))) - (let ((is (make-symbol "table"))) - ;; FIXME: This generates a horrendous mess of redundant let bindings. - ;; `pcase' needs to be improved somehow to introduce let-bindings more - ;; sparingly, or the byte-compiler needs to be taught to optimize - ;; them away. - ;; FIXME: `pcase' does not do a good job here of sharing tests&code among - ;; various branches. - `(and (pred eieio-object-p) - (app eieio-pcase-slot-index-table ,is) - ,@(mapcar (lambda (field) - (let* ((name (if (consp field) (car field) field)) - (pat (if (consp field) (cadr field) field)) - (i (make-symbol "index"))) - `(and (let (and ,i (pred natnump)) - (eieio-pcase-slot-index-from-index-table - ,is ',name)) - (app (pcase--flip aref ,i) ,pat)))) - fields)))) + ;; FIXME: This generates a horrendous mess of redundant let bindings. + ;; `pcase' needs to be improved somehow to introduce let-bindings more + ;; sparingly, or the byte-compiler needs to be taught to optimize + ;; them away. + ;; FIXME: `pcase' does not do a good job here of sharing tests&code among + ;; various branches. + `(and (pred eieio-object-p) + ,@(mapcar (lambda (field) + (pcase-exhaustive field + (`(,name ,pat) + `(app (pcase--flip eieio-oref ',name) ,pat)) + ((pred symbolp) + `(app (pcase--flip eieio-oref ',field) ,field)))) + fields))) ;;; Simple generators, and query functions. None of these would do ;; well embedded into an object. @@ -649,14 +645,6 @@ If SLOT is unbound, do nothing." nil (eieio-oset object slot (delete item (eieio-oref object slot))))) -;;; Here are some CLOS items that need the CL package -;; - -;; FIXME: Shouldn't this be a more complex gv-expander which extracts the -;; common code between oref and oset, so as to reduce the redundant work done -;; in (push foo (oref bar baz)), like we do for the `nth' expander? -(gv-define-simple-setter eieio-oref eieio-oset) - ;;; ;; We want all objects created by EIEIO to have some default set of @@ -887,7 +875,7 @@ this object." ;; Now output readable lisp to recreate this object ;; It should look like this: ;; (<constructor> <name> <slot> <slot> ... ) - ;; Each slot's slot is writen using its :writer. + ;; Each slot's slot is written using its :writer. (when eieio-print-indentation (princ (make-string (* eieio-print-depth 2) ? ))) (princ "(") diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 7cf5796db09..90e075b1102 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -5,6 +5,11 @@ ;; Author: Noah Friedman <friedman@splode.com> ;; Keywords: extensions ;; Created: 1995-10-06 +;; Version: 1.11.0 +;; Package-Requires: ((emacs "26.3")) + +;; This is a GNU ELPA :core package. Avoid functionality that is not +;; compatible with the version of Emacs recorded above. ;; This file is part of GNU Emacs. @@ -32,20 +37,18 @@ ;; the one-line documentation for that variable instead, to remind you of ;; that variable's meaning. -;; One useful way to enable this minor mode is to put the following in your -;; .emacs: -;; -;; (add-hook 'emacs-lisp-mode-hook 'eldoc-mode) -;; (add-hook 'lisp-interaction-mode-hook 'eldoc-mode) -;; (add-hook 'ielm-mode-hook 'eldoc-mode) -;; (add-hook 'eval-expression-minibuffer-setup-hook 'eldoc-mode) +;; This mode is now enabled by default in all major modes that provide +;; support for it, such as `emacs-lisp-mode'. +;; This is controlled by `global-eldoc-mode'. -;; Major modes for other languages may use ElDoc by defining an -;; appropriate function as the buffer-local value of -;; `eldoc-documentation-function'. +;; Major modes for other languages may use ElDoc by adding an +;; appropriate function to the buffer-local value of +;; `eldoc-documentation-functions'. ;;; Code: +(eval-when-compile (require 'cl-lib)) + (defgroup eldoc nil "Show function arglist or variable docstring in echo area." :group 'lisp @@ -57,20 +60,23 @@ If user input arrives before this interval of time has elapsed after the last input, no documentation will be printed. If this variable is set to 0, no idle time is required." - :type 'number - :group 'eldoc) + :type 'number) (defcustom eldoc-print-after-edit nil "If non-nil eldoc info is only shown when editing. Changing the value requires toggling `eldoc-mode'." + :type 'boolean) + +(defcustom eldoc-echo-area-display-truncation-message t + "If non-nil, provide verbose help when a message has been truncated. +If nil, truncated messages will just have \"...\" appended." :type 'boolean - :group 'eldoc) + :version "28.1") ;;;###autoload (defcustom eldoc-minor-mode-string (purecopy " ElDoc") "String to display in mode line when ElDoc Mode is enabled; nil for none." - :type '(choice string (const :tag "None" nil)) - :group 'eldoc) + :type '(choice string (const :tag "None" nil))) (defcustom eldoc-argument-case #'identity "Case to display argument names of functions, as a symbol. @@ -79,42 +85,55 @@ Actually, any name of a function which takes a string as an argument and returns another string is acceptable. Note that this variable has no effect, unless -`eldoc-documentation-function' handles it explicitly." +`eldoc-documentation-strategy' handles it explicitly." :type '(radio (function-item upcase) (function-item downcase) - function) - :group 'eldoc) + function)) (make-obsolete-variable 'eldoc-argument-case nil "25.1") (defcustom eldoc-echo-area-use-multiline-p 'truncate-sym-name-if-fit - "Allow long ElDoc messages to resize echo area display. -If value is t, never attempt to truncate messages; complete symbol name -and function arglist or 1-line variable documentation will be displayed -even if echo area must be resized to fit. - -If value is any non-nil value other than t, symbol name may be truncated -if it will enable the function arglist or documentation string to fit on a -single line without resizing window. Otherwise, behavior is just like -former case. - -If value is nil, messages are always truncated to fit in a single line of -display in the echo area. Function or variable symbol name may be -truncated to make more of the arglist or documentation string visible. - -Note that this variable has no effect, unless -`eldoc-documentation-function' handles it explicitly." - :type '(radio (const :tag "Always" t) - (const :tag "Never" nil) - (const :tag "Yes, but truncate symbol names if it will\ - enable argument list to fit on one line" truncate-sym-name-if-fit)) - :group 'eldoc) + "Allow long ElDoc doc strings to resize echo area display. +If value is t, never attempt to truncate messages, even if the +echo area must be resized to fit. + +If the value is a positive number, it is used to calculate a +number of logical lines of documentation that ElDoc is allowed to +put in the echo area. If a positive integer, the number is used +directly, while a float specifies the number of lines as a +proporting of the echo area frame's height. + +If value is the symbol `truncate-sym-name-if-fit' t, the part of +the doc string that represents a symbol's name may be truncated +if it will enable the rest of the doc string to fit on a single +line, without resizing the echo area. + +If value is nil, a doc string is always truncated to fit in a +single line of display in the echo area. + +Any resizing of the echo area additionally respects +`max-mini-window-height'." + :type '(radio (const :tag "Always" t) + (float :tag "Fraction of frame height" 0.25) + (integer :tag "Number of lines" 5) + (const :tag "Never" nil) + (const :tag "Yes, but ask major-mode to truncate + symbol names if it will\ enable argument list to fit on one + line" truncate-sym-name-if-fit))) + +(defcustom eldoc-echo-area-prefer-doc-buffer nil + "Prefer ElDoc's documentation buffer if it is showing in some frame. +If this variable's value is t, ElDoc will skip showing +documentation in the echo area if the dedicated documentation +buffer (given by `eldoc-doc-buffer') is being displayed in some +window. If the value is the symbol `maybe', then the echo area +is only skipped if the documentation doesn't fit there." + :type 'boolean) (defface eldoc-highlight-function-argument '((t (:inherit bold))) "Face used for the argument at point in a function's argument list. -Note that this face has no effect unless the `eldoc-documentation-function' -handles it explicitly." - :group 'eldoc) +Note that this face has no effect unless the `eldoc-documentation-strategy' +handles it explicitly.") ;;; No user options below here. @@ -155,7 +174,7 @@ directly. Instead, use `eldoc-add-command' and `eldoc-remove-command'.") This is used to determine if `eldoc-idle-delay' is changed by the user.") (defvar eldoc-message-function #'eldoc-minibuffer-message - "The function used by `eldoc-message' to display messages. + "The function used by `eldoc--message' to display messages. It should receive the same arguments as `message'.") (defun eldoc-edit-message-commands () @@ -182,8 +201,7 @@ area displays information about a function or variable in the text where point is. If point is on a documented variable, it displays the first line of that variable's doc string. Otherwise it displays the argument list of the function called in the -expression point is on." - :group 'eldoc :lighter eldoc-minor-mode-string +expression point is on." :lighter eldoc-minor-mode-string (setq eldoc-last-message nil) (cond ((not (eldoc--supported-p)) @@ -193,24 +211,23 @@ expression point is on." (eldoc-mode (when eldoc-print-after-edit (setq-local eldoc-message-commands (eldoc-edit-message-commands))) - (add-hook 'post-command-hook 'eldoc-schedule-timer nil t) - (add-hook 'pre-command-hook 'eldoc-pre-command-refresh-echo-area nil t)) + (add-hook 'post-command-hook #'eldoc-schedule-timer nil t) + (add-hook 'pre-command-hook #'eldoc-pre-command-refresh-echo-area nil t)) (t (kill-local-variable 'eldoc-message-commands) - (remove-hook 'post-command-hook 'eldoc-schedule-timer t) - (remove-hook 'pre-command-hook 'eldoc-pre-command-refresh-echo-area t) + (remove-hook 'post-command-hook #'eldoc-schedule-timer t) + (remove-hook 'pre-command-hook #'eldoc-pre-command-refresh-echo-area t) (when eldoc-timer (cancel-timer eldoc-timer) (setq eldoc-timer nil))))) ;;;###autoload (define-globalized-minor-mode global-eldoc-mode eldoc-mode turn-on-eldoc-mode - :group 'eldoc :initialize 'custom-initialize-delay :init-value t ;; For `read--expression', the usual global mode mechanism of ;; `change-major-mode-hook' runs in the minibuffer before - ;; `eldoc-documentation-function' is set, so `turn-on-eldoc-mode' + ;; `eldoc-documentation-strategy' is set, so `turn-on-eldoc-mode' ;; does nothing. Configure and enable eldoc from ;; `eval-expression-minibuffer-setup-hook' instead. (if global-eldoc-mode @@ -222,21 +239,25 @@ expression point is on." (defun eldoc--eval-expression-setup () ;; Setup `eldoc', similar to `emacs-lisp-mode'. FIXME: Call ;; `emacs-lisp-mode' itself? - (add-function :before-until (local 'eldoc-documentation-function) - #'elisp-eldoc-documentation-function) + (cond ((<= emacs-major-version 27) + (declare-function elisp-eldoc-documentation-function "elisp-mode") + (with-no-warnings + (add-function :before-until (local 'eldoc-documentation-function) + #'elisp-eldoc-documentation-function))) + (t (add-hook 'eldoc-documentation-functions + #'elisp-eldoc-var-docstring nil t) + (add-hook 'eldoc-documentation-functions + #'elisp-eldoc-funcall nil t) + (setq eldoc-documentation-strategy 'eldoc-documentation-default))) (eldoc-mode +1)) ;;;###autoload (defun turn-on-eldoc-mode () "Turn on `eldoc-mode' if the buffer has ElDoc support enabled. -See `eldoc-documentation-function' for more detail." +See `eldoc-documentation-strategy' for more detail." (when (eldoc--supported-p) (eldoc-mode 1))) -(defun eldoc--supported-p () - "Non-nil if an ElDoc function is set for this buffer." - (not (memq eldoc-documentation-function '(nil ignore)))) - (defun eldoc-schedule-timer () "Ensure `eldoc-timer' is running. @@ -252,7 +273,9 @@ reflect the change." (when (or eldoc-mode (and global-eldoc-mode (eldoc--supported-p))) - (eldoc-print-current-symbol-info)))))) + ;; Don't ignore, but also don't full-on signal errors + (with-demoted-errors "eldoc error: %s" + (eldoc-print-current-symbol-info)) ))))) ;; If user has changed the idle delay, update the timer. (cond ((not (= eldoc-idle-delay eldoc-current-idle-delay)) @@ -277,28 +300,29 @@ Otherwise work like `message'." (or (window-in-direction 'above (minibuffer-window)) (minibuffer-selected-window) (get-largest-window))) - (when mode-line-format - (unless (and (listp mode-line-format) - (assq 'eldoc-mode-line-string mode-line-format)) + (when (and mode-line-format + (not (and (listp mode-line-format) + (assq 'eldoc-mode-line-string mode-line-format)))) (setq mode-line-format (list "" '(eldoc-mode-line-string (" " eldoc-mode-line-string " ")) - mode-line-format)))) + mode-line-format))) (setq eldoc-mode-line-string (when (stringp format-string) (apply #'format-message format-string args))) (force-mode-line-update))) - (apply 'message format-string args))) + (apply #'message format-string args))) -(defun eldoc-message (&optional string) +(make-obsolete + 'eldoc-message "use `eldoc-documentation-functions' instead." "eldoc-1.1.0") +(defun eldoc-message (&optional string) (eldoc--message string)) +(defun eldoc--message (&optional string) "Display STRING as an ElDoc message if it's non-nil. Also store it in `eldoc-last-message' and return that value." (let ((omessage eldoc-last-message)) (setq eldoc-last-message string) - ;; In emacs 19.29 and later, and XEmacs 19.13 and later, all messages - ;; are recorded in a log. Do not put eldoc messages in that log since - ;; they are Legion. + ;; Do not put eldoc messages in the log since they are Legion. ;; Emacs way of preventing log messages. (let ((message-log-max nil)) (cond (eldoc-last-message @@ -311,34 +335,45 @@ Also store it in `eldoc-last-message' and return that value." (and (symbolp command) (intern-soft (symbol-name command) eldoc-message-commands))) -;; This function goes on pre-command-hook for XEmacs or when using idle -;; timers in Emacs. Motion commands clear the echo area for some reason, +;; This function goes on pre-command-hook. +;; Motion commands clear the echo area for some reason, ;; which make eldoc messages flicker or disappear just before motion ;; begins. This function reprints the last eldoc message immediately ;; before the next command executes, which does away with the flicker. ;; This doesn't seem to be required for Emacs 19.28 and earlier. +;; FIXME: The above comment suggests we don't really understand why +;; this is needed. Maybe it's not needed any more, but if it is +;; we should figure out why. (defun eldoc-pre-command-refresh-echo-area () "Reprint `eldoc-last-message' in the echo area." (and eldoc-last-message (not (minibufferp)) ;We don't use the echo area when in minibuffer. (if (and (eldoc-display-message-no-interference-p) (eldoc--message-command-p this-command)) - (eldoc-message eldoc-last-message) - ;; No need to call eldoc-message since the echo area will be cleared + (eldoc--message eldoc-last-message) + ;; No need to call eldoc--message since the echo area will be cleared ;; for us, but do note that the last-message will be gone. (setq eldoc-last-message nil)))) -;; Decide whether now is a good time to display a message. +;; The point of `eldoc--request-state' is not to over-request, which +;; can happen if the idle timer is restarted on execution of command +;; which is guaranteed not to change the conditions that warrant a new +;; request for documentation. +(defvar eldoc--last-request-state nil + "Tuple containing information about last ElDoc request.") +(defun eldoc--request-state () + "Compute information to store in `eldoc--last-request-state'." + (list (current-buffer) (buffer-modified-tick) (point))) + (defun eldoc-display-message-p () - "Return non-nil when it is appropriate to display an ElDoc message." + "Tell if ElDoc can use the echo area." (and (eldoc-display-message-no-interference-p) - ;; If this-command is non-nil while running via an idle - ;; timer, we're still in the middle of executing a command, - ;; e.g. a query-replace where it would be annoying to - ;; overwrite the echo area. (not this-command) (eldoc--message-command-p last-command))) +(make-obsolete 'eldoc-display-message-p + "Use `eldoc-documentation-functions' instead." + "eldoc-1.6.0") ;; Check various conditions about the current environment that might make ;; it undesirable to print eldoc messages right this instant. @@ -347,75 +382,497 @@ Also store it in `eldoc-last-message' and return that value." (not (or executing-kbd-macro (bound-and-true-p edebug-active)))) -;;;###autoload -(defvar eldoc-documentation-function #'ignore - "Function to call to return doc string. -The function of no args should return a one-line string for displaying -doc about a function etc. appropriate to the context around point. -It should return nil if there's no doc appropriate for the context. -Typically doc is returned if point is on a function-like name or in its -arg list. - -The result is used as is, so the function must explicitly handle -the variables `eldoc-argument-case' and `eldoc-echo-area-use-multiline-p', -and the face `eldoc-highlight-function-argument', if they are to have any -effect. - -Major modes should modify this variable using `add-function', for example: - (add-function :before-until (local \\='eldoc-documentation-function) - #\\='foo-mode-eldoc-function) -so that the global documentation function (i.e. the default value of the -variable) is taken into account if the major mode specific function does not +(defvar eldoc-documentation-functions nil + "Hook of functions that produce doc strings. + +A doc string is typically relevant if point is on a function-like +name, inside its arg list, or on any object with some associated +information. + +Each hook function is called with at least one argument CALLBACK, +a function, and decides whether to display a doc short string +about the context around point. + +- If that decision can be taken quickly, the hook function may + call CALLBACK immediately following the protocol described + below. Alternatively it may ignore CALLBACK entirely and + return either the doc string, or nil if there's no doc + appropriate for the context. + +- If the computation of said doc string (or the decision whether + there is one at all) is expensive or can't be performed + directly, the hook function should return a non-nil, non-string + value and arrange for CALLBACK to be called at a later time, + using asynchronous processes or other asynchronous mechanisms. + +To call the CALLBACK function, the hook function must pass it an +obligatory argument DOCSTRING, a string containing the +documentation, followed by an optional list of arbitrary +keyword-value pairs of the form (:KEY VALUE :KEY2 VALUE2...). +The information contained in these pairs is understood by members +of `eldoc-display-functions', allowing the +documentation-producing backend to cooperate with specific +documentation-displaying frontends. For example, KEY can be: + +* `:thing', VALUE being a short string or symbol designating what + is being reported on. It can, for example be the name of the + function whose signature is being documented, or the name of + the variable whose docstring is being documented. + `eldoc-display-in-echo-area', a member of + `eldoc-display-functions', sometimes omits this information + depending on space constraints; + +* `:face', VALUE being a symbol designating a face which both + `eldoc-display-in-echo-area' and `eldoc-display-in-buffer' will + use when displaying `:thing''s value. + +Finally, major modes should modify this hook locally, for +example: + (add-hook \\='eldoc-documentation-functions #\\='foo-mode-eldoc nil t) +so that the global value (i.e. the default value of the hook) is +taken into account if the major mode specific function does not return any documentation.") -(defun eldoc-print-current-symbol-info () - "Print the text produced by `eldoc-documentation-function'." - ;; This is run from post-command-hook or some idle timer thing, - ;; so we need to be careful that errors aren't ignored. - (with-demoted-errors "eldoc error: %s" - (if (not (eldoc-display-message-p)) - ;; Erase the last message if we won't display a new one. - (when eldoc-last-message - (eldoc-message nil)) - (let ((non-essential t)) - ;; Only keep looking for the info as long as the user hasn't - ;; requested our attention. This also locally disables inhibit-quit. - (while-no-input - (eldoc-message (funcall eldoc-documentation-function))))))) - -;; If the entire line cannot fit in the echo area, the symbol name may be -;; truncated or eliminated entirely from the output to make room for the -;; description. -(defun eldoc-docstring-format-sym-doc (prefix doc &optional face) - "Combine PREFIX and DOC, and shorten the result to fit in the echo area. - -When PREFIX is a symbol, propertize its symbol name with FACE -before combining it with DOC. If FACE is not provided, just -apply the nil face. - -See also: `eldoc-echo-area-use-multiline-p'." - (when (symbolp prefix) - (setq prefix (concat (propertize (symbol-name prefix) 'face face) ": "))) - (let* ((ea-multi eldoc-echo-area-use-multiline-p) - ;; Subtract 1 from window width since emacs will not write - ;; any chars to the last column, or in later versions, will - ;; cause a wraparound and resize of the echo area. - (ea-width (1- (window-width (minibuffer-window)))) - (strip (- (+ (length prefix) (length doc)) ea-width))) - (cond ((or (<= strip 0) - (eq ea-multi t) - (and ea-multi (> (length doc) ea-width))) - (concat prefix doc)) - ((> (length doc) ea-width) - (substring (format "%s" doc) 0 ea-width)) - ((>= strip (string-match-p ":? *\\'" prefix)) - doc) +(defvar eldoc-display-functions + '(eldoc-display-in-echo-area eldoc-display-in-buffer) + "Hook of functions tasked with displaying ElDoc results. +Each function is passed two arguments: DOCS and INTERACTIVE. DOCS +is a list (DOC ...) where DOC looks like (STRING :KEY VALUE :KEY2 +VALUE2 ...). STRING is a string containing the documentation's +text and the remainder of DOC is an optional list of +keyword-value pairs denoting additional properties of that +documentation. For commonly recognized properties, see +`eldoc-documentation-functions'. + +INTERACTIVE says if the request to display doc strings came +directly from the user or from ElDoc's automatic mechanisms'.") + +(defvar eldoc--doc-buffer nil "Buffer displaying latest ElDoc-produced docs.") + +(defvar eldoc--doc-buffer-docs nil "Documentation items in `eldoc--doc-buffer'.") + +(defun eldoc-doc-buffer () + "Display ElDoc documentation buffer. + +This holds the results of the last documentation request." + (interactive) + (unless (buffer-live-p eldoc--doc-buffer) + (user-error (format + "ElDoc buffer doesn't exist, maybe `%s' to produce one." + (substitute-command-keys "\\[eldoc]")))) + (with-current-buffer eldoc--doc-buffer + (rename-buffer (replace-regexp-in-string "^ *" "" + (buffer-name))) + (display-buffer (current-buffer)))) + +(defun eldoc--format-doc-buffer (docs) + "Ensure DOCS are displayed in an *eldoc* buffer." + (with-current-buffer (if (buffer-live-p eldoc--doc-buffer) + eldoc--doc-buffer + (setq eldoc--doc-buffer + (get-buffer-create " *eldoc*"))) + (unless (eq docs eldoc--doc-buffer-docs) + (setq-local eldoc--doc-buffer-docs docs) + (let ((inhibit-read-only t) + (things-reported-on)) + (erase-buffer) (setq buffer-read-only t) + (local-set-key "q" 'quit-window) + (cl-loop for (docs . rest) on docs + for (this-doc . plist) = docs + for thing = (plist-get plist :thing) + when thing do + (cl-pushnew thing things-reported-on) + (setq this-doc + (concat + (propertize (format "%s" thing) + 'face (plist-get plist :face)) + ": " + this-doc)) + do (insert this-doc) + when rest do (insert "\n") + finally (goto-char (point-min))) + ;; Rename the buffer, taking into account whether it was + ;; hidden or not + (rename-buffer (format "%s*eldoc%s*" + (if (string-match "^ " (buffer-name)) " " "") + (if things-reported-on + (format " for %s" + (mapconcat + (lambda (s) (format "%s" s)) + things-reported-on + ", ")) + "")))))) + eldoc--doc-buffer) + +(defun eldoc--echo-area-substring (available) + "Given AVAILABLE lines, get buffer substring to display in echo area. +Helper for `eldoc-display-in-echo-area'." + (let ((start (prog1 (progn + (goto-char (point-min)) + (skip-chars-forward " \t\n") + (point)) + (goto-char (line-end-position available)) + (skip-chars-backward " \t\n"))) + (truncated (save-excursion + (skip-chars-forward " \t\n") + (not (eobp))))) + (cond ((eldoc--echo-area-prefer-doc-buffer-p truncated) + nil) + ((and truncated + (> available 1) + eldoc-echo-area-display-truncation-message) + (goto-char (line-end-position 0)) + (concat (buffer-substring start (point)) + (format + "\n(Documentation truncated. Use `%s' to see rest)" + (substitute-command-keys "\\[eldoc-doc-buffer]")))) (t - ;; Show the end of the partial symbol name, rather - ;; than the beginning, since the former is more likely - ;; to be unique given package namespace conventions. - (concat (substring prefix strip) doc))))) + (buffer-substring start (point)))))) + +(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." + (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))) + +(defun eldoc-display-in-echo-area (docs _interactive) + "Display DOCS in echo area. +Honor `eldoc-echo-area-use-multiline-p' and +`eldoc-echo-area-prefer-doc-buffer'." + (cond + (;; Check if he wave permission to mess with echo area at all. For + ;; example, if this-command is non-nil while running via an idle + ;; timer, we're still in the middle of executing a command, e.g. a + ;; query-replace where it would be annoying to overwrite the echo + ;; area. + (or + (not (eldoc-display-message-no-interference-p)) + this-command + (not (eldoc--message-command-p last-command)))) + (;; If we do but nothing to report, clear the echo area. + (null docs) + (eldoc--message nil)) + (t + ;; Otherwise, establish some parameters. + (let* + ((width (1- (window-width (minibuffer-window)))) + (val (if (and (symbolp eldoc-echo-area-use-multiline-p) + eldoc-echo-area-use-multiline-p) + max-mini-window-height + eldoc-echo-area-use-multiline-p)) + (available (cl-typecase val + (float (truncate (* (frame-height) val))) + (integer val) + (t 'just-one-line))) + single-doc single-doc-sym) + (let ((echo-area-message + (cond + (;; To output to the echo area, we handle the + ;; `truncate-sym-name-if-fit' special case first, by + ;; checking for a lot of special conditions. + (and + (eq 'truncate-sym-name-if-fit eldoc-echo-area-use-multiline-p) + (null (cdr docs)) + (setq single-doc (caar docs)) + (setq single-doc-sym + (format "%s" (plist-get (cdar docs) :thing))) + (< (length single-doc) width) + (not (string-match "\n" single-doc)) + (> (+ (length single-doc) (length single-doc-sym) 2) width)) + single-doc) + ((and (numberp available) + (cl-plusp available)) + ;; Else, given a positive number of logical lines, we + ;; format the *eldoc* buffer, using as most of its + ;; contents as we know will fit. + (with-current-buffer (eldoc--format-doc-buffer docs) + (save-excursion + (eldoc--echo-area-substring available)))) + (t ;; this is the "truncate brutally" situation + (let ((string + (with-current-buffer (eldoc--format-doc-buffer docs) + (buffer-substring (goto-char (point-min)) + (line-end-position 1))))) + (if (> (length string) width) ; truncation to happen + (unless (eldoc--echo-area-prefer-doc-buffer-p t) + (truncate-string-to-width string width)) + (unless (eldoc--echo-area-prefer-doc-buffer-p nil) + string))))))) + (when echo-area-message + (eldoc--message echo-area-message))))))) + +(defun eldoc-display-in-buffer (docs interactive) + "Display DOCS in a dedicated buffer. +If INTERACTIVE is t, also display the buffer." + (eldoc--format-doc-buffer docs) + (when interactive + (eldoc-doc-buffer))) + +(defun eldoc-documentation-default () + "Show first doc string for item at point. +Default value for `eldoc-documentation-strategy'." + (run-hook-with-args-until-success 'eldoc-documentation-functions + (eldoc--make-callback :patient))) + +(defun eldoc--documentation-compose-1 (eagerlyp) + "Helper function for composing multiple doc strings. +If EAGERLYP is non-nil show documentation as soon as possible, +else wait for all doc strings." + (run-hook-wrapped 'eldoc-documentation-functions + (lambda (f) + (let* ((callback (eldoc--make-callback + (if eagerlyp :eager :patient))) + (str (funcall f callback))) + (if (or (null str) (stringp str)) (funcall callback str)) + nil))) + t) + +(defun eldoc-documentation-compose () + "Show multiple doc strings at once after waiting for all. +Meant as a value for `eldoc-documentation-strategy'." + (eldoc--documentation-compose-1 nil)) + +(defun eldoc-documentation-compose-eagerly () + "Show multiple doc strings at once as soon as possible. +Meant as a value for `eldoc-documentation-strategy'." + (eldoc--documentation-compose-1 t)) + +(defun eldoc-documentation-enthusiast () + "Show most important doc string produced so far. +Meant as a value for `eldoc-documentation-strategy'." + (run-hook-wrapped 'eldoc-documentation-functions + (lambda (f) + (let* ((callback (eldoc--make-callback :enthusiast)) + (str (funcall f callback))) + (if (stringp str) (funcall callback str)) + nil))) + t) + +;; JT@2020-07-10: ElDoc is pre-loaded, so in Emacs < 28 we can't +;; make the "old" `eldoc-documentation-function' point to the new +;; `eldoc-documentation-strategy', so we do the reverse. This allows +;; for ElDoc to be loaded in those older Emacs versions and work with +;; whomever (major-modes, extensions, user) sets one or the other +;; variable. +(defmacro eldoc--documentation-strategy-defcustom + (main secondary value docstring &rest more) + "Defcustom helper macro for sorting `eldoc-documentation-strategy'." + (declare (indent 2)) + `(if (< emacs-major-version 28) + (progn + (defcustom ,secondary ,value ,docstring ,@more) + (define-obsolete-variable-alias ',main ',secondary "eldoc-1.1.0")) + (progn + (defcustom ,main ,value ,docstring ,@more) + (defvaralias ',secondary ',main ,docstring)))) + +(eldoc--documentation-strategy-defcustom eldoc-documentation-strategy + eldoc-documentation-function + #'eldoc-documentation-default + "How to collect and organize results of `eldoc-documentation-functions'. + +This variable controls how `eldoc-documentation-functions', which +specifies the sources of documentation, is queried and how its +results are organized before being displayed to the user. The +following values are allowed: + +- `eldoc-documentation-default': calls functions in the special + hook in order until one is found that produces a doc string + value. Display only that value; + +- `eldoc-documentation-compose': calls all functions in the + special hook and displays all of the resulting doc strings + together. Wait for all strings to be ready, and preserve their + relative as specified by the order of functions in the hook; + +- `eldoc-documentation-compose-eagerly': calls all functions in + the special hook and display as many of the resulting doc + strings as possible, as soon as possibl. Preserving the + relative order of doc strings; + +- `eldoc-documentation-enthusiast': calls all functions in the + special hook and displays only the most important resulting + docstring one at any given time. A function appearing first in + the special hook is considered more important. + +This variable can also be set to a function of no args that +returns something other than a string or nil and allows for some +or all of the special hook `eldoc-documentation-functions' to be +run. In that case, the strategy function should follow that +other variable's protocol closely and endeavor to display the +resulting doc strings itself. + +For backward compatibility to the \"old\" protocol, this variable +can also be set to a function that returns nil or a doc string, +depending whether or not there is documentation to display at +all." + :link '(info-link "(emacs) Lisp Doc") + :type '(radio (function-item eldoc-documentation-default) + (function-item eldoc-documentation-compose) + (function-item eldoc-documentation-compose-eagerly) + (function-item eldoc-documentation-enthusiast) + (function :tag "Other function")) + :version "28.1") + +(defun eldoc--supported-p () + "Non-nil if an ElDoc function is set for this buffer." + (and (not (memq eldoc-documentation-strategy '(nil ignore))) + (or eldoc-documentation-functions + ;; The old API had major modes set `eldoc-documentation-function' + ;; to provide eldoc support. It's impossible now to determine + ;; reliably whether the `eldoc-documentation-strategy' provides + ;; eldoc support (as in the old API) or whether it just provides + ;; a way to combine the results of the + ;; `eldoc-documentation-functions' (as in the new API). + ;; But at least if it's set buffer-locally it's a good hint that + ;; there's some eldoc support in the current buffer. + (local-variable-p 'eldoc-documentation-strategy)))) + +(defvar eldoc--enthusiasm-curbing-timer nil + "Timer used by the `eldoc-documentation-enthusiast' strategy. +When a doc string is encountered, it must endure a certain amount +of time unchallenged until it is displayed to the user. This +prevents blinking if a lower priority docstring comes in shortly +before a higher priority one.") + +(defalias 'eldoc #'eldoc-print-current-symbol-info) + +;; This variable should be unbound, but that confuses +;; `describe-symbol' for some reason. +(defvar eldoc--make-callback nil "Helper for function `eldoc--make-callback'.") + +;; JT@2020-07-08: the below docstring for the internal function +;; `eldoc--invoke-strategy' could be moved to +;; `eldoc-documentation-strategy' or thereabouts if/when we decide to +;; extend or publish the `make-callback' protocol. +(defun eldoc--make-callback (method) + "Make callback suitable for `eldoc-documentation-functions'. +The return value is a function FN whose lambda list is (STRING +&rest PLIST) and can be called by those functions. Its +responsibility is always to register the docstring STRING along +with options specified in PLIST as the documentation to display +for each particular situation. + +METHOD specifies how the callback behaves relative to other +competing elements in `eldoc-documentation-functions'. It can +have the following values: + +- `:enthusiast' says to display STRING as soon as possible if + there's no higher priority doc string; + +- `:patient' says to display STRING along with all other + competing strings but only when all of all + `eldoc-documentation-functions' have been collected; + +- `:eager' says to display STRING along with all other competing + strings so far, as soon as possible." + (funcall eldoc--make-callback method)) + +(defun eldoc--invoke-strategy (interactive) + "Invoke `eldoc-documentation-strategy' function. + +If INTERACTIVE is non-nil, the request came directly from a user +command, otherwise it came from ElDoc's idle +timer, `eldoc-timer'. + +That function's job is to run the `eldoc-documentation-functions' +special hook, using the `run-hook' family of functions. ElDoc's +built-in strategy functions play along with the +`eldoc--make-callback' protocol, using it to produce a callback +argument to feed the functions that the user places in +`eldoc-documentation-functions'. Whenever the strategy +determines it has information to display to the user, this +function passes responsibility to the functions in +`eldoc-display-functions'. + +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-function' and should endeavour to display +the docstrings eventually produced, using +`eldoc-display-functions'." + (let* (;; How many callbacks have been created by the strategy + ;; function and passed to elements of + ;; `eldoc-documentation-functions'. + (howmany 0) + ;; How many calls to callbacks we're still waiting on. Used + ;; by `:patient'. + (want 0) + ;; The doc strings and corresponding options registered so + ;; far. + (docs-registered '())) + (cl-labels + ((register-doc + (pos string plist) + (when (and string (> (length string) 0)) + (push (cons pos (cons string plist)) docs-registered))) + (display-doc + () + (run-hook-with-args + 'eldoc-display-functions (mapcar #'cdr + (setq docs-registered + (sort docs-registered + (lambda (a b) (< (car a) (car b)))))) + interactive)) + (make-callback + (method) + (let ((pos (prog1 howmany (cl-incf howmany)))) + (cl-ecase method + (:enthusiast + (lambda (string &rest plist) + (when (and string (cl-loop for (p) in docs-registered + never (< p pos))) + (setq docs-registered '()) + (register-doc pos string plist)) + (when (and (timerp eldoc--enthusiasm-curbing-timer) + (memq eldoc--enthusiasm-curbing-timer + timer-list)) + (cancel-timer eldoc--enthusiasm-curbing-timer)) + (setq eldoc--enthusiasm-curbing-timer + (run-at-time (unless (zerop pos) 0.3) + nil #'display-doc)) + t)) + (:patient + (cl-incf want) + (lambda (string &rest plist) + (register-doc pos string plist) + (when (zerop (cl-decf want)) (display-doc)) + t)) + (:eager + (lambda (string &rest plist) + (register-doc pos string plist) + (display-doc) + t)))))) + (let* ((eldoc--make-callback #'make-callback) + (res (funcall eldoc-documentation-strategy))) + ;; Observe the old and the new protocol: + (cond (;; Old protocol: got string, output immediately; + (stringp res) (register-doc 0 res nil) (display-doc)) + (;; Old protocol: got nil, clear the echo area; + (null res) (eldoc--message nil)) + (;; New protocol: trust callback will be called; + t)))))) + +(defun eldoc-print-current-symbol-info (&optional interactive) + "Document thing at point." + (interactive '(t)) + (let (token) + (cond (interactive + (eldoc--invoke-strategy t)) + ((not (equal (setq token (eldoc--request-state)) + eldoc--last-request-state)) + (let ((non-essential t)) + (setq eldoc--last-request-state token) + (eldoc--invoke-strategy nil)))))) + +;; This section only affects ElDoc output to the echo area, as in +;; `eldoc-display-in-echo-area'. +;; ;; When point is in a sexp, the function args are not reprinted in the echo ;; area after every possible interactive command because some of them print ;; their own messages in the echo area; the eldoc functions would instantly @@ -447,7 +904,6 @@ See also: `eldoc-echo-area-use-multiline-p'." (apply #'eldoc-remove-command (all-completions name eldoc-message-commands)))) - ;; Prime the command list. (eldoc-add-command-completions "back-to-indentation" diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el index ccd0c8ade4e..0fba5938f3d 100644 --- a/lisp/emacs-lisp/elint.el +++ b/lisp/emacs-lisp/elint.el @@ -355,15 +355,14 @@ Returns the forms." ;; Env is up to date elint-buffer-forms ;; Remake env - (set (make-local-variable 'elint-buffer-forms) (elint-get-top-forms)) - (set (make-local-variable 'elint-features) nil) - (set (make-local-variable 'elint-buffer-env) - (elint-init-env elint-buffer-forms)) + (setq-local elint-buffer-forms (elint-get-top-forms)) + (setq-local elint-features nil) + (setq-local elint-buffer-env (elint-init-env elint-buffer-forms)) (if elint-preloaded-env ;; FIXME: This doesn't do anything! Should we setq the result to ;; elint-buffer-env? (elint-env-add-env elint-preloaded-env elint-buffer-env)) - (set (make-local-variable 'elint-last-env-time) (buffer-modified-tick)) + (setq-local elint-last-env-time (buffer-modified-tick)) elint-buffer-forms)) (defun elint-get-top-forms () @@ -456,8 +455,8 @@ Return nil if there are no more forms, t otherwise." (= 4 (length form)) (eq (car-safe (cadr form)) 'quote) (equal (nth 2 form) '(quote error-conditions))) - (set (make-local-variable 'elint-extra-errors) - (cons (cadr (cadr form)) elint-extra-errors))) + (setq-local elint-extra-errors + (cons (cadr (cadr form)) elint-extra-errors))) ((eq (car form) 'provide) (add-to-list 'elint-features (eval (cadr form)))) ;; Import variable definitions @@ -522,7 +521,7 @@ Return nil if there are no more forms, t otherwise." "The currently linted top form, or nil.") (defvar elint-top-form-logged nil - "The value t if the currently linted top form has been mentioned in the log buffer.") + "Non-nil if the currently linted top form has been mentioned in the log buffer.") (defun elint-top-form (form) "Lint a top FORM." @@ -559,7 +558,8 @@ Return nil if there are no more forms, t otherwise." (when . elint-check-conditional-form) (unless . elint-check-conditional-form) (and . elint-check-conditional-form) - (or . elint-check-conditional-form)) + (or . elint-check-conditional-form) + (require . elint-require-form)) "Functions to call when some special form should be linted.") (defun elint-form (form env &optional nohandler) @@ -954,6 +954,13 @@ Does basic handling of `featurep' tests." (elint-form form env t)))) env) +(defun elint-require-form (form _env) + "Load `require'd files." + (pcase form + (`(require ',x) + (require x))) + nil) + ;;; ;;; Message functions ;;; diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el index 4fb4a438b26..f551c0c36c3 100644 --- a/lisp/emacs-lisp/elp.el +++ b/lisp/emacs-lisp/elp.el @@ -342,9 +342,9 @@ Use optional LIST if provided instead." (interactive (list (intern - (completing-read "Master function: " obarray - #'elp--instrumented-p - t nil nil (if elp-master (symbol-name elp-master)))))) + (let ((default (if elp-master (symbol-name elp-master)))) + (completing-read (format-prompt "Master function" default) + obarray #'elp--instrumented-p t nil nil default))))) ;; When there's a master function, recording is turned off by default. (setq elp-master funsym elp-record-p nil) diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index a67f42bc386..d058d3dda0b 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -30,6 +30,7 @@ (eval-when-compile (require 'cl-lib)) (require 'ert) +(require 'subr-x) ; string-trim ;;; Test buffers. @@ -177,6 +178,18 @@ test for `called-interactively' in the command will fail." (cl-assert (not unread-command-events) t) return-value)) +(defmacro ert-simulate-keys (keys &rest body) + "Execute BODY with KEYS as pseudo-interactive input." + (declare (debug t) (indent 1)) + `(let ((unread-command-events + ;; Add some C-g to try and make sure we still exit + ;; in case something goes wrong. + (append ,keys '(?\C-g ?\C-g ?\C-g))) + ;; Tell `read-from-minibuffer' not to read from stdin when in + ;; batch mode. + (executing-kbd-macro t)) + ,@body)) + (defun ert-run-idle-timers () "Run all idle timers (from `timer-idle-list')." (dolist (timer (copy-sequence timer-idle-list)) @@ -341,6 +354,46 @@ convert it to a string and pass it to COLLECTOR first." (funcall func object))) (funcall func object printcharfun)))) +(defvar ert-resource-directory-format "%s-resources/" + "Format for `ert-resource-directory'.") +(defvar ert-resource-directory-trim-left-regexp "" + "Regexp for `string-trim' (left) used by `ert-resource-directory'.") +(defvar ert-resource-directory-trim-right-regexp "\\(-tests?\\)?\\.el" + "Regexp for `string-trim' (right) used by `ert-resource-directory'.") + +;; Has to be a macro for `load-file-name'. +(defmacro ert-resource-directory () + "Return absolute file name of the resource (test data) directory. + +The path to the resource directory is the \"resources\" directory +in the same directory as the test file this is called from. + +If that directory doesn't exist, find a directory based on the +test file name. If the file is named \"foo-tests.el\", return +the absolute file name for \"foo-resources\". If you want a +different resource directory naming scheme, set the variable +`ert-resource-directory-format'. Before formatting, the file +name will be trimmed using `string-trim' with arguments +`ert-resource-directory-trim-left-regexp' and +`ert-resource-directory-trim-right-regexp'." + `(let* ((testfile ,(or (bound-and-true-p byte-compile-current-file) + (and load-in-progress load-file-name) + buffer-file-name)) + (default-directory (file-name-directory testfile))) + (file-truename + (if (file-accessible-directory-p "resources/") + (expand-file-name "resources/") + (expand-file-name + (format ert-resource-directory-format + (string-trim testfile + ert-resource-directory-trim-left-regexp + ert-resource-directory-trim-right-regexp))))))) + +(defmacro ert-resource-file (file) + "Return file name of resource file named FILE. +A resource file is in the resource directory as per +`ert-resource-directory'." + `(expand-file-name ,file (ert-resource-directory))) (provide 'ert-x) diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index d519c0ff729..fdbf95319ff 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -58,13 +58,11 @@ ;;; Code: (require 'cl-lib) -(require 'button) (require 'debug) (require 'backtrace) (require 'easymenu) (require 'ewoc) (require 'find-func) -(require 'help) (require 'pp) ;;; UI customization options. @@ -276,7 +274,7 @@ DATA is displayed to the user and should state the reason for skipping." It should only be stopped when ran from inside ert--run-test-internal." (when (and (not (symbolp debugger)) ; only run on anonymous debugger (memq error-symbol '(ert-test-failed ert-test-skipped))) - (funcall debugger 'error data))) + (funcall debugger 'error (list error-symbol data)))) (defun ert--special-operator-p (thing) "Return non-nil if THING is a symbol naming a special operator." @@ -489,7 +487,7 @@ Errors during evaluation are caught and handled like nil." Returns nil if they are." (if (not (eq (type-of a) (type-of b))) `(different-types ,a ,b) - (pcase-exhaustive a + (pcase a ((pred consp) (let ((a-length (proper-list-p a)) (b-length (proper-list-p b))) @@ -515,7 +513,14 @@ Returns nil if they are." `(cdr ,cdr-x) (cl-assert (equal a b) t) nil)))))))) - ((pred arrayp) + ((pred cl-struct-p) + (cl-loop for slot in (cl-struct-slot-info (type-of a)) + for ai across a + for bi across b + for xf = (ert--explain-equal-rec ai bi) + do (when xf (cl-return `(struct-field ,(car slot) ,xf))) + finally (cl-assert (equal a b) t))) + ((or (pred arrayp) (pred recordp)) ;; For mixed unibyte/multibyte string comparisons, make both multibyte. (when (and (stringp a) (xor (multibyte-string-p a) (multibyte-string-p b))) @@ -533,7 +538,7 @@ Returns nil if they are." for xi = (ert--explain-equal-rec ai bi) do (when xi (cl-return `(array-elt ,i ,xi))) finally (cl-assert (equal a b) t)))) - ((pred atom) + (_ (if (not (equal a b)) (if (and (symbolp a) (symbolp b) (string= a b)) `(different-symbols-with-the-same-name ,a ,b) @@ -1298,7 +1303,8 @@ EXPECTEDP specifies whether the result was expected." "Pretty-print OBJECT, indenting it to the current column of point. Ensures a final newline is inserted." (let ((begin (point)) - (pp-escape-newlines nil)) + (pp-escape-newlines nil) + (print-escape-control-characters t)) (pp object (current-buffer)) (unless (bolp) (insert "\n")) (save-excursion @@ -1628,9 +1634,7 @@ Signals an error if no test name was read." nil))) (ert-test (setq default (ert-test-name default)))) (when add-default-to-prompt - (setq prompt (if (null default) - (format "%s: " prompt) - (format "%s (default %s): " prompt default)))) + (setq prompt (format-prompt prompt default))) (let ((input (completing-read prompt obarray #'ert-test-boundp t nil history default nil))) ;; completing-read returns an empty string if default was nil and @@ -1798,8 +1802,8 @@ Also sets `ert--results-progress-bar-button-begin'." ;; `progress-bar-button-begin' will be the right position ;; even in the results buffer. (with-current-buffer results-buffer - (set (make-local-variable 'ert--results-progress-bar-button-begin) - progress-bar-button-begin)))) + (setq-local ert--results-progress-bar-button-begin + progress-bar-button-begin)))) (insert "\n\n") (buffer-string)) ;; footer @@ -1975,15 +1979,15 @@ BUFFER-NAME, if non-nil, is the buffer name to use." ;; from ert-results-mode to ert-results-mode when ;; font-lock-mode turns itself off in change-major-mode-hook.) (erase-buffer) - (set (make-local-variable 'font-lock-function) - 'ert--results-font-lock-function) + (setq-local font-lock-function + 'ert--results-font-lock-function) (let ((ewoc (ewoc-create 'ert--print-test-for-ewoc nil nil t))) - (set (make-local-variable 'ert--results-ewoc) ewoc) - (set (make-local-variable 'ert--results-stats) stats) - (set (make-local-variable 'ert--results-progress-bar-string) - (make-string (ert-stats-total stats) - (ert-char-for-test-result nil t))) - (set (make-local-variable 'ert--results-listener) listener) + (setq-local ert--results-ewoc ewoc) + (setq-local ert--results-stats stats) + (setq-local ert--results-progress-bar-string + (make-string (ert-stats-total stats) + (ert-char-for-test-result nil t))) + (setq-local ert--results-listener listener) (cl-loop for test across (ert--stats-tests stats) do (ewoc-enter-last ewoc (make-ert--ewoc-entry :test test @@ -2016,9 +2020,7 @@ and how to display message." (car ert--selector-history) "t"))) (read - (completing-read (if (null default) - "Run tests: " - (format "Run tests (default %s): " default)) + (completing-read (format-prompt "Run tests" default) obarray #'ert-test-boundp nil nil 'ert--selector-history default nil))) nil)) diff --git a/lisp/emacs-lisp/ewoc.el b/lisp/emacs-lisp/ewoc.el index c65837986d1..d3ace97945f 100644 --- a/lisp/emacs-lisp/ewoc.el +++ b/lisp/emacs-lisp/ewoc.el @@ -205,15 +205,26 @@ NODE and leaving the new node's start there. Return the new node." (defun ewoc--refresh-node (pp node dll) "Redisplay the element represented by NODE using the pretty-printer PP." - (let ((inhibit-read-only t) - (m (ewoc--node-start-marker node)) - (R (ewoc--node-right node))) - ;; First, remove the string from the buffer: - (delete-region m (ewoc--node-start-marker R)) - ;; Calculate and insert the string. - (goto-char m) - (funcall pp (ewoc--node-data node)) - (ewoc--adjust m (point) R dll))) + (let* ((m (ewoc--node-start-marker node)) + (R (ewoc--node-right node)) + (end (ewoc--node-start-marker R)) + (inhibit-read-only t) + (offset (if (= (point) end) + 'end + (when (< m (point) end) + (- (point) m))))) + (save-excursion + ;; First, remove the string from the buffer: + (delete-region m end) + ;; Calculate and insert the string. + (goto-char m) + (funcall pp (ewoc--node-data node)) + (setq end (point)) + (ewoc--adjust m (point) R dll)) + (when offset + (goto-char (if (eq offset 'end) + end + (min (+ m offset) (1- end))))))) (defun ewoc--wrap (func) (lambda (data) @@ -342,11 +353,10 @@ arguments will be passed to MAP-FUNCTION." ((footer (ewoc--footer ewoc)) (pp (ewoc--pretty-printer ewoc)) (node (ewoc--node-nth dll 1))) - (save-excursion - (while (not (eq node footer)) - (if (apply map-function (ewoc--node-data node) args) - (ewoc--refresh-node pp node dll)) - (setq node (ewoc--node-next dll node)))))) + (while (not (eq node footer)) + (if (apply map-function (ewoc--node-data node) args) + (ewoc--refresh-node pp node dll)) + (setq node (ewoc--node-next dll node))))) (defun ewoc-delete (ewoc &rest nodes) "Delete NODES from EWOC." @@ -461,9 +471,8 @@ If the EWOC is empty, nil is returned." Delete current text first, thus effecting a \"refresh\"." (ewoc--set-buffer-bind-dll-let* ewoc ((pp (ewoc--pretty-printer ewoc))) - (save-excursion - (dolist (node nodes) - (ewoc--refresh-node pp node dll))))) + (dolist (node nodes) + (ewoc--refresh-node pp node dll)))) (defun ewoc-goto-prev (ewoc arg) "Move point to the ARGth previous element in EWOC. @@ -566,9 +575,8 @@ Return nil if the buffer has been deleted." (hf-pp (ewoc--hf-pp ewoc))) (setf (ewoc--node-data head) header (ewoc--node-data foot) footer) - (save-excursion - (ewoc--refresh-node hf-pp head dll) - (ewoc--refresh-node hf-pp foot dll)))) + (ewoc--refresh-node hf-pp head dll) + (ewoc--refresh-node hf-pp foot dll))) (provide 'ewoc) diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 0cbd2145432..c399a682f70 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -61,7 +61,7 @@ "^\\s-*(\\(def\\(ine-skeleton\\|ine-generic-mode\\|ine-derived-mode\\|\ ine\\(?:-global\\)?-minor-mode\\|ine-compilation-mode\\|un-cvs-mode\\|\ foo\\|\\(?:[^icfgv]\\|g[^r]\\)\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\ -menu-bar-make-toggle\\)" +menu-bar-make-toggle\\|menu-bar-make-toggle-command\\)" find-function-space-re "\\('\\|(quote \\)?%s\\(\\s-\\|$\\|[()]\\)") "The regexp used by `find-function' to search for a function definition. @@ -103,7 +103,7 @@ Please send improvements and fixes to the maintainer." (defcustom find-feature-regexp (concat ";;; Code:") - "The regexp used by `xref-find-definitions' when searching for a feature definition. + "Regexp used by `xref-find-definitions' when searching for a feature definition. Note it may contain up to one `%s' at the place where `format' should insert the feature name." ;; We search for ";;; Code" rather than (feature '%s) because the @@ -279,25 +279,17 @@ Interactively, prompt for LIBRARY using the one at or near point." (switch-to-buffer (find-file-noselect (find-library-name library))) (run-hooks 'find-function-after-hook))) +;;;###autoload (defun read-library-name () "Read and return a library name, defaulting to the one near point. A library name is the filename of an Emacs Lisp library located in a directory under `load-path' (or `find-function-source-path', if non-nil)." - (let* ((suffix-regexp (mapconcat - (lambda (suffix) - (concat (regexp-quote suffix) "\\'")) - (find-library-suffixes) - "\\|")) - (table (cl-loop for dir in (or find-function-source-path load-path) - when (file-readable-p dir) - append (mapcar - (lambda (file) - (replace-regexp-in-string suffix-regexp - "" file)) - (directory-files dir nil - suffix-regexp)))) + (let* ((dirs (or find-function-source-path load-path)) + (suffixes (find-library-suffixes)) + (table (apply-partially 'locate-file-completion-table + dirs suffixes)) (def (if (eq (function-called-at-point) 'require) ;; `function-called-at-point' may return 'require ;; with `point' anywhere on this line. So wrap the @@ -313,9 +305,7 @@ if non-nil)." (thing-at-point 'symbol)))) (when (and def (not (test-completion def table))) (setq def nil)) - (completing-read (if def - (format "Library name (default %s): " def) - "Library name: ") + (completing-read (format-prompt "Library name" def) table nil nil nil nil def))) ;;;###autoload @@ -399,7 +389,70 @@ The search is done in the source for library LIBRARY." (progn (beginning-of-line) (cons (current-buffer) (point))) - (cons (current-buffer) nil))))))))) + ;; If the regexp search didn't find the location of + ;; the symbol (for example, because it is generated by + ;; a macro), try a slightly more expensive search that + ;; expands macros until it finds the symbol. + (cons (current-buffer) + (find-function--search-by-expanding-macros + (current-buffer) symbol type)))))))))) + +(defun find-function--try-macroexpand (form) + "Try to macroexpand FORM in full or partially. +This is a best-effort operation in which if macroexpansion fails, +this function returns FORM as is." + (ignore-errors + (or + (macroexpand-all form) + (macroexpand-1 form) + form))) + +(defun find-function--any-subform-p (form pred) + "Walk FORM and apply PRED to its subexpressions. +Return t if any PRED returns t." + (cond + ((not (consp form)) nil) + ((funcall pred form) t) + (t + (cl-destructuring-bind (left-child . right-child) form + (or + (find-function--any-subform-p left-child pred) + (find-function--any-subform-p right-child pred)))))) + +(defun find-function--search-by-expanding-macros (buf symbol type) + "Expand macros in BUF to search for the definition of SYMBOL of TYPE." + (catch 'found + (with-current-buffer buf + (save-excursion + (goto-char (point-min)) + (condition-case nil + (while t + (let ((form (read (current-buffer))) + (expected-symbol-p + (lambda (form) + (cond + ((null type) + ;; Check if a given form is a `defalias' to + ;; SYM, the function name we are searching + ;; for. All functions in Emacs Lisp + ;; ultimately expand to a `defalias' form + ;; after several steps of macroexpansion. + (and (eq (car-safe form) 'defalias) + (equal (car-safe (cdr form)) + `(quote ,symbol)))) + ((eq type 'defvar) + ;; Variables generated by macros ultimately + ;; expand to `defvar'. + (and (eq (car-safe form) 'defvar) + (eq (car-safe (cdr form)) symbol))) + (t nil))))) + (when (find-function--any-subform-p + (find-function--try-macroexpand form) + expected-symbol-p) + ;; We want to return the location at the beginning + ;; of the macro, so move back one sexp. + (throw 'found (progn (backward-sexp) (point)))))) + (end-of-file nil)))))) (defun find-function-library (function &optional lisp-only verbose) "Return the pair (ORIG-FUNCTION . LIBRARY) for FUNCTION. @@ -483,12 +536,10 @@ otherwise uses `variable-at-point'." (prompt-type (cdr (assq type '((nil . "function") (defvar . "variable") (defface . "face"))))) - (prompt (concat "Find " prompt-type - (and symb (format " (default %s)" symb)) - ": ")) (enable-recursive-minibuffers t)) (list (intern (completing-read - prompt obarray predicate + (format-prompt "Find %s" symb prompt-type) + obarray predicate t nil nil (and symb (symbol-name symb))))))) (defun find-function-do-it (symbol type switch-fn) diff --git a/lisp/emacs-lisp/float-sup.el b/lisp/emacs-lisp/float-sup.el index a245f6fe2e6..4256bd59584 100644 --- a/lisp/emacs-lisp/float-sup.el +++ b/lisp/emacs-lisp/float-sup.el @@ -1,4 +1,4 @@ -;;; float-sup.el --- define some constants useful for floating point numbers. +;;; float-sup.el --- define some constants useful for floating point numbers. -*- lexical-binding:t -*- ;; Copyright (C) 1985-1987, 2001-2021 Free Software Foundation, Inc. diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el index 13aec1e6785..9eb6d959645 100644 --- a/lisp/emacs-lisp/generator.el +++ b/lisp/emacs-lisp/generator.el @@ -153,7 +153,7 @@ DYNAMIC-VAR bound to STATIC-VAR." (defun cps--add-state (kind body) "Create a new CPS state of KIND with BODY and return the state's name." (declare (indent 1)) - (let* ((state (cps--gensym "cps-state-%s-" kind))) + (let ((state (cps--gensym "cps-state-%s-" kind))) (push (list state body cps--cleanup-function) cps--states) (push state cps--bindings) state)) @@ -673,7 +673,7 @@ When called as a function, NAME returns an iterator value that encapsulates the state of a computation that produces a sequence of values. Callers can retrieve each value using `iter-next'." (declare (indent defun) - (debug (&define name lambda-list lambda-doc def-body)) + (debug (&define name lambda-list lambda-doc &rest sexp)) (doc-string 3)) (cl-assert lexical-binding) (let* ((parsed-body (macroexp-parse-body body)) @@ -687,14 +687,14 @@ of values. Callers can retrieve each value using `iter-next'." "Return a lambda generator. `iter-lambda' is to `iter-defun' as `lambda' is to `defun'." (declare (indent defun) - (debug (&define lambda-list lambda-doc def-body))) + (debug (&define lambda-list lambda-doc &rest sexp))) (cl-assert lexical-binding) `(lambda ,arglist ,(cps-generate-evaluator body))) (defmacro iter-make (&rest body) "Return a new iterator." - (declare (debug t)) + (declare (debug (&rest sexp))) (cps-generate-evaluator body)) (defconst iter-empty (lambda (_op _val) (signal 'iter-end-of-sequence nil)) @@ -720,7 +720,7 @@ is blocked." Evaluate BODY with VAR bound to each value from ITERATOR. Return the value with which ITERATOR finished iteration." (declare (indent 1) - (debug ((symbolp form) body))) + (debug ((symbolp form) &rest sexp))) (let ((done-symbol (cps--gensym "iter-do-iterator-done")) (condition-symbol (cps--gensym "iter-do-condition")) (it-symbol (cps--gensym "iter-do-iterator")) diff --git a/lisp/emacs-lisp/generic.el b/lisp/emacs-lisp/generic.el index 56643906fbb..294aba66c3a 100644 --- a/lisp/emacs-lisp/generic.el +++ b/lisp/emacs-lisp/generic.el @@ -1,4 +1,4 @@ -;;; generic.el --- defining simple major modes with comment and font-lock +;;; generic.el --- defining simple major modes with comment and font-lock -*- lexical-binding: t; -*- ;; ;; Copyright (C) 1997, 1999, 2001-2021 Free Software Foundation, Inc. ;; @@ -96,9 +96,8 @@ ;; Internal Variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar generic-font-lock-keywords nil +(defvar-local generic-font-lock-keywords nil "Keywords for `font-lock-defaults' in a generic mode.") -(make-variable-buffer-local 'generic-font-lock-keywords) ;;;###autoload (defvar generic-mode-list nil @@ -116,6 +115,10 @@ instead (which see).") function-list &optional docstring) "Create a new generic mode MODE. +A \"generic\" mode is a simple major mode with basic support for +comment syntax and Font Lock mode, but otherwise does not have +any special keystrokes or functionality available. + MODE is the name of the command for the generic mode; don't quote it. The optional DOCSTRING is the documentation for the mode command. If you do not supply it, `define-generic-mode' uses a default @@ -241,7 +244,6 @@ Some generic modes are defined in `generic-x.el'." "Set up comment functionality for generic mode." (let ((chars nil) (comstyles) - (comstyle "") (comment-start nil)) ;; Go through all the comments. @@ -265,14 +267,16 @@ Some generic modes are defined in `generic-x.el'." ;; Store the relevant info but don't update yet. (push (cons c0 (concat (cdr (assoc c0 chars)) "1")) chars) (push (cons c1 (concat (cdr (assoc c1 chars)) - (concat "2" comstyle))) chars))) + (concat "2" comstyle))) + chars))) (if (= (length end) 1) (modify-syntax-entry (aref end 0) (concat ">" comstyle) st) (let ((c0 (aref end 0)) (c1 (aref end 1))) ;; Store the relevant info but don't update yet. (push (cons c0 (concat (cdr (assoc c0 chars)) - (concat "3" comstyle))) chars) + (concat "3" comstyle))) + chars) (push (cons c1 (concat (cdr (assoc c1 chars)) "4")) chars))))) ;; Process the chars that were part of a 2-char comment marker diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 4d2bcbfaf5f..29f8230e6b8 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -166,15 +166,25 @@ 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)))) +;; Additions for `declare'. We specify the values as named aliases so +;; that `describe-variable' prints something useful; cf. Bug#40491. + +;;;###autoload +(defsubst gv--expander-defun-declaration (&rest args) + (apply #'gv--defun-declaration 'gv-expander args)) + +;;;###autoload +(defsubst gv--setter-defun-declaration (&rest args) + (apply #'gv--defun-declaration 'gv-setter args)) + ;;;###autoload (or (assq 'gv-expander defun-declarations-alist) - (let ((x `(gv-expander - ,(apply-partially #'gv--defun-declaration 'gv-expander)))) + (let ((x (list 'gv-expander #'gv--expander-defun-declaration))) (push x macro-declarations-alist) (push x defun-declarations-alist))) ;;;###autoload (or (assq 'gv-setter defun-declarations-alist) - (push `(gv-setter ,(apply-partially #'gv--defun-declaration 'gv-setter)) + (push (list 'gv-setter #'gv--setter-defun-declaration) defun-declarations-alist)) ;; (defmacro gv-define-expand (name expander) @@ -214,7 +224,7 @@ The first arg in ARGLIST (the one that receives VAL) receives an expression which can do arbitrary things, whereas the other arguments are all guaranteed to be pure and copyable. Example use: (gv-define-setter aref (v a i) \\=`(aset ,a ,i ,v))" - (declare (indent 2) (debug (&define name sexp def-body))) + (declare (indent 2) (debug (&define name :name gv-setter sexp def-body))) `(gv-define-expander ,name (lambda (do &rest args) (declare-function @@ -407,6 +417,17 @@ The return value is the last VAL in the list. `(delq ,p ,getter)))))) ,v)))))))))) +(gv-define-expander plist-get + (lambda (do plist prop) + (macroexp-let2 macroexp-copyable-p key prop + (gv-letplace (getter setter) plist + (macroexp-let2 nil p `(cdr (plist-member ,getter ,key)) + (funcall do + `(car ,p) + (lambda (val) + `(if ,p + (setcar ,p ,val) + ,(funcall setter `(cons ,key (cons ,val ,getter))))))))))) ;;; Some occasionally handy extensions. @@ -483,6 +504,11 @@ The return value is the last VAL in the list. (funcall do `(funcall (car ,gv)) (lambda (v) `(funcall (cdr ,gv) ,v)))))))) +(put 'error 'gv-expander + (lambda (do &rest args) + (funcall do `(error . ,args) + (lambda (v) `(progn ,v (error . ,args)))))) + (defmacro gv-synthetic-place (getter setter) "Special place described by its setter and getter. GETTER and SETTER (typically obtained via `gv-letplace') get and @@ -517,9 +543,12 @@ This macro only makes sense when used in a place." (gv-letplace (dgetter dsetter) d (funcall do `(cons ,agetter ,dgetter) - (lambda (v) `(progn - ,(funcall asetter `(car ,v)) - ,(funcall dsetter `(cdr ,v))))))))) + (lambda (v) + (macroexp-let2 nil v v + `(progn + ,(funcall asetter `(car ,v)) + ,(funcall dsetter `(cdr ,v)) + ,v)))))))) (put 'logand 'gv-expander (lambda (do place &rest masks) @@ -529,9 +558,12 @@ This macro only makes sense when used in a place." (funcall do `(logand ,getter ,mask) (lambda (v) - (funcall setter - `(logior (logand ,v ,mask) - (logand ,getter (lognot ,mask)))))))))) + (macroexp-let2 nil v v + `(progn + ,(funcall setter + `(logior (logand ,v ,mask) + (logand ,getter (lognot ,mask)))) + ,v)))))))) ;;; References diff --git a/lisp/emacs-lisp/helper.el b/lisp/emacs-lisp/helper.el index 737f3ec2f33..a5f21a55924 100644 --- a/lisp/emacs-lisp/helper.el +++ b/lisp/emacs-lisp/helper.el @@ -1,4 +1,4 @@ -;;; helper.el --- utility help package supporting help in electric modes +;;; helper.el --- utility help package supporting help in electric modes -*- lexical-binding: t; -*- ;; Copyright (C) 1985, 2001-2021 Free Software Foundation, Inc. @@ -39,20 +39,19 @@ ;; keymap either. -(defvar Helper-help-map nil) -(if Helper-help-map - nil - (setq Helper-help-map (make-keymap)) - ;(fillarray Helper-help-map 'undefined) - (define-key Helper-help-map "m" 'Helper-describe-mode) - (define-key Helper-help-map "b" 'Helper-describe-bindings) - (define-key Helper-help-map "c" 'Helper-describe-key-briefly) - (define-key Helper-help-map "k" 'Helper-describe-key) - ;(define-key Helper-help-map "f" 'Helper-describe-function) - ;(define-key Helper-help-map "v" 'Helper-describe-variable) - (define-key Helper-help-map "?" 'Helper-help-options) - (define-key Helper-help-map (char-to-string help-char) 'Helper-help-options) - (fset 'Helper-help-map Helper-help-map)) +(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)) (defun Helper-help-scroller () (let ((blurb (or (and (boundp 'Helper-return-blurb) diff --git a/lisp/emacs-lisp/hierarchy.el b/lisp/emacs-lisp/hierarchy.el new file mode 100644 index 00000000000..7466fc85df1 --- /dev/null +++ b/lisp/emacs-lisp/hierarchy.el @@ -0,0 +1,579 @@ +;;; hierarchy.el --- Library to create and display hierarchy structures -*- lexical-binding: t; -*- + +;; Copyright (C) 2020-2021 Free Software Foundation, Inc. + +;; Author: Damien Cassou <damien@cassou.me> +;; Maintainer: emacs-devel@gnu.org + +;; 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: + +;; Library to create, query, navigate and display hierarchy structures. + +;; Creation: After having created a hierarchy with `hierarchy-new', +;; populate it by calling `hierarchy-add-tree' or +;; `hierarchy-add-trees'. You can then optionally sort its element +;; with `hierarchy-sort'. + +;; Querying: You can learn more about your hierarchy by using +;; functions such as `hierarchy-roots', `hierarchy-has-item', +;; `hierarchy-length', `hierarchy-parent', `hierarchy-descendant-p'. + +;; Navigation: When your hierarchy is ready, you can use +;; `hierarchy-map-item', `hierarchy-map', and `map-tree' to apply +;; functions to elements of the hierarchy. + +;; Display: You can display a hierarchy as a tabulated list using +;; `hierarchy-tabulated-display' and as an expandable/foldable tree +;; using `hierarchy-convert-to-tree-widget'. The +;; `hierarchy-labelfn-*' functions will help you display each item of +;; the hierarchy the way you want it. + +;;; Limitation: + +;; - Current implementation uses #'equal to find and distinguish +;; elements. Support for user-provided equality definition is +;; desired but not yet implemented; +;; +;; - nil can't be added to a hierarchy; +;; +;; - the hierarchy is computed eagerly. + +;;; Code: + +(require 'seq) +(require 'map) +(require 'subr-x) +(require 'cl-lib) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Helpers +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(cl-defstruct (hierarchy + (:constructor hierarchy--make) + (:conc-name hierarchy--)) + (roots (list)) ; list of the hierarchy roots (no parent) + (parents (make-hash-table :test 'equal)) ; map an item to its parent + (children (make-hash-table :test 'equal)) ; map an item to its childre + ;; cache containing the set of all items in the hierarchy + (seen-items (make-hash-table :test 'equal))) ; map an item to t + +(defun hierarchy--seen-items-add (hierarchy item) + "In HIERARCHY, add ITEM to seen items." + (map-put! (hierarchy--seen-items hierarchy) item t)) + +(defun hierarchy--compute-roots (hierarchy) + "Search roots of HIERARCHY and return them." + (cl-set-difference + (map-keys (hierarchy--seen-items hierarchy)) + (map-keys (hierarchy--parents hierarchy)) + :test #'equal)) + +(defun hierarchy--sort-roots (hierarchy sortfn) + "Compute, sort and store the roots of HIERARCHY. + +SORTFN is a function taking two items of the hierarchy as parameter and +returning non-nil if the first parameter is lower than the second." + (setf (hierarchy--roots hierarchy) + (sort (hierarchy--compute-roots hierarchy) + sortfn))) + +(defun hierarchy--add-relation (hierarchy item parent acceptfn) + "In HIERARCHY, add ITEM as child of PARENT. + +ACCEPTFN is a function returning non-nil if its parameter (any object) +should be an item of the hierarchy." + (let* ((existing-parent (hierarchy-parent hierarchy item)) + (has-parent-p (funcall acceptfn existing-parent))) + (cond + ((and has-parent-p (not (equal existing-parent parent))) + (error "An item (%s) can only have one parent: '%s' vs '%s'" + item existing-parent parent)) + ((not has-parent-p) + (let ((existing-children (map-elt (hierarchy--children hierarchy) + parent (list)))) + (map-put! (hierarchy--children hierarchy) + parent (append existing-children (list item)))) + (map-put! (hierarchy--parents hierarchy) item parent))))) + +(defun hierarchy--set-equal (list1 list2 &rest cl-keys) + "Return non-nil if LIST1 and LIST2 have same elements. + +I.e., if every element of LIST1 also appears in LIST2 and if +every element of LIST2 also appears in LIST1. + +CL-KEYS are key-value pairs just like in `cl-subsetp'. Supported +keys are :key and :test." + (and (apply 'cl-subsetp list1 list2 cl-keys) + (apply 'cl-subsetp list2 list1 cl-keys))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Creation +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun hierarchy-new () + "Create a hierarchy and return it." + (hierarchy--make)) + +(defun hierarchy-add-tree (hierarchy item parentfn &optional childrenfn acceptfn) + "In HIERARCHY, add ITEM. + +PARENTFN is either nil or a function defining the child-to-parent +relationship: this function takes an item as parameter and should return +the parent of this item in the hierarchy. If the item has no parent in the +hierarchy (i.e., it should be a root), the function should return an object +not accepted by acceptfn (i.e., nil for the default value of acceptfn). + +CHILDRENFN is either nil or a function defining the parent-to-children +relationship: this function takes an item as parameter and should return a +list of children of this item in the hierarchy. + +If both PARENTFN and CHILDRENFN are non-nil, the results of PARENTFN and +CHILDRENFN are expected to be coherent with each other. + +ACCEPTFN is a function returning non-nil if its parameter (any object) +should be an item of the hierarchy. By default, ACCEPTFN returns non-nil +if its parameter is non-nil." + (unless (hierarchy-has-item hierarchy item) + (let ((acceptfn (or acceptfn #'identity))) + (hierarchy--seen-items-add hierarchy item) + (let ((parent (and parentfn (funcall parentfn item)))) + (when (funcall acceptfn parent) + (hierarchy--add-relation hierarchy item parent acceptfn) + (hierarchy-add-tree hierarchy parent parentfn childrenfn))) + (let ((children (and childrenfn (funcall childrenfn item)))) + (mapc (lambda (child) + (when (funcall acceptfn child) + (hierarchy--add-relation hierarchy child item acceptfn) + (hierarchy-add-tree hierarchy child parentfn childrenfn))) + children))))) + +(defun hierarchy-add-trees (hierarchy items parentfn &optional childrenfn acceptfn) + "Call `hierarchy-add-tree' on HIERARCHY and each element of ITEMS. + +PARENTFN, CHILDRENFN and ACCEPTFN have the same meaning as in `hierarchy-add'." + (seq-map (lambda (item) + (hierarchy-add-tree hierarchy item parentfn childrenfn acceptfn)) + items)) + +(defun hierarchy-add-list (hierarchy list &optional wrap childrenfn) + "Add to HIERARCHY the sub-lists in LIST. + +If WRAP is non-nil, allow duplicate items in LIST by wraping each +item in a cons (id . item). The root's id is 1. + +CHILDRENFN is a function (defaults to `cdr') taking LIST as a +parameter which should return LIST's children (a list). Each +child is (recursively) passed as a parameter to CHILDRENFN to get +its own children. Because of this parameter, LIST can be +anything, not necessarily a list." + (let* ((childrenfn (or childrenfn #'cdr)) + (id 0) + (wrapfn (lambda (item) + (if wrap + (cons (setq id (1+ id)) item) + item))) + (unwrapfn (if wrap #'cdr #'identity))) + (hierarchy-add-tree + hierarchy (funcall wrapfn list) nil + (lambda (item) + (mapcar wrapfn (funcall childrenfn + (funcall unwrapfn item))))) + hierarchy)) + +(defun hierarchy-from-list (list &optional wrap childrenfn) + "Create and return a hierarchy built from LIST. + +This function passes LIST, WRAP and CHILDRENFN unchanged to +`hierarchy-add-list'." + (hierarchy-add-list (hierarchy-new) list wrap childrenfn)) + +(defun hierarchy-sort (hierarchy &optional sortfn) + "Modify HIERARCHY so that its roots and item's children are sorted. + +SORTFN is a function taking two items of the hierarchy as parameter and +returning non-nil if the first parameter is lower than the second. By +default, SORTFN is `string-lessp'." + (let ((sortfn (or sortfn #'string-lessp))) + (hierarchy--sort-roots hierarchy sortfn) + (mapc (lambda (parent) + (setf + (map-elt (hierarchy--children hierarchy) parent) + (sort (map-elt (hierarchy--children hierarchy) parent) sortfn))) + (map-keys (hierarchy--children hierarchy))))) + +(defun hierarchy-extract-tree (hierarchy item) + "Return a copy of HIERARCHY with ITEM's descendants and parents." + (if (not (hierarchy-has-item hierarchy item)) + nil + (let ((tree (hierarchy-new))) + (hierarchy-add-tree tree item + (lambda (each) (hierarchy-parent hierarchy each)) + (lambda (each) + (when (or (equal each item) + (hierarchy-descendant-p hierarchy each item)) + (hierarchy-children hierarchy each)))) + tree))) + +(defun hierarchy-copy (hierarchy) + "Return a copy of HIERARCHY. + +Items in HIERARCHY are shared, but structure is not." + (hierarchy-map-hierarchy (lambda (item _) (identity item)) hierarchy)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Querying +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun hierarchy-items (hierarchy) + "Return a list of all items of HIERARCHY." + (map-keys (hierarchy--seen-items hierarchy))) + +(defun hierarchy-has-item (hierarchy item) + "Return t if HIERARCHY includes ITEM." + (map-contains-key (hierarchy--seen-items hierarchy) item)) + +(defun hierarchy-empty-p (hierarchy) + "Return t if HIERARCHY is empty." + (= 0 (hierarchy-length hierarchy))) + +(defun hierarchy-length (hierarchy) + "Return the number of items in HIERARCHY." + (hash-table-count (hierarchy--seen-items hierarchy))) + +(defun hierarchy-has-root (hierarchy item) + "Return t if one of HIERARCHY's roots is ITEM. + +A root is an item with no parent." + (seq-contains-p (hierarchy-roots hierarchy) item)) + +(defun hierarchy-roots (hierarchy) + "Return all roots of HIERARCHY. + +A root is an item with no parent." + (let ((roots (hierarchy--roots hierarchy))) + (or roots + (hierarchy--compute-roots hierarchy)))) + +(defun hierarchy-leafs (hierarchy &optional node) + "Return all leafs of HIERARCHY. + +A leaf is an item with no child. + +If NODE is an item of HIERARCHY, only return leafs under NODE." + (let ((leafs (cl-set-difference + (map-keys (hierarchy--seen-items hierarchy)) + (map-keys (hierarchy--children hierarchy))))) + (if (hierarchy-has-item hierarchy node) + (seq-filter (lambda (item) + (hierarchy-descendant-p hierarchy item node)) + leafs) + leafs))) + +(defun hierarchy-parent (hierarchy item) + "In HIERARCHY, return parent of ITEM." + (map-elt (hierarchy--parents hierarchy) item)) + +(defun hierarchy-children (hierarchy parent) + "In HIERARCHY, return children of PARENT." + (map-elt (hierarchy--children hierarchy) parent (list))) + +(defun hierarchy-child-p (hierarchy item1 item2) + "In HIERARCHY, return non-nil if and only if ITEM1 is a child of ITEM2." + (equal (hierarchy-parent hierarchy item1) item2)) + +(defun hierarchy-descendant-p (hierarchy item1 item2) + "In HIERARCHY, return non-nil if and only if ITEM1 is a descendant of ITEM2. + +ITEM1 is a descendant of ITEM2 if and only if both are items of HIERARCHY +and either: + +- ITEM1 is child of ITEM2, or +- ITEM1's parent is a descendant of ITEM2." + (and + (hierarchy-has-item hierarchy item1) + (hierarchy-has-item hierarchy item2) + (or + (hierarchy-child-p hierarchy item1 item2) + (hierarchy-descendant-p + hierarchy (hierarchy-parent hierarchy item1) item2)))) + +(defun hierarchy-equal (hierarchy1 hierarchy2) + "Return t if HIERARCHY1 and HIERARCHY2 are equal. + +Two equal hierarchies share the same items and the same +relationships among them." + (and (hierarchy-p hierarchy1) + (hierarchy-p hierarchy2) + (= (hierarchy-length hierarchy1) (hierarchy-length hierarchy2)) + ;; parents are the same + (seq-every-p (lambda (child) + (equal (hierarchy-parent hierarchy1 child) + (hierarchy-parent hierarchy2 child))) + (map-keys (hierarchy--parents hierarchy1))) + ;; children are the same + (seq-every-p (lambda (parent) + (hierarchy--set-equal + (hierarchy-children hierarchy1 parent) + (hierarchy-children hierarchy2 parent) + :test #'equal)) + (map-keys (hierarchy--children hierarchy1))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Navigation +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun hierarchy-map-item (func item hierarchy &optional indent) + "Return the result of applying FUNC to ITEM and its descendants in HIERARCHY. + +This function navigates the tree top-down: FUNCTION is first called on item +and then on each of its children. Results are concatenated in a list. + +INDENT is a number (default 0) representing the indentation of ITEM in +HIERARCHY. FUNC should take 2 argument: the item and its indentation +level." + (let ((indent (or indent 0))) + (cons + (funcall func item indent) + (seq-mapcat (lambda (child) (hierarchy-map-item func child + hierarchy (1+ indent))) + (hierarchy-children hierarchy item))))) + +(defun hierarchy-map (func hierarchy &optional indent) + "Return the result of applying FUNC to each element of HIERARCHY. + +This function navigates the tree top-down: FUNCTION is first called on each +root. To do so, it calls `hierarchy-map-item' on each root +sequentially. Results are concatenated in a list. + +FUNC should take 2 arguments: the item and its indentation level. + +INDENT is a number (default 0) representing the indentation of HIERARCHY's +roots." + (let ((indent (or indent 0))) + (seq-mapcat (lambda (root) (hierarchy-map-item func root hierarchy indent)) + (hierarchy-roots hierarchy)))) + +(defun hierarchy-map-tree (function hierarchy &optional item indent) + "Apply FUNCTION on each item of HIERARCHY under ITEM. + +This function navigates the tree bottom-up: FUNCTION is first called on +leafs and the result is passed as parameter when calling FUNCTION on +parents. + +FUNCTION should take 3 parameters: the current item, its indentation +level (a number), and a list representing the result of applying +`hierarchy-map-tree' to each child of the item. + +INDENT is 0 by default and is passed as second parameter to FUNCTION. +INDENT is incremented by 1 at each level of the tree. + +This function returns the result of applying FUNCTION to ITEM (the first +root if nil)." + (let ((item (or item (car (hierarchy-roots hierarchy)))) + (indent (or indent 0))) + (funcall function item indent + (mapcar (lambda (child) + (hierarchy-map-tree function hierarchy + child (1+ indent))) + (hierarchy-children hierarchy item))))) + +(defun hierarchy-map-hierarchy (function hierarchy) + "Apply FUNCTION to each item of HIERARCHY in a new hierarchy. + +FUNCTION should take 2 parameters, the current item and its +indentation level (a number), and should return an item to be +added to the new hierarchy." + (let* ((items (make-hash-table :test #'equal)) + (transform (lambda (item) (map-elt items item)))) + ;; Make 'items', a table mapping original items to their + ;; transformation + (hierarchy-map (lambda (item indent) + (map-put! items item (funcall function item indent))) + hierarchy) + (hierarchy--make + :roots (mapcar transform (hierarchy-roots hierarchy)) + :parents (let ((result (make-hash-table :test #'equal))) + (map-apply (lambda (child parent) + (map-put! result + (funcall transform child) + (funcall transform parent))) + (hierarchy--parents hierarchy)) + result) + :children (let ((result (make-hash-table :test #'equal))) + (map-apply (lambda (parent children) + (map-put! result + (funcall transform parent) + (seq-map transform children))) + (hierarchy--children hierarchy)) + result) + :seen-items (let ((result (make-hash-table :test #'equal))) + (map-apply (lambda (item v) + (map-put! result + (funcall transform item) + v)) + (hierarchy--seen-items hierarchy)) + result)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Display +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun hierarchy-labelfn-indent (labelfn &optional indent-string) + "Return a function rendering LABELFN indented with INDENT-STRING. + +INDENT-STRING defaults to a 2-space string. Indentation is +multiplied by the depth of the displayed item." + (let ((indent-string (or indent-string " "))) + (lambda (item indent) + (dotimes (_ indent) (insert indent-string)) + (funcall labelfn item indent)))) + +(defun hierarchy-labelfn-button (labelfn actionfn) + "Return a function rendering LABELFN in a button. + +Clicking the button triggers ACTIONFN. ACTIONFN is a function +taking an item of HIERARCHY and an indentation value (a number) +as input. This function is called when an item is clicked. The +return value of ACTIONFN is ignored." + (lambda (item indent) + (let ((start (point))) + (funcall labelfn item indent) + (make-text-button start (point) + 'action (lambda (_) (funcall actionfn item indent)))))) + +(defun hierarchy-labelfn-button-if (labelfn buttonp actionfn) + "Return a function rendering LABELFN as a button if BUTTONP. + +Pass LABELFN and ACTIONFN to `hierarchy-labelfn-button' if +BUTTONP is non-nil. Otherwise, render LABELFN without making it +a button. + +BUTTONP is a function taking an item of HIERARCHY and an +indentation value (a number) as input." + (lambda (item indent) + (if (funcall buttonp item indent) + (funcall (hierarchy-labelfn-button labelfn actionfn) item indent) + (funcall labelfn item indent)))) + +(defun hierarchy-labelfn-to-string (labelfn item indent) + "Execute LABELFN on ITEM and INDENT. Return result as a string." + (with-temp-buffer + (funcall labelfn item indent) + (buffer-substring (point-min) (point-max)))) + +(defun hierarchy-print (hierarchy &optional to-string) + "Insert HIERARCHY in current buffer as plain text. + +Use TO-STRING to convert each element to a string. TO-STRING is +a function taking an item of HIERARCHY as input and returning a +string. If nil, TO-STRING defaults to a call to `format' with \"%s\"." + (let ((to-string (or to-string (lambda (item) (format "%s" item))))) + (hierarchy-map + (hierarchy-labelfn-indent (lambda (item _) + (insert (funcall to-string item) "\n"))) + hierarchy))) + +(defun hierarchy-to-string (hierarchy &optional to-string) + "Return a string representing HIERARCHY. + +TO-STRING is passed unchanged to `hierarchy-print'." + (with-temp-buffer + (hierarchy-print hierarchy to-string) + (buffer-substring (point-min) (point-max)))) + +(defun hierarchy-tabulated-imenu-action (_item-name position) + "Move to ITEM-NAME at POSITION in current buffer." + (goto-char position) + (back-to-indentation)) + +(define-derived-mode hierarchy-tabulated-mode tabulated-list-mode "Hierarchy tabulated" + "Major mode to display a hierarchy as a tabulated list." + (setq-local imenu-generic-expression + ;; debbugs: 26457 - Cannot pass a function to + ;; imenu-generic-expression. Add + ;; `hierarchy-tabulated-imenu-action' to the end of the + ;; list when bug is fixed + '(("Item" "^[[:space:]]+\\(?1:.+\\)$" 1)))) + +(defun hierarchy-tabulated-display (hierarchy labelfn &optional buffer) + "Display HIERARCHY as a tabulated list in `hierarchy-tabulated-mode'. + +LABELFN is a function taking an item of HIERARCHY and an indentation +level (a number) as input and inserting a string to be displayed in the +table. + +The tabulated list is displayed in BUFFER, or a newly created buffer if +nil. The buffer is returned." + (let ((buffer (or buffer (generate-new-buffer "hierarchy-tabulated")))) + (with-current-buffer buffer + (hierarchy-tabulated-mode) + (setq tabulated-list-format + (vector '("Item name" 0 nil))) + (setq tabulated-list-entries + (hierarchy-map (lambda (item indent) + (list item (vector (hierarchy-labelfn-to-string + labelfn item indent)))) + hierarchy)) + (tabulated-list-init-header) + (tabulated-list-print)) + buffer)) + +(declare-function widget-convert "wid-edit") +(defun hierarchy-convert-to-tree-widget (hierarchy labelfn) + "Return a tree-widget for HIERARCHY. + +LABELFN is a function taking an item of HIERARCHY and an indentation +value (a number) as parameter and inserting a string to be displayed as a +node label." + (require 'wid-edit) + (require 'tree-widget) + (hierarchy-map-tree (lambda (item indent children) + (widget-convert + 'tree-widget + :tag (hierarchy-labelfn-to-string labelfn item indent) + :args children)) + hierarchy)) + +(defun hierarchy-tree-display (hierarchy labelfn &optional buffer) + "Display HIERARCHY as a tree widget in a new buffer. + +HIERARCHY and LABELFN are passed unchanged to +`hierarchy-convert-to-tree-widget'. + +The tree widget is displayed in BUFFER, or a newly created buffer if +nil. The buffer is returned." + (let ((buffer (or buffer (generate-new-buffer "*hierarchy-tree*"))) + (tree-widget (hierarchy-convert-to-tree-widget hierarchy labelfn))) + (with-current-buffer buffer + (setq-local buffer-read-only t) + (let ((inhibit-read-only t)) + (erase-buffer) + (widget-create tree-widget) + (goto-char (point-min)) + (special-mode))) + buffer)) + +(provide 'hierarchy) + +;;; hierarchy.el ends here diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index 9cba232e16f..adb9cb2372c 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -208,6 +208,7 @@ a section." (when start (save-excursion (goto-char start) + (looking-at outline-regexp) (let ((level (lisp-outline-level)) (case-fold-search t) next-section-found) @@ -218,6 +219,7 @@ a section." nil t)) (> (save-excursion (beginning-of-line) + (looking-at outline-regexp) (lisp-outline-level)) level))) (min (if next-section-found @@ -485,7 +487,18 @@ absent, return nil." (lm-with-file file (let ((start (lm-commentary-start))) (when start - (buffer-substring-no-properties start (lm-commentary-end)))))) + (replace-regexp-in-string ; Get rid of... + "[[:blank:]]*$" "" ; trailing white-space + (replace-regexp-in-string + (format "%s\\|%s\\|%s" + ;; commentary header + (concat "^;;;[[:blank:]]*\\(" + lm-commentary-header + "\\):[[:blank:]\n]*") + "^;;[[:blank:]]*" ; double semicolon prefix + "[[:blank:]\n]*\\'") ; trailing new-lines + "" (buffer-substring-no-properties + start (lm-commentary-end)))))))) (defun lm-homepage (&optional file) "Return the homepage in file FILE, or current buffer if FILE is nil." diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index ec76d805e59..5dda3a8f8e9 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -38,7 +38,7 @@ (define-abbrev-table 'lisp-mode-abbrev-table () "Abbrev table for Lisp mode.") -(defvar lisp--mode-syntax-table +(defvar lisp-data-mode-syntax-table (let ((table (make-syntax-table)) (i 0)) (while (< i ?0) @@ -77,11 +77,13 @@ (modify-syntax-entry ?\\ "\\ " table) (modify-syntax-entry ?\( "() " table) (modify-syntax-entry ?\) ")( " table) + (modify-syntax-entry ?\[ "(]" table) + (modify-syntax-entry ?\] ")[" table) table) "Parent syntax table used in Lisp modes.") (defvar lisp-mode-syntax-table - (let ((table (make-syntax-table lisp--mode-syntax-table))) + (let ((table (make-syntax-table lisp-data-mode-syntax-table))) (modify-syntax-entry ?\[ "_ " table) (modify-syntax-entry ?\] "_ " table) (modify-syntax-entry ?# "' 14" table) @@ -178,13 +180,16 @@ (defun lisp--match-hidden-arg (limit) (let ((res nil)) + (forward-line 0) (while - (let ((ppss (parse-partial-sexp (line-beginning-position) + (let ((ppss (parse-partial-sexp (point) (line-end-position) -1))) (skip-syntax-forward " )") (if (or (>= (car ppss) 0) - (looking-at ";\\|$")) + (eolp) + (looking-at ";") + (nth 8 (syntax-ppss))) ;Within a string or comment. (progn (forward-line 1) (< (point) limit)) @@ -196,39 +201,53 @@ (defun lisp--el-non-funcall-position-p (pos) "Heuristically determine whether POS is an evaluated position." + (declare (obsolete lisp--el-funcall-position-p "28.1")) + (not (lisp--el-funcall-position-p pos))) + +(defun lisp--el-funcall-position-p (pos) + "Heuristically determine whether POS is an evaluated position." (save-match-data (save-excursion (ignore-errors (goto-char pos) - (or (eql (char-before) ?\') - (let* ((ppss (syntax-ppss)) - (paren-posns (nth 9 ppss)) - (parent - (when paren-posns - (goto-char (car (last paren-posns))) ;(up-list -1) - (cond - ((ignore-errors - (and (eql (char-after) ?\() - (when (cdr paren-posns) - (goto-char (car (last paren-posns 2))) - (looking-at "(\\_<let\\*?\\_>")))) - (goto-char (match-end 0)) - 'let) - ((looking-at - (rx "(" - (group-n 1 (+ (or (syntax w) (syntax _)))) - symbol-end)) - (prog1 (intern-soft (match-string-no-properties 1)) - (goto-char (match-end 1)))))))) - (or (eq parent 'declare) - (and (eq parent 'let) - (progn - (forward-sexp 1) - (< pos (point)))) - (and (eq parent 'condition-case) - (progn - (forward-sexp 2) - (< (point) pos)))))))))) + ;; '(lambda ..) is not a funcall position, but #'(lambda ...) is. + (if (eql (char-before) ?\') + (eql (char-before (1- (point))) ?#) + (let* ((ppss (syntax-ppss)) + (paren-posns (nth 9 ppss)) + (parent + (when paren-posns + (goto-char (car (last paren-posns))) ;(up-list -1) + (cond + ((ignore-errors + (and (eql (char-after) ?\() + (when (cdr paren-posns) + (goto-char (car (last paren-posns 2))) + (looking-at "(\\_<let\\*?\\_>")))) + (goto-char (match-end 0)) + 'let) + ((looking-at + (rx "(" + (group-n 1 (+ (or (syntax w) (syntax _)))) + symbol-end)) + (prog1 (intern-soft (match-string-no-properties 1)) + (goto-char (match-end 1)))))))) + (pcase parent + ('declare nil) + ('let + (forward-sexp 1) + (>= pos (point))) + ('condition-case + ;; If (cdr paren-posns), then we're in the BODY + ;; of HANDLERS. + (or (cdr paren-posns) + (progn + (forward-sexp 1) + ;; If we're in the second form, then we're in + ;; a funcall position. + (< (point) pos (progn (forward-sexp 1) + (point)))))) + (_ t)))))))) (defun lisp--el-match-keyword (limit) ;; FIXME: Move to elisp-mode.el. @@ -238,11 +257,9 @@ (concat "(\\(" lisp-mode-symbol-regexp "\\)\\_>")) limit t) (let ((sym (intern-soft (match-string 1)))) - (when (or (special-form-p sym) - (and (macrop sym) - (not (get sym 'no-font-lock-keyword)) - (not (lisp--el-non-funcall-position-p - (match-beginning 0))))) + (when (and (or (special-form-p sym) (macrop sym)) + (not (get sym 'no-font-lock-keyword)) + (lisp--el-funcall-position-p (match-beginning 0))) (throw 'found t)))))) (defmacro let-when-compile (bindings &rest body) @@ -449,14 +466,13 @@ This will generate compile-time constants from BINDINGS." ("\\(\\\\\\)\\([^\"\\]\\)" (1 (elisp--font-lock-backslash) prepend)) ;; Words inside ‘’ and `' tend to be symbol names. - (,(concat "[`‘]\\(\\(?:\\sw\\|\\s_\\|\\\\.\\)" - lisp-mode-symbol-regexp "\\)['’]") + (,(concat "[`‘]\\(" lisp-mode-symbol-regexp "\\)['’]") (1 font-lock-constant-face prepend)) ;; Constant values. (,(concat "\\_<:" lisp-mode-symbol-regexp "\\_>") (0 font-lock-builtin-face)) ;; ELisp and CLisp `&' keywords as types. - (,(concat "\\_<\\&" lisp-mode-symbol-regexp "\\_>") + (,(concat "\\_<&" lisp-mode-symbol-regexp "\\_>") . font-lock-type-face) ;; ELisp regexp grouping constructs (,(lambda (bound) @@ -476,7 +492,8 @@ This will generate compile-time constants from BINDINGS." (3 'font-lock-regexp-grouping-construct prepend)) (lisp--match-hidden-arg (0 '(face font-lock-warning-face - help-echo "Hidden behind deeper element; move to another line?"))) + help-echo "Easy to misread; consider moving the element to the next line") + prepend)) (lisp--match-confusable-symbol-character 0 '(face font-lock-warning-face help-echo "Confusable character")) @@ -499,19 +516,16 @@ This will generate compile-time constants from BINDINGS." (,(concat "(" cl-errs-re "\\_>") (1 font-lock-warning-face)) ;; Words inside ‘’ and `' tend to be symbol names. - (,(concat "[`‘]\\(\\(?:\\sw\\|\\s_\\|\\\\.\\)" - lisp-mode-symbol-regexp "\\)['’]") + (,(concat "[`‘]\\(" lisp-mode-symbol-regexp "\\)['’]") (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 "\\)") - (1 font-lock-comment-delimiter-face) - (2 font-lock-doc-face)) + (,(concat "#:" lisp-mode-symbol-regexp "") 0 font-lock-builtin-face) ;; Constant values. (,(concat "\\_<:" lisp-mode-symbol-regexp "\\_>") (0 font-lock-builtin-face)) ;; ELisp and CLisp `&' keywords as types. - (,(concat "\\_<\\&" lisp-mode-symbol-regexp "\\_>") + (,(concat "\\_<&" lisp-mode-symbol-regexp "\\_>") . font-lock-type-face) ;; This is too general -- rms. ;; A user complained that he has functions whose names start with `do' @@ -522,7 +536,8 @@ This will generate compile-time constants from BINDINGS." (1 font-lock-keyword-face)) (lisp--match-hidden-arg (0 '(face font-lock-warning-face - help-echo "Hidden behind deeper element; move to another line?"))) + help-echo "Easy to misread; consider moving the element to the next line") + prepend)) )) "Gaudy level highlighting for Lisp modes."))) @@ -611,6 +626,8 @@ Value for `adaptive-fill-function'." ;; a single docstring. Let's fix it here. (if (looking-at "\\s-+\"[^\n\"]+\"\\s-*$") "")) +;; Maybe this should be discouraged/obsoleted and users should be +;; encouraged to use `lisp-data-mode` instead. (defun lisp-mode-variables (&optional lisp-syntax keywords-case-insensitive elisp) "Common initialization routine for lisp modes. @@ -627,7 +644,7 @@ font-lock keywords will not be case sensitive." ;; and should make no difference for explicit fill ;; because lisp-fill-paragraph should do the job. ;; I believe that newcomment's auto-fill code properly deals with it -stef - ;;(set (make-local-variable 'adaptive-fill-mode) nil) + ;;(setq-local adaptive-fill-mode nil) (setq-local indent-line-function 'lisp-indent-line) (setq-local indent-region-function 'lisp-indent-region) (setq-local comment-indent-function #'lisp-comment-indent) @@ -658,6 +675,14 @@ font-lock keywords will not be case sensitive." (setq-local electric-pair-skip-whitespace 'chomp) (setq-local electric-pair-open-newline-between-pairs nil)) +;;;###autoload +(define-derived-mode lisp-data-mode prog-mode "Lisp-Data" + "Major mode for buffers holding data written in Lisp syntax." + :group 'lisp + (lisp-mode-variables nil t nil) + (setq-local electric-quote-string t) + (setq imenu-case-fold-search nil)) + (defun lisp-outline-level () "Lisp mode `outline-level' function." (let ((len (- (match-end 0) (match-beginning 0)))) @@ -737,7 +762,7 @@ font-lock keywords will not be case sensitive." "Keymap for ordinary Lisp mode. All commands in `lisp-mode-shared-map' are inherited by this map.") -(define-derived-mode lisp-mode prog-mode "Lisp" +(define-derived-mode lisp-mode lisp-data-mode "Lisp" "Major mode for editing Lisp code for Lisps other than GNU Emacs Lisp. Commands: Delete converts tabs to spaces as it moves back. @@ -746,10 +771,12 @@ Blank lines separate paragraphs. Semicolons start comments. \\{lisp-mode-map} Note that `run-lisp' may be used either to start an inferior Lisp job or to switch back to an existing one." - (lisp-mode-variables nil t) + (setq-local lisp-indent-function 'common-lisp-indent-function) (setq-local find-tag-default-function 'lisp-find-tag-default) (setq-local comment-start-skip - "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\)\\(;+\\|#|\\) *") + "\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\)\\(;+\\|#|\\) *") + (setq-local comment-end-skip "[ \t]*\\(\\s>\\||#\\)") + (setq-local font-lock-comment-end-skip "|#") (setq imenu-case-fold-search t)) (defun lisp-find-tag-default () @@ -775,8 +802,6 @@ or to switch back to an existing one." nil))) (comment-indent-default))) -(define-obsolete-function-alias 'lisp-mode-auto-fill 'do-auto-fill "23.1") - (defcustom lisp-indent-offset nil "If non-nil, indent second line of expressions that many more columns." :group 'lisp @@ -946,6 +971,7 @@ is the buffer position of the start of the containing expression." ;; setting this to a number inhibits calling hook (desired-indent nil) (retry t) + whitespace-after-open-paren calculate-lisp-indent-last-sexp containing-sexp) (cond ((or (markerp parse-start) (integerp parse-start)) (goto-char parse-start)) @@ -975,6 +1001,7 @@ is the buffer position of the start of the containing expression." nil ;; Innermost containing sexp found (goto-char (1+ containing-sexp)) + (setq whitespace-after-open-paren (looking-at (rx whitespace))) (if (not calculate-lisp-indent-last-sexp) ;; indent-point immediately follows open paren. ;; Don't call hook. @@ -989,9 +1016,11 @@ is the buffer position of the start of the containing expression." calculate-lisp-indent-last-sexp) ;; This is the first line to start within the containing sexp. ;; It's almost certainly a function call. - (if (= (point) calculate-lisp-indent-last-sexp) + (if (or (= (point) calculate-lisp-indent-last-sexp) + whitespace-after-open-paren) ;; Containing sexp has nothing before this line - ;; except the first element. Indent under that element. + ;; except the first element, or the first element is + ;; preceded by whitespace. Indent under that element. nil ;; Skip the first element, find start of second (the first ;; argument of the function call) and indent under. diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index 26428af4555..46ca94869c7 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -55,7 +55,7 @@ This affects `insert-parentheses' and `insert-pair'." "If non-nil, `forward-sexp' delegates to this function. Should take the same arguments and behave similarly to `forward-sexp'.") -(defun forward-sexp (&optional arg) +(defun forward-sexp (&optional arg interactive) "Move forward across one balanced expression (sexp). With ARG, do it that many times. Negative arg -N means move backward across N balanced expressions. This command assumes @@ -64,23 +64,32 @@ point is not in a string or comment. Calls If unable to move over a sexp, signal `scan-error' with three arguments: a message, the start of the obstacle (usually a parenthesis or list marker of some kind), and end of the -obstacle." - (interactive "^p") - (or arg (setq arg 1)) - (if forward-sexp-function - (funcall forward-sexp-function arg) - (goto-char (or (scan-sexps (point) arg) (buffer-end arg))) - (if (< arg 0) (backward-prefix-chars)))) - -(defun backward-sexp (&optional arg) +obstacle. If INTERACTIVE is non-nil, as it is interactively, +report errors as appropriate for this kind of usage." + (interactive "^p\nd") + (if interactive + (condition-case _ + (forward-sexp arg nil) + (scan-error (user-error (if (> arg 0) + "No next sexp" + "No previous sexp")))) + (or arg (setq arg 1)) + (if forward-sexp-function + (funcall forward-sexp-function arg) + (goto-char (or (scan-sexps (point) arg) (buffer-end arg))) + (if (< arg 0) (backward-prefix-chars))))) + +(defun backward-sexp (&optional arg interactive) "Move backward across one balanced expression (sexp). With ARG, do it that many times. Negative arg -N means move forward across N balanced expressions. This command assumes point is not in a string or comment. -Uses `forward-sexp' to do the work." - (interactive "^p") +Uses `forward-sexp' to do the work. +If INTERACTIVE is non-nil, as it is interactively, +report errors as appropriate for this kind of usage." + (interactive "^p\nd") (or arg (setq arg 1)) - (forward-sexp (- arg))) + (forward-sexp (- arg) interactive)) (defun mark-sexp (&optional arg allow-extend) "Set mark ARG sexps from point. @@ -99,50 +108,78 @@ This command assumes point is not in a string or comment." (set-mark (save-excursion (goto-char (mark)) - (forward-sexp arg) + (condition-case error + (forward-sexp arg) + (scan-error + (user-error (if (equal (cadr error) + "Containing expression ends prematurely") + "No more sexp to select" + (cadr error))))) (point)))) (t (push-mark (save-excursion - (forward-sexp (prefix-numeric-value arg)) + (condition-case error + (forward-sexp (prefix-numeric-value arg)) + (scan-error + (user-error (if (equal (cadr error) + "Containing expression ends prematurely") + "No sexp to select" + (cadr error))))) (point)) nil t)))) -(defun forward-list (&optional arg) +(defun forward-list (&optional arg interactive) "Move forward across one balanced group of parentheses. This command will also work on other parentheses-like expressions defined by the current language mode. With ARG, do it that many times. Negative arg -N means move backward across N groups of parentheses. -This command assumes point is not in a string or comment." - (interactive "^p") - (or arg (setq arg 1)) - (goto-char (or (scan-lists (point) arg 0) (buffer-end arg)))) - -(defun backward-list (&optional arg) +This command assumes point is not in a string or comment. +If INTERACTIVE is non-nil, as it is interactively, +report errors as appropriate for this kind of usage." + (interactive "^p\nd") + (if interactive + (condition-case _ + (forward-list arg nil) + (scan-error (user-error (if (> arg 0) + "No next group" + "No previous group")))) + (or arg (setq arg 1)) + (goto-char (or (scan-lists (point) arg 0) (buffer-end arg))))) + +(defun backward-list (&optional arg interactive) "Move backward across one balanced group of parentheses. This command will also work on other parentheses-like expressions defined by the current language mode. With ARG, do it that many times. Negative arg -N means move forward across N groups of parentheses. -This command assumes point is not in a string or comment." - (interactive "^p") +This command assumes point is not in a string or comment. +If INTERACTIVE is non-nil, as it is interactively, +report errors as appropriate for this kind of usage." + (interactive "^p\nd") (or arg (setq arg 1)) - (forward-list (- arg))) + (forward-list (- arg) interactive)) -(defun down-list (&optional arg) +(defun down-list (&optional arg interactive) "Move forward down one level of parentheses. This command will also work on other parentheses-like expressions defined by the current language mode. With ARG, do this that many times. A negative argument means move backward but still go down a level. -This command assumes point is not in a string or comment." - (interactive "^p") - (or arg (setq arg 1)) - (let ((inc (if (> arg 0) 1 -1))) - (while (/= arg 0) - (goto-char (or (scan-lists (point) inc -1) (buffer-end arg))) - (setq arg (- arg inc))))) +This command assumes point is not in a string or comment. +If INTERACTIVE is non-nil, as it is interactively, +report errors as appropriate for this kind of usage." + (interactive "^p\nd") + (if interactive + (condition-case _ + (down-list arg nil) + (scan-error (user-error "At bottom level"))) + (or arg (setq arg 1)) + (let ((inc (if (> arg 0) 1 -1))) + (while (/= arg 0) + (goto-char (or (scan-lists (point) inc -1) (buffer-end arg))) + (setq arg (- arg inc)))))) (defun backward-up-list (&optional arg escape-strings no-syntax-crossing) "Move backward out of one level of parentheses. @@ -229,26 +266,39 @@ point is unspecified." (or (< inc 0) (forward-comment 1)) (setf arg (+ arg inc))) - (signal (car err) (cdr err)))))) + (if no-syntax-crossing + ;; Assume called interactively; don't signal an error. + (user-error "At top level") + (signal (car err) (cdr err))))))) (setq arg (- arg inc))))) -(defun kill-sexp (&optional arg) +(defun kill-sexp (&optional arg interactive) "Kill the sexp (balanced expression) following point. With ARG, kill that many sexps after point. Negative arg -N means kill N sexps before point. -This command assumes point is not in a string or comment." - (interactive "p") - (let ((opoint (point))) - (forward-sexp (or arg 1)) - (kill-region opoint (point)))) - -(defun backward-kill-sexp (&optional arg) +This command assumes point is not in a string or comment. +If INTERACTIVE is non-nil, as it is interactively, +report errors as appropriate for this kind of usage." + (interactive "p\nd") + (if interactive + (condition-case _ + (kill-sexp arg nil) + (scan-error (user-error (if (> arg 0) + "No next sexp" + "No previous sexp")))) + (let ((opoint (point))) + (forward-sexp (or arg 1)) + (kill-region opoint (point))))) + +(defun backward-kill-sexp (&optional arg interactive) "Kill the sexp (balanced expression) preceding point. With ARG, kill that many sexps before point. Negative arg -N means kill N sexps after point. -This command assumes point is not in a string or comment." - (interactive "p") - (kill-sexp (- (or arg 1)))) +This command assumes point is not in a string or comment. +If INTERACTIVE is non-nil, as it is interactively, +report errors as appropriate for this kind of usage." + (interactive "p\nd") + (kill-sexp (- (or arg 1)) interactive)) ;; After Zmacs: (defun kill-backward-up-list (&optional arg) @@ -482,7 +532,8 @@ is called as a function to find the defun's end." (if (looking-at "\\s<\\|\n") (forward-line 1)))))) (funcall end-of-defun-function) - (funcall skip) + (when (<= arg 1) + (funcall skip)) (cond ((> arg 0) ;; Moving forward. @@ -733,13 +784,52 @@ This command assumes point is not in a string or comment." (interactive "P") (insert-pair arg ?\( ?\))) +(defcustom delete-pair-blink-delay blink-matching-delay + "Time in seconds to delay after showing a paired character to delete. +It's used by the command `delete-pair'. The value 0 disables blinking." + :type 'number + :group 'lisp + :version "28.1") + (defun delete-pair (&optional arg) - "Delete a pair of characters enclosing ARG sexps following point. -A negative ARG deletes a pair of characters around preceding ARG sexps." - (interactive "p") - (unless arg (setq arg 1)) - (save-excursion (forward-sexp arg) (delete-char (if (> arg 0) -1 1))) - (delete-char (if (> arg 0) 1 -1))) + "Delete a pair of characters enclosing ARG sexps that follow point. +A negative ARG deletes a pair around the preceding ARG sexps instead. +The option `delete-pair-blink-delay' can disable blinking." + (interactive "P") + (if arg + (setq arg (prefix-numeric-value arg)) + (setq arg 1)) + (if (< arg 0) + (save-excursion + (skip-chars-backward " \t") + (save-excursion + (let ((close-char (char-before))) + (forward-sexp arg) + (unless (member (list (char-after) close-char) + (mapcar (lambda (p) + (if (= (length p) 3) (cdr p) p)) + insert-pair-alist)) + (error "Not after matching pair")) + (when (and (numberp delete-pair-blink-delay) + (> delete-pair-blink-delay 0)) + (sit-for delete-pair-blink-delay)) + (delete-char 1))) + (delete-char -1)) + (save-excursion + (skip-chars-forward " \t") + (save-excursion + (let ((open-char (char-after))) + (forward-sexp arg) + (unless (member (list open-char (char-before)) + (mapcar (lambda (p) + (if (= (length p) 3) (cdr p) p)) + insert-pair-alist)) + (error "Not before matching pair")) + (when (and (numberp delete-pair-blink-delay) + (> delete-pair-blink-delay 0)) + (sit-for delete-pair-blink-delay)) + (delete-char -1))) + (delete-char 1)))) (defun raise-sexp (&optional arg) "Raise ARG sexps higher up the tree." diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 82a8cd2d777..e842222b7c3 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -127,7 +127,7 @@ and also to avoid outputting the warning during normal execution." (cond ((null msg) form) ((macroexp--compiling-p) - (if (gethash form macroexp--warned) + (if (and (consp form) (gethash form macroexp--warned)) ;; Already wrapped this exp with a warning: avoid inf-looping ;; where we keep adding the same warning onto `form' because ;; macroexpand-all gets right back to macroexpanding `form'. @@ -138,9 +138,10 @@ and also to avoid outputting the warning during normal execution." ,form))) (t (unless compile-only - (message "%s%s" (if (stringp load-file-name) - (concat (file-relative-name load-file-name) ": ") - "") + (message "%sWarning: %s" + (if (stringp load-file-name) + (concat (file-relative-name load-file-name) ": ") + "") msg)) form)))) @@ -180,8 +181,9 @@ and also to avoid outputting the warning during normal execution." (defun macroexp-macroexpand (form env) "Like `macroexpand' but checking obsolescence." - (let ((new-form - (macroexpand form env))) + (let* ((macroexpand-all-environment env) + (new-form + (macroexpand form env))) (if (and (not (eq form new-form)) ;It was a macro call. (car-safe form) (symbolp (car form)) @@ -239,9 +241,22 @@ Assumes the caller has bound `macroexpand-all-environment'." form)) (`(,(and fun `(lambda . ,_)) . ,args) ;; Embedded lambda in function position. - (macroexp--cons (macroexp--all-forms fun 2) - (macroexp--all-forms args) - form)) + ;; If the byte-optimizer is loaded, try to unfold this, + ;; i.e. rewrite it to (let (<args>) <body>). We'd do it in the optimizer + ;; anyway, but doing it here (i.e. earlier) can sometimes avoid the + ;; creation of a closure, thus resulting in much better code. + (let ((newform (if (not (fboundp 'byte-compile-unfold-lambda)) + 'macroexp--not-unfolded + ;; Don't unfold if byte-opt is not yet loaded. + (byte-compile-unfold-lambda form)))) + (if (or (eq newform 'macroexp--not-unfolded) + (eq newform form)) + ;; Unfolding failed for some reason, avoid infinite recursion. + (macroexp--cons (macroexp--all-forms fun 2) + (macroexp--all-forms args) + form) + (macroexp--expand-all newform)))) + ;; The following few cases are for normal function calls that ;; are known to funcall one of their arguments. The byte ;; compiler has traditionally handled these functions specially @@ -255,17 +270,21 @@ Assumes the caller has bound `macroexpand-all-environment'." (macroexp--warn-and-return (format "%s quoted with ' rather than with #'" (list 'lambda (nth 1 f) '...)) - (macroexp--expand-all `(,fun ,f . ,args)))) + (macroexp--expand-all `(,fun #',f . ,args)))) ;; Second arg is a function: (`(,(and fun (or 'sort)) ,arg1 ',(and f `(lambda . ,_)) . ,args) (macroexp--warn-and-return (format "%s quoted with ' rather than with #'" (list 'lambda (nth 1 f) '...)) - (macroexp--expand-all `(,fun ,arg1 ,f . ,args)))) - (`(funcall #',(and f (pred symbolp)) . ,args) - ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' - ;; has a compiler-macro. - (macroexp--expand-all `(,f . ,args))) + (macroexp--expand-all `(,fun ,arg1 #',f . ,args)))) + (`(funcall ,exp . ,args) + (let ((eexp (macroexp--expand-all exp)) + (eargs (macroexp--all-forms args))) + ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' + ;; has a compiler-macro, or to unfold it. + (pcase eexp + (`#',f (macroexp--expand-all `(,f . ,eargs))) + (_ `(funcall ,eexp . ,eargs))))) (`(,func . ,_) ;; Macro expand compiler macros. This cannot be delayed to ;; byte-optimize-form because the output of the compiler-macro can @@ -358,12 +377,12 @@ Never returns an empty list." (t `(cond (,test ,@(macroexp-unprogn then)) (,(nth 1 else) ,@(macroexp-unprogn (nth 2 else))) - (t ,@(nthcdr 3 else)))))) + ,@(let ((def (nthcdr 3 else))) (if def `((t ,@def)))))))) ((eq (car-safe else) 'cond) `(cond (,test ,@(macroexp-unprogn then)) ,@(cdr else))) ;; Invert the test if that lets us reduce the depth of the tree. ((memq (car-safe then) '(if cond)) (macroexp-if `(not ,test) else then)) - (t `(if ,test ,then ,@(macroexp-unprogn else))))) + (t `(if ,test ,then ,@(if else (macroexp-unprogn else)))))) (defmacro macroexp-let2 (test sym exp &rest body) "Evaluate BODY with SYM bound to an expression for EXP's value. @@ -480,6 +499,35 @@ itself or not." v (list 'quote v))) +(defun macroexp--fgrep (bindings sexp) + "Return those of the BINDINGS which might be used in SEXP. +It is used as a poor-man's \"free variables\" test. It differs from a true +test of free variables in the following ways: +- It does not distinguish variables from functions, so it can be used + both to detect whether a given variable is used by SEXP and to + detect whether a given function is used by SEXP. +- It does not actually know ELisp syntax, so it only looks for the presence + of symbols in SEXP and can't distinguish if those symbols are truly + references to the given variable (or function). That can make the result + include bindings which actually aren't used. +- For the same reason it may cause the result to fail to include bindings + which will be used if SEXP is not yet fully macro-expanded and the + use of the binding will only be revealed by macro expansion." + (let ((res '())) + (while (and (consp sexp) bindings) + (dolist (binding (macroexp--fgrep bindings (pop sexp))) + (push binding res) + (setq bindings (remove binding bindings)))) + (if (or (vectorp sexp) (byte-code-function-p sexp)) + ;; With backquote, code can appear within vectors as well. + ;; This wouldn't be needed if we `macroexpand-all' before + ;; calling macroexp--fgrep, OTOH. + (macroexp--fgrep bindings (mapcar #'identity sexp)) + (let ((tmp (assq sexp bindings))) + (if tmp + (cons tmp res) + res))))) + ;;; Load-time macro-expansion. ;; Because macro-expansion used to be more lazy, eager macro-expansion diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index 8fa36da6e17..46a1bd21a3d 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -4,7 +4,7 @@ ;; Author: Nicolas Petton <nicolas@petton.fr> ;; Keywords: convenience, map, hash-table, alist, array -;; Version: 2.0 +;; Version: 2.1 ;; Package-Requires: ((emacs "25")) ;; Package: map @@ -56,8 +56,10 @@ evaluated and searched for in the map. The match fails if for any KEY found in the map, the corresponding PAT doesn't match the value associated to the KEY. -Each element can also be a SYMBOL, which is an abbreviation of a (KEY -PAT) tuple of the form (\\='SYMBOL SYMBOL). +Each element can also be a SYMBOL, which is an abbreviation of +a (KEY PAT) tuple of the form (\\='SYMBOL SYMBOL). When SYMBOL +is a keyword, it is an abbreviation of the form (:SYMBOL SYMBOL), +useful for binding plist values. Keys in ARGS not found in the map are ignored, and the match doesn't fail." @@ -486,9 +488,12 @@ Example: (defun map--make-pcase-bindings (args) "Return a list of pcase bindings from ARGS to the elements of a map." (seq-map (lambda (elt) - (if (consp elt) - `(app (pcase--flip map-elt ,(car elt)) ,(cadr elt)) - `(app (pcase--flip map-elt ',elt) ,elt))) + (cond ((consp elt) + `(app (pcase--flip map-elt ,(car elt)) ,(cadr elt))) + ((keywordp elt) + (let ((var (intern (substring (symbol-name elt) 1)))) + `(app (pcase--flip map-elt ,elt) ,var))) + (t `(app (pcase--flip map-elt ',elt) ,elt)))) args)) (defun map--make-pcase-patterns (args) diff --git a/lisp/emacs-lisp/memory-report.el b/lisp/emacs-lisp/memory-report.el new file mode 100644 index 00000000000..3d6ca957e63 --- /dev/null +++ b/lisp/emacs-lisp/memory-report.el @@ -0,0 +1,317 @@ +;;; memory-report.el --- Short function summaries -*- lexical-binding: t -*- + +;; Copyright (C) 2020-2021 Free Software Foundation, Inc. + +;; Keywords: lisp, help + +;; 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: + +;; Todo (possibly): Font cache, regexp cache, bidi cache, various +;; buffer caches (newline cache, free_region_cache, etc), composition +;; cache, face cache. + +;;; Code: + +(require 'seq) +(require 'subr-x) +(eval-when-compile (require 'cl-lib)) + +(defvar memory-report--type-size (make-hash-table)) + +;;;###autoload +(defun memory-report () + "Generate a report of how Emacs is using memory. + +This report is approximate, and will commonly over-count memory +usage by variables, because shared data structures will usually +by counted more than once." + (interactive) + (pop-to-buffer "*Memory Report*") + (special-mode) + (button-mode 1) + (setq truncate-lines t) + (message "Gathering data...") + (let ((reports (append (memory-report--garbage-collect) + (memory-report--image-cache) + (memory-report--symbol-plist) + (memory-report--buffers) + (memory-report--largest-variables))) + (inhibit-read-only t) + summaries details) + (message "Gathering data...done") + (erase-buffer) + (insert (propertize "Estimated Emacs Memory Usage\n\n" 'face 'bold)) + (dolist (report reports) + (if (listp report) + (push report summaries) + (push report details))) + (dolist (summary (seq-sort (lambda (e1 e2) + (> (cdr e1) (cdr e2))) + summaries)) + (insert (format "%s %s\n" + (memory-report--format (cdr summary)) + (car summary)))) + (insert "\n") + (dolist (detail (nreverse details)) + (insert detail "\n"))) + (goto-char (point-min))) + +(defun memory-report-object-size (object) + "Return the size of OBJECT in bytes." + (unless memory-report--type-size + (memory-report--garbage-collect)) + (memory-report--object-size (make-hash-table :test #'eq) object)) + +(defun memory-report--size (type) + (or (gethash type memory-report--type-size) + (gethash 'object memory-report--type-size))) + +(defun memory-report--set-size (elems) + (setf (gethash 'string memory-report--type-size) + (cadr (assq 'strings elems))) + (setf (gethash 'cons memory-report--type-size) + (cadr (assq 'conses elems))) + (setf (gethash 'symbol memory-report--type-size) + (cadr (assq 'symbols elems))) + (setf (gethash 'object memory-report--type-size) + (cadr (assq 'vectors elems))) + (setf (gethash 'float memory-report--type-size) + (cadr (assq 'floats elems))) + (setf (gethash 'buffer memory-report--type-size) + (cadr (assq 'buffers elems)))) + +(defun memory-report--garbage-collect () + (let ((elems (garbage-collect))) + (memory-report--set-size elems) + (let ((data (list + (list 'strings + (+ (memory-report--gc-elem elems 'strings) + (memory-report--gc-elem elems 'string-bytes))) + (list 'vectors + (+ (memory-report--gc-elem elems 'vectors) + (memory-report--gc-elem elems 'vector-slots))) + (list 'floats (memory-report--gc-elem elems 'floats)) + (list 'conses (memory-report--gc-elem elems 'conses)) + (list 'symbols (memory-report--gc-elem elems 'symbols)) + (list 'intervals (memory-report--gc-elem elems 'intervals)) + (list 'buffer-objects + (memory-report--gc-elem elems 'buffers))))) + (list (cons "Overall Object Memory Usage" + (seq-reduce #'+ (mapcar (lambda (elem) + (* (nth 1 elem) (nth 2 elem))) + elems) + 0)) + (cons "Reserved (But Unused) Object Memory" + (seq-reduce #'+ (mapcar (lambda (elem) + (if (nth 3 elem) + (* (nth 1 elem) (nth 3 elem)) + 0)) + elems) + 0)) + (with-temp-buffer + (insert (propertize "Object Storage\n\n" 'face 'bold)) + (dolist (object (seq-sort (lambda (e1 e2) + (> (cadr e1) (cadr e2))) + data)) + (insert (format "%s %s\n" + (memory-report--format (cadr object)) + (capitalize (symbol-name (car object)))))) + (buffer-string)))))) + +(defun memory-report--largest-variables () + (let ((variables nil)) + (mapatoms + (lambda (symbol) + (when (boundp symbol) + (let ((size (memory-report--object-size + (make-hash-table :test #'eq) + (symbol-value symbol)))) + (when (> size 1000) + (push (cons symbol size) variables))))) + obarray) + (list + (cons (propertize "Memory Used By Global Variables" + 'help-echo "Upper bound; mutually overlapping data from different variables are counted several times") + (seq-reduce #'+ (mapcar #'cdr variables) 0)) + (with-temp-buffer + (insert (propertize "Largest Variables\n\n" 'face 'bold)) + (cl-loop for i from 1 upto 20 + for (symbol . size) in (seq-sort (lambda (e1 e2) + (> (cdr e1) (cdr e2))) + variables) + do (insert (memory-report--format size) + " " + (symbol-name symbol) + "\n")) + (buffer-string))))) + +(defun memory-report--symbol-plist () + (let ((counted (make-hash-table :test #'eq)) + (total 0)) + (mapatoms + (lambda (symbol) + (cl-incf total (memory-report--object-size + counted (symbol-plist symbol)))) + obarray) + (list + (cons "Memory Used By Symbol Plists" total)))) + +(defun memory-report--object-size (counted value) + (if (gethash value counted) + 0 + (setf (gethash value counted) t) + (memory-report--object-size-1 counted value))) + +(cl-defgeneric memory-report--object-size-1 (_counted _value) + 0) + +(cl-defmethod memory-report--object-size-1 (_ (value symbol)) + ;; Don't count global symbols -- makes sizes of lists of symbols too + ;; heavey. + (if (intern-soft value obarray) + 0 + (memory-report--size 'symbol))) + +(cl-defmethod memory-report--object-size-1 (_ (_value buffer)) + (memory-report--size 'buffer)) + +(cl-defmethod memory-report--object-size-1 (counted (value string)) + (+ (memory-report--size 'string) + (string-bytes value) + (memory-report--interval-size counted (object-intervals value)))) + +(defun memory-report--interval-size (counted intervals) + ;; We get a list back of intervals, but only count the "inner list" + ;; (i.e., the actual text properties), and add the size of the + ;; intervals themselves. + (+ (* (memory-report--size 'interval) (length intervals)) + (seq-reduce #'+ (mapcar + (lambda (interval) + (memory-report--object-size counted (nth 2 interval))) + intervals) + 0))) + +(cl-defmethod memory-report--object-size-1 (counted (value list)) + (let ((total 0) + (size (memory-report--size 'cons))) + (while value + (cl-incf total size) + (setf (gethash value counted) t) + (when (car value) + (cl-incf total (memory-report--object-size counted (car value)))) + (if (cdr value) + (if (consp (cdr value)) + (if (gethash (cdr value) counted) + (setq value nil) + (setq value (cdr value))) + (cl-incf total (memory-report--object-size counted (cdr value))) + (setq value nil)) + (setq value nil))) + total)) + +(cl-defmethod memory-report--object-size-1 (counted (value vector)) + (let ((total (+ (memory-report--size 'vector) + (* (memory-report--size 'object) (length value))))) + (cl-loop for elem across value + do (setf (gethash elem counted) t) + (cl-incf total (memory-report--object-size counted elem))) + total)) + +(cl-defmethod memory-report--object-size-1 (counted (value hash-table)) + (let ((total (+ (memory-report--size 'vector) + (* (memory-report--size 'object) (hash-table-size value))))) + (maphash + (lambda (key elem) + (setf (gethash key counted) t) + (setf (gethash elem counted) t) + (cl-incf total (memory-report--object-size counted key)) + (cl-incf total (memory-report--object-size counted elem))) + value) + total)) + +(defun memory-report--format (bytes) + (setq bytes (/ bytes 1024.0)) + (let ((units '("KiB" "MiB" "GiB" "TiB"))) + (while (>= bytes 1024) + (setq bytes (/ bytes 1024.0)) + (setq units (cdr units))) + (format "%6.1f %s" bytes (car units)))) + +(defun memory-report--gc-elem (elems type) + (* (nth 1 (assq type elems)) + (nth 2 (assq type elems)))) + +(defun memory-report--buffers () + (let ((buffers (mapcar (lambda (buffer) + (cons buffer (memory-report--buffer buffer))) + (buffer-list)))) + (list (cons "Total Buffer Memory Usage" + (seq-reduce #'+ (mapcar #'cdr buffers) 0)) + (with-temp-buffer + (insert (propertize "Largest Buffers\n\n" 'face 'bold)) + (cl-loop for i from 1 upto 20 + for (buffer . size) in (seq-sort (lambda (e1 e2) + (> (cdr e1) (cdr e2))) + buffers) + do (insert (memory-report--format size) + " " + (button-buttonize + (buffer-name buffer) + #'memory-report--buffer-details buffer) + "\n")) + (buffer-string))))) + +(defun memory-report--buffer-details (buffer) + (with-current-buffer buffer + (apply + #'message + "Buffer text: %s; variables: %s; text properties: %s; overlays: %s" + (mapcar #'string-trim (mapcar #'memory-report--format + (memory-report--buffer-data buffer)))))) + +(defun memory-report--buffer (buffer) + (seq-reduce #'+ (memory-report--buffer-data buffer) 0)) + +(defun memory-report--buffer-data (buffer) + (with-current-buffer buffer + (list (save-restriction + (widen) + (+ (position-bytes (point-max)) + (- (position-bytes (point-min))) + (gap-size))) + (seq-reduce #'+ (mapcar (lambda (elem) + (if (cdr elem) + (memory-report--object-size + (make-hash-table :test #'eq) + (cdr elem)) + 0)) + (buffer-local-variables buffer)) + 0) + (memory-report--object-size (make-hash-table :test #'eq) + (object-intervals buffer)) + (memory-report--object-size (make-hash-table :test #'eq) + (overlay-lists))))) + +(defun memory-report--image-cache () + (list (cons "Total Image Cache Size" (if (fboundp 'image-cache-size) + (image-cache-size) + 0)))) + +(provide 'memory-report) + +;;; memory-report.el ends here diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index ca60a041cf2..afdd372d273 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -5,18 +5,20 @@ ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: extensions, lisp, tools -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el index 8a0853ce445..2e327d16de4 100644 --- a/lisp/emacs-lisp/package-x.el +++ b/lisp/emacs-lisp/package-x.el @@ -1,4 +1,4 @@ -;;; package-x.el --- Package extras +;;; package-x.el --- Package extras -*- lexical-binding: t; -*- ;; Copyright (C) 2007-2021 Free Software Foundation, Inc. @@ -182,8 +182,7 @@ if it exists." ;; Check if `package-archive-upload-base' is valid. (when (or (not (stringp package-archive-upload-base)) (equal package-archive-upload-base - (car-safe - (get 'package-archive-upload-base 'standard-value)))) + (custom--standard-value 'package-archive-upload-base))) (setq package-archive-upload-base (read-directory-name "Base directory for package archive: "))) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index ecb2573cab7..90b7b88d58a 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -173,12 +173,12 @@ with \"-q\"). Even if the value is nil, you can type \\[package-initialize] to make installed packages available at any time, or you can -call (package-initialize) in your init-file." +call (package-activate-all) in your init-file." :type 'boolean :version "24.1") (defcustom package-load-list '(all) - "List of packages for `package-initialize' to make available. + "List of packages for `package-activate-all' to make available. Each element in this list should be a list (NAME VERSION), or the symbol `all'. The symbol `all' says to make available the latest installed versions of all packages not specified by other @@ -203,6 +203,9 @@ If VERSION is nil, the package is not made available (it is \"disabled\")." (defcustom package-archives `(("gnu" . ,(format "http%s://elpa.gnu.org/packages/" + (if (gnutls-available-p) "s" ""))) + ("nongnu" . + ,(format "http%s://elpa.nongnu.org/nongnu/" (if (gnutls-available-p) "s" "")))) "An alist of archives from which to fetch. The default value points to the GNU Emacs package repository. @@ -289,15 +292,18 @@ the package will be unavailable." :risky t :version "24.4") +;;;###autoload (defcustom package-user-dir (locate-user-emacs-file "elpa") "Directory containing the user's Emacs Lisp packages. The directory name should be absolute. Apart from this directory, Emacs also looks for system-wide packages in `package-directory-list'." :type 'directory + :initialize #'custom-initialize-delay :risky t :version "24.1") +;;;###autoload (defcustom package-directory-list ;; Defaults are subdirs named "elpa" in the site-lisp dirs. (let (result) @@ -312,6 +318,7 @@ Each directory name should be absolute. 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 :risky t :version "24.1") @@ -397,6 +404,26 @@ synchronously." :type 'boolean :version "25.1") +(defcustom package-name-column-width 30 + "Column width for the Package name in the package menu." + :type 'number + :version "28.1") + +(defcustom package-version-column-width 14 + "Column width for the Package version in the package menu." + :type 'number + :version "28.1") + +(defcustom package-status-column-width 12 + "Column width for the Package status in the package menu." + :type 'number + :version "28.1") + +(defcustom package-archive-column-width 8 + "Column width for the Package status in the package menu." + :type 'number + :version "28.1") + ;;; `package-desc' object definition ;; This is the struct used internally to represent packages. @@ -421,9 +448,9 @@ synchronously." &aux (name (intern name-string)) (version (version-to-list version-string)) - (reqs (mapcar #'(lambda (elt) - (list (car elt) - (version-to-list (cadr elt)))) + (reqs (mapcar (lambda (elt) + (list (car elt) + (version-to-list (cadr elt)))) (if (eq 'quote (car requirements)) (nth 1 requirements) requirements))) @@ -564,9 +591,8 @@ package." ;;; Installed packages ;; The following variables store information about packages present in ;; the system. The most important of these is `package-alist'. The -;; command `package-initialize' is also closely related to this -;; section, but it is left for a later section because it also affects -;; other stuff. +;; command `package-activate-all' is also closely related to this +;; section. (defvar package--builtins nil "Alist of built-in packages. @@ -585,7 +611,7 @@ name (a symbol) and DESCS is a non-empty list of `package-desc' structures, sorted by decreasing versions. This variable is set automatically by `package-load-descriptor', -called via `package-initialize'. To change which packages are +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) @@ -670,9 +696,9 @@ updates `package-alist'." (progn (package-load-all-descriptors) package-alist))) -(defun define-package (_name-string _version-string - &optional _docstring _requirements - &rest _extra-properties) +(defun define-package ( _name-string _version-string + &optional _docstring _requirements + &rest _extra-properties) "Define a new package. NAME-STRING is the name of the package, as a string. VERSION-STRING is the version of the package, as a string. @@ -798,49 +824,68 @@ correspond to previously loaded files (those returned by ;; FIXME: not the friendliest, but simple. (require 'info) (info-initialize) - (push pkg-dir Info-directory-list)) + (add-to-list 'Info-directory-list pkg-dir)) (push name package-activated-list) ;; Don't return nil. t))) (declare-function find-library-name "find-func" (library)) +(defun package--files-load-history () + (delq nil + (mapcar (lambda (x) + (let ((f (car x))) + (and (stringp f) + (file-name-sans-extension (file-truename f))))) + load-history))) + +(defun package--list-of-conflicts (dir history) + (delq + nil + (mapcar + (lambda (x) (let* ((file (file-relative-name x dir)) + ;; Previously loaded file, if any. + (previous + (ignore-errors + (file-name-sans-extension + (file-truename (find-library-name file))))) + (pos (when previous (member previous history)))) + ;; Return (RELATIVE-FILENAME . HISTORY-POSITION) + (when pos + (cons (file-name-sans-extension file) (length pos))))) + (directory-files-recursively dir "\\`[^\\.].*\\.el\\'")))) + (defun package--list-loaded-files (dir) "Recursively list all files in DIR which correspond to loaded features. Returns the `file-name-sans-extension' of each file, relative to DIR, sorted by most recently loaded last." - (let* ((history (delq nil - (mapcar (lambda (x) - (let ((f (car x))) - (and (stringp f) - (file-name-sans-extension f)))) - load-history))) + (let* ((history (package--files-load-history)) (dir (file-truename dir)) ;; List all files that have already been loaded. - (list-of-conflicts - (delq - nil - (mapcar - (lambda (x) (let* ((file (file-relative-name x dir)) - ;; Previously loaded file, if any. - (previous - (ignore-errors - (file-name-sans-extension - (file-truename (find-library-name file))))) - (pos (when previous (member previous history)))) - ;; Return (RELATIVE-FILENAME . HISTORY-POSITION) - (when pos - (cons (file-name-sans-extension file) (length pos))))) - (directory-files-recursively dir "\\`[^\\.].*\\.el\\'"))))) + (list-of-conflicts (package--list-of-conflicts dir history))) ;; Turn the list of (FILENAME . POS) back into a list of features. Files in ;; subdirectories are returned relative to DIR (so not actually features). (let ((default-directory (file-name-as-directory dir))) (mapcar (lambda (x) (file-truename (car x))) - (sort list-of-conflicts - ;; Sort the files by ascending HISTORY-POSITION. - (lambda (x y) (< (cdr x) (cdr y)))))))) + (sort list-of-conflicts + ;; Sort the files by ascending HISTORY-POSITION. + (lambda (x y) (< (cdr x) (cdr y)))))))) ;;;; `package-activate' + +(defun package--get-activatable-pkg (pkg-name) + ;; Is "activatable" a word? + (let ((pkg-descs (cdr (assq pkg-name package-alist)))) + ;; Check if PACKAGE is available in `package-alist'. + (while + (when pkg-descs + (let ((available-version (package-desc-version (car pkg-descs)))) + (or (package-disabled-p pkg-name available-version) + ;; Prefer a builtin package. + (package-built-in-p pkg-name available-version)))) + (setq pkg-descs (cdr pkg-descs))) + (car pkg-descs))) + ;; This function activates a newer version of a package if an older ;; one was already activated. It also loads a features of this ;; package which were already loaded. @@ -848,24 +893,16 @@ DIR, sorted by most recently loaded last." "Activate the package named PACKAGE. If FORCE is true, (re-)activate it if it's already activated. Newer versions are always activated, regardless of FORCE." - (let ((pkg-descs (cdr (assq package package-alist)))) - ;; Check if PACKAGE is available in `package-alist'. - (while - (when pkg-descs - (let ((available-version (package-desc-version (car pkg-descs)))) - (or (package-disabled-p package available-version) - ;; Prefer a builtin package. - (package-built-in-p package available-version)))) - (setq pkg-descs (cdr pkg-descs))) + (let ((pkg-desc (package--get-activatable-pkg package))) (cond ;; If no such package is found, maybe it's built-in. - ((null pkg-descs) + ((null pkg-desc) (package-built-in-p package)) ;; If the package is already activated, just return t. ((and (memq package package-activated-list) (not force)) t) ;; Otherwise, proceed with activation. - (t (package-activate-1 (car pkg-descs) nil 'deps))))) + (t (package-activate-1 pkg-desc nil 'deps))))) ;;; Installation -- Local operations @@ -926,7 +963,6 @@ untar into a directory named DIR; otherwise, signal an error." (if (> (length file-list) 1) 'tar 'single)))) ('tar (make-directory package-user-dir t) - ;; FIXME: should we delete PKG-DIR if it exists? (let* ((default-directory (file-name-as-directory package-user-dir))) (package-untar-buffer dirname))) ('single @@ -995,7 +1031,6 @@ untar into a directory named DIR; otherwise, signal an error." (write-region (autoload-rubric file "package" nil) nil file nil 'silent)) file) -(defvar generated-autoload-file) (defvar autoload-timestamps) (defvar version-control) @@ -1003,14 +1038,14 @@ untar into a directory named DIR; otherwise, signal an error." "Generate autoloads in PKG-DIR for package named NAME." (let* ((auto-name (format "%s-autoloads.el" name)) ;;(ignore-name (concat name "-pkg.el")) - (generated-autoload-file (expand-file-name auto-name pkg-dir)) + (output-file (expand-file-name auto-name pkg-dir)) ;; We don't need 'em, and this makes the output reproducible. (autoload-timestamps nil) (backup-inhibited t) (version-control 'never)) - (package-autoload-ensure-default-file generated-autoload-file) - (update-directory-autoloads pkg-dir) - (let ((buf (find-buffer-visiting generated-autoload-file))) + (package-autoload-ensure-default-file output-file) + (make-directory-autoloads pkg-dir output-file) + (let ((buf (find-buffer-visiting output-file))) (when buf (kill-buffer buf))) auto-name)) @@ -1097,14 +1132,15 @@ boundaries." ;; Use some headers we've invented to drive the process. (let* (;; Prefer Package-Version; if defined, the package author ;; probably wants us to use it. Otherwise try Version. - (pkg-version - (or (package-strip-rcs-id (lm-header "package-version")) - (package-strip-rcs-id (lm-header "version")))) + (version-info + (or (lm-header "package-version") (lm-header "version"))) + (pkg-version (package-strip-rcs-id version-info)) (keywords (lm-keywords-list)) (homepage (lm-homepage))) (unless pkg-version - (error - "Package lacks a \"Version\" or \"Package-Version\" header")) + (if version-info + (error "Unrecognized package version: %s" version-info) + (error "Package lacks a \"Version\" or \"Package-Version\" header"))) (package-desc-from-define file-name pkg-version desc (and-let* ((require-lines (lm-header-multiline "package-requires"))) @@ -1201,8 +1237,8 @@ The return result is a `package-desc'." cipher-algorithm digest-algorithm compress-algorithm)) -(declare-function epg-verify-string "epg" (context signature - &optional signed-text)) +(declare-function epg-verify-string "epg" ( context signature + &optional signed-text)) (declare-function epg-context-result-for "epg" (context name)) (declare-function epg-signature-status "epg" (signature) t) (declare-function epg-signature-to-string "epg" (signature)) @@ -1589,25 +1625,34 @@ that code in the early init-file." ;; `package--initialized' is t. (package--build-compatibility-table)) -(defvar package-quickstart-file) - ;;;###autoload +(progn ;; Make the function usable without loading `package.el'. (defun package-activate-all () "Activate all installed packages. The variable `package-load-list' controls which packages to load." (setq package--activated t) - (if (file-readable-p package-quickstart-file) - ;; Skip load-source-file-function which would slow us down by a factor - ;; 2 (this assumes we were careful to save this file so it doesn't need - ;; any decoding). - (let ((load-source-file-function nil)) - (load package-quickstart-file nil 'nomessage)) - (dolist (elt (package--alist)) - (condition-case err - (package-activate (car elt)) - ;; Don't let failure of activation of a package arbitrarily stop - ;; activation of further packages. - (error (message "%s" (error-message-string err))))))) + (let* ((elc (concat package-quickstart-file "c")) + (qs (if (file-readable-p elc) elc + (if (file-readable-p package-quickstart-file) + package-quickstart-file)))) + (if qs + ;; Skip load-source-file-function which would slow us down by a factor + ;; 2 when loading the .el file (this assumes we were careful to + ;; save this file so it doesn't need any decoding). + (let ((load-source-file-function nil)) + (unless (boundp 'package-activated-list) + (setq package-activated-list nil)) + (load qs nil 'nomessage)) + (require 'package) + (package--activate-all))))) + +(defun package--activate-all () + (dolist (elt (package--alist)) + (condition-case err + (package-activate (car elt)) + ;; Don't let failure of activation of a package arbitrarily stop + ;; activation of further packages. + (error (message "%s" (error-message-string err)))))) ;;;; Populating `package-archive-contents' from archives ;; This subsection populates the variables listed above from the @@ -2035,6 +2080,13 @@ PACKAGES are satisfied, i.e. that PACKAGES is computed using `package-compute-transaction'." (mapc #'package-install-from-archive packages)) +(defun package--archives-initialize () + "Make sure the list of installed and remote packages are initialized." + (unless package--initialized + (package-initialize t)) + (unless package-archive-contents + (package-refresh-contents))) + ;;;###autoload (defun package-install (pkg &optional dont-select) "Install the package PKG. @@ -2055,10 +2107,7 @@ to install it but still mark it as selected." (progn ;; Initialize the package system to get the list of package ;; symbols for completion. - (unless package--initialized - (package-initialize t)) - (unless package-archive-contents - (package-refresh-contents)) + (package--archives-initialize) (list (intern (completing-read "Install package: " (delq nil @@ -2068,6 +2117,7 @@ to install it but still mark it as selected." package-archive-contents)) nil t)) nil))) + (package--archives-initialize) (add-hook 'post-command-hook #'package-menu--post-refresh) (let ((name (if (package-desc-p pkg) (package-desc-name pkg) @@ -2083,7 +2133,8 @@ to install it but still mark it as selected." (package-compute-transaction () (list (list pkg)))))) (progn (package-download-transaction transaction) - (package--quickstart-maybe-refresh)) + (package--quickstart-maybe-refresh) + (message "Package `%s' installed." name)) (message "`%s' is already installed" name)))) (defun package-strip-rcs-id (str) @@ -2093,8 +2144,10 @@ Otherwise return nil." (when str (when (string-match "\\`[ \t]*[$]Revision:[ \t]+" str) (setq str (substring str (match-end 0)))) - (ignore-errors - (if (version-to-list str) str)))) + (let ((l (version-to-list str))) + ;; Don't return `str' but (package-version-join (version-to-list str)) + ;; to make sure we use a "canonical name"! + (if l (package-version-join l))))) (declare-function lm-homepage "lisp-mnt" (&optional file)) @@ -2134,6 +2187,7 @@ Downloads and installs required packages as needed." (unless (package--user-selected-p name) (package--save-selected-packages (cons name package-selected-packages))) + (package--quickstart-maybe-refresh) pkg-desc)) ;;;###autoload @@ -2319,10 +2373,7 @@ will be deleted." (setq guess nil)) (setq packages (mapcar #'symbol-name packages)) (let ((val - (completing-read (if guess - (format "Describe package (default %s): " - guess) - "Describe package: ") + (completing-read (format-prompt "Describe package" guess) packages nil t nil nil (when guess (symbol-name guess))))) (list (and (> (length val) 0) (intern val))))))) @@ -2378,18 +2429,9 @@ The description is read from the installed package files." result ;; Look for Commentary header. - (let ((mainsrcfile (expand-file-name (format "%s.el" (package-desc-name desc)) - srcdir))) - (when (file-readable-p mainsrcfile) - (with-temp-buffer - (insert (or (lm-commentary mainsrcfile) "")) - (goto-char (point-min)) - (when (re-search-forward "^;;; Commentary:\n" nil t) - (replace-match "")) - (while (re-search-forward "^\\(;+ ?\\)" nil t) - (replace-match "")) - (buffer-string)))) - ))) + (lm-commentary (expand-file-name + (format "%s.el" (package-desc-name desc)) srcdir)) + ""))) (defun describe-package-1 (pkg) "Insert the package description for PKG. @@ -2584,16 +2626,10 @@ Helper function for `describe-package'." (if built-in ;; For built-in packages, get the description from the ;; Commentary header. - (let ((fn (locate-file (format "%s.el" name) load-path - load-file-rep-suffixes)) - (opoint (point))) - (insert (or (lm-commentary fn) "")) - (save-excursion - (goto-char opoint) - (when (re-search-forward "^;;; Commentary:\n" nil t) - (replace-match "")) - (while (re-search-forward "^\\(;+ ?\\)" nil t) - (replace-match "")))) + (insert (or (lm-commentary (locate-file (format "%s.el" name) + load-path + load-file-rep-suffixes)) + "")) (if (package-installed-p desc) ;; For installed packages, get the description from the @@ -2630,8 +2666,7 @@ Used for the `action' property of buttons in the buffer created by (when (y-or-n-p (format-message "Install package `%s'? " (package-desc-full-name pkg-desc))) (package-install pkg-desc nil) - (revert-buffer nil t) - (goto-char (point-min))))) + (describe-package (package-desc-name pkg-desc))))) (defun package-delete-button-action (button) "Run `package-delete' on the package BUTTON points to. @@ -2641,8 +2676,7 @@ Used for the `action' property of buttons in the buffer created by (when (y-or-n-p (format-message "Delete package `%s'? " (package-desc-full-name pkg-desc))) (package-delete pkg-desc) - (revert-buffer nil t) - (goto-char (point-min))))) + (describe-package (package-desc-name pkg-desc))))) (defun package-keyword-button-action (button) "Show filtered \"*Packages*\" buffer for BUTTON. @@ -2696,15 +2730,22 @@ either a full name or nil, and EMAIL is a valid email address." (define-key map "i" 'package-menu-mark-install) (define-key map "U" 'package-menu-mark-upgrades) (define-key map "r" 'revert-buffer) - (define-key map (kbd "/ k") 'package-menu-filter-by-keyword) - (define-key map (kbd "/ n") 'package-menu-filter-by-name) - (define-key map (kbd "/ /") 'package-menu-clear-filter) (define-key map "~" 'package-menu-mark-obsolete-for-deletion) (define-key map "x" 'package-menu-execute) (define-key map "h" 'package-menu-quick-help) (define-key map "H" #'package-menu-hide-package) (define-key map "?" 'package-menu-describe-package) (define-key map "(" #'package-menu-toggle-hiding) + (define-key map (kbd "/ /") 'package-menu-clear-filter) + (define-key map (kbd "/ a") 'package-menu-filter-by-archive) + (define-key map (kbd "/ d") 'package-menu-filter-by-description) + (define-key map (kbd "/ k") 'package-menu-filter-by-keyword) + (define-key map (kbd "/ N") 'package-menu-filter-by-name-or-description) + (define-key map (kbd "/ n") 'package-menu-filter-by-name) + (define-key map (kbd "/ s") 'package-menu-filter-by-status) + (define-key map (kbd "/ v") 'package-menu-filter-by-version) + (define-key map (kbd "/ m") 'package-menu-filter-marked) + (define-key map (kbd "/ u") 'package-menu-filter-upgradable) map) "Local keymap for `package-menu-mode' buffers.") @@ -2730,8 +2771,15 @@ either a full name or nil, and EMAIL is a valid email address." "--" ("Filter Packages" + ["Filter by Archive" package-menu-filter-by-archive :help "Filter packages by archive"] + ["Filter by Description" package-menu-filter-by-description :help "Filter packages by description"] ["Filter by Keyword" package-menu-filter-by-keyword :help "Filter packages by keyword"] ["Filter by Name" package-menu-filter-by-name :help "Filter packages by name"] + ["Filter by Name or Description" package-menu-filter-by-name-or-description + :help "Filter packages by name or description"] + ["Filter by Status" package-menu-filter-by-status :help "Filter packages by status"] + ["Filter by Version" package-menu-filter-by-version :help "Filter packages by version"] + ["Filter Marked" package-menu-filter-marked :help "Filter packages marked for upgrade"] ["Clear Filter" package-menu-clear-filter :help "Clear package list filter"]) ["Hide by Regexp" package-menu-hide-package :help "Hide all packages matching a regexp"] @@ -2758,11 +2806,11 @@ Letters do not insert themselves; instead, they are commands. (package-menu--transaction-status package-menu--transaction-status))) (setq tabulated-list-format - `[("Package" 18 package-menu--name-predicate) - ("Version" 13 package-menu--version-predicate) - ("Status" 10 package-menu--status-predicate) + `[("Package" ,package-name-column-width package-menu--name-predicate) + ("Version" ,package-version-column-width package-menu--version-predicate) + ("Status" ,package-status-column-width package-menu--status-predicate) ,@(if (cdr package-archives) - '(("Archive" 10 package-menu--archive-predicate))) + `(("Archive" ,package-archive-column-width package-menu--archive-predicate))) ("Description" 0 package-menu--description-predicate)]) (setq tabulated-list-padding 2) (setq tabulated-list-sort-key (cons "Status" nil)) @@ -3041,8 +3089,21 @@ When none are given, the package matches." found) t)) -(defun package-menu--generate (remember-pos packages &optional keywords) - "Populate the Package Menu. +(defun package-menu--display (remember-pos suffix) + "Display the Package Menu. +If REMEMBER-POS is non-nil, keep point on the same entry. + +If SUFFIX is non-nil, append that to \"Package\" for the first +column in the header line." + (setf (car (aref tabulated-list-format 0)) + (if suffix + (concat "Package[" suffix "]") + "Package")) + (tabulated-list-init-header) + (tabulated-list-print remember-pos)) + +(defun package-menu--generate (remember-pos &optional packages keywords) + "Populate and display the Package Menu. If REMEMBER-POS is non-nil, keep point on the same entry. PACKAGES should be t, which means to display all known packages, or a list of package names (symbols) to display. @@ -3050,13 +3111,10 @@ or a list of package names (symbols) to display. With KEYWORDS given, only packages with those keywords are shown." (package-menu--refresh packages keywords) - (setf (car (aref tabulated-list-format 0)) - (if keywords - (let ((filters (mapconcat #'identity keywords ","))) - (concat "Package[" filters "]")) - "Package")) - (tabulated-list-init-header) - (tabulated-list-print remember-pos)) + (package-menu--display remember-pos + (when keywords + (let ((filters (mapconcat #'identity keywords ","))) + (concat "Package[" filters "]"))))) (defun package-menu--print-info (pkg) "Return a package entry suitable for `tabulated-list-entries'. @@ -3202,9 +3260,9 @@ To unhide a package, type `\\[customize-variable] RET package-hidden-regexps'. Type \\[package-menu-toggle-hiding] to toggle package hiding." + (declare (interactive-only "change `package-hidden-regexps' instead.")) (interactive) (package--ensure-package-menu-mode) - (declare (interactive-only "change `package-hidden-regexps' instead.")) (let* ((name (when (derived-mode-p 'package-menu-mode) (concat "\\`" (regexp-quote (symbol-name (package-desc-name (tabulated-list-get-id)))) @@ -3675,7 +3733,7 @@ short description." (package-menu--generate nil t))) ;; The package menu buffer has keybindings. If the user types ;; `M-x list-packages', that suggests it should become current. - (switch-to-buffer buf))) + (pop-to-buffer-same-window buf))) ;;;###autoload (defalias 'package-list-packages 'list-packages) @@ -3700,48 +3758,239 @@ shown." (select-window win) (switch-to-buffer buf)))) +(defun package-menu--filter-by (predicate suffix) + "Filter \"*Packages*\" buffer by PREDICATE and add SUFFIX to header. +PREDICATE is a function which will be called with one argument, a +`package-desc' object, and returns t if that object should be +listed in the Package Menu. + +SUFFIX is passed on to `package-menu--display' and is added to +the header line of the first column." + ;; Update `tabulated-list-entries' so that it contains all + ;; packages before searching. + (package-menu--refresh t nil) + (let (found-entries) + (dolist (entry tabulated-list-entries) + (when (funcall predicate (car entry)) + (push entry found-entries))) + (if found-entries + (progn + (setq tabulated-list-entries found-entries) + (package-menu--display t suffix)) + (user-error "No packages found")))) + +(defun package-menu-filter-by-archive (archive) + "Filter the \"*Packages*\" buffer by ARCHIVE. +Display only packages from package archive ARCHIVE. + +When called interactively, prompt for ARCHIVE, which can be a +comma-separated string. If ARCHIVE is empty, show all packages. + +When called from Lisp, ARCHIVE can be a string or a list of +strings. If ARCHIVE is nil or the empty string, show all +packages." + (interactive (list (completing-read-multiple + "Filter by archive (comma separated): " + (mapcar #'car package-archives)))) + (package--ensure-package-menu-mode) + (let ((re (if (listp archive) + (regexp-opt archive) + archive))) + (package-menu--filter-by (lambda (pkg-desc) + (let ((pkg-archive (package-desc-archive pkg-desc))) + (and pkg-archive + (string-match-p re pkg-archive)))) + (concat "archive:" (if (listp archive) + (string-join archive ",") + archive))))) + +(defun package-menu-filter-by-description (description) + "Filter the \"*Packages*\" buffer by DESCRIPTION regexp. +Display only packages with a description that matches regexp +DESCRIPTION. + +When called interactively, prompt for DESCRIPTION. + +If DESCRIPTION is nil or the empty string, show all packages." + (interactive (list (read-regexp "Filter by description (regexp)"))) + (package--ensure-package-menu-mode) + (if (or (not description) (string-empty-p description)) + (package-menu--generate t t) + (package-menu--filter-by (lambda (pkg-desc) + (string-match description + (package-desc-summary pkg-desc))) + (format "desc:%s" description)))) + (defun package-menu-filter-by-keyword (keyword) "Filter the \"*Packages*\" buffer by KEYWORD. -Show only those items that relate to the specified KEYWORD. - -KEYWORD can be a string or a list of strings. If it is a list, a -package will be displayed if it matches any of the keywords. -Interactively, it is a list of strings separated by commas. - -KEYWORD can also be used to filter by status or archive name by -using keywords like \"arc:gnu\" and \"status:available\". -Statuses available include \"incompat\", \"available\", -\"built-in\" and \"installed\"." - (interactive - (list (completing-read-multiple - "Keywords (comma separated): " (package-all-keywords)))) +Display only packages with specified KEYWORD. + +When called interactively, prompt for KEYWORD, which can be a +comma-separated string. If KEYWORD is empty, show all packages. + +When called from Lisp, KEYWORD can be a string or a list of +strings. If KEYWORD is nil or the empty string, show all +packages." + (interactive (list (completing-read-multiple + "Keywords (comma separated): " + (package-all-keywords)))) + (when (stringp keyword) + (setq keyword (list keyword))) (package--ensure-package-menu-mode) - (package-show-package-list t (if (stringp keyword) - (list keyword) - keyword))) + (if (not keyword) + (package-menu--generate t t) + (package-menu--filter-by (lambda (pkg-desc) + (package--has-keyword-p pkg-desc keyword)) + (concat "keyword:" (string-join keyword ","))))) (define-obsolete-function-alias 'package-menu-filter #'package-menu-filter-by-keyword "27.1") +(defun package-menu-filter-by-name-or-description (name-or-description) + "Filter the \"*Packages*\" buffer by NAME-OR-DESCRIPTION regexp. +Display only packages with a name-or-description that matches regexp +NAME-OR-DESCRIPTION. + +When called interactively, prompt for NAME-OR-DESCRIPTION. + +If NAME-OR-DESCRIPTION is nil or the empty string, show all +packages." + (interactive (list (read-regexp "Filter by name or description (regexp)"))) + (package--ensure-package-menu-mode) + (if (or (not name-or-description) (string-empty-p name-or-description)) + (package-menu--generate t t) + (package-menu--filter-by (lambda (pkg-desc) + (or (string-match name-or-description + (package-desc-summary pkg-desc)) + (string-match name-or-description + (symbol-name + (package-desc-name pkg-desc))))) + (format "name-or-desc:%s" name-or-description)))) + (defun package-menu-filter-by-name (name) - "Filter the \"*Packages*\" buffer by NAME. -Show only those items whose name matches the regular expression -NAME. If NAME is nil or the empty string, show all packages." - (interactive (list (read-from-minibuffer "Filter by name (regexp): "))) + "Filter the \"*Packages*\" buffer by NAME regexp. +Display only packages with name that matches regexp NAME. + +When called interactively, prompt for NAME. + +If NAME is nil or the empty string, show all packages." + (interactive (list (read-regexp "Filter by name (regexp)"))) (package--ensure-package-menu-mode) (if (or (not name) (string-empty-p name)) - (package-show-package-list t nil) - ;; Update `tabulated-list-entries' so that it contains all - ;; packages before searching. - (package-menu--refresh t nil) - (let (matched) - (dolist (entry tabulated-list-entries) - (let* ((pkg-name (package-desc-name (car entry)))) - (when (string-match name (symbol-name pkg-name)) - (push pkg-name matched)))) - (if matched - (package-show-package-list matched nil) - (user-error "No packages found"))))) + (package-menu--generate t t) + (package-menu--filter-by (lambda (pkg-desc) + (string-match-p name (symbol-name + (package-desc-name pkg-desc)))) + (format "name:%s" name)))) + +(defun package-menu-filter-by-status (status) + "Filter the \"*Packages*\" buffer by STATUS. +Display only packages with specified STATUS. + +When called interactively, prompt for STATUS, which can be a +comma-separated string. If STATUS is empty, show all packages. + +When called from Lisp, STATUS can be a string or a list of +strings. If STATUS is nil or the empty string, show all +packages." + (interactive (list (completing-read "Filter by status: " + '("avail-obso" + "available" + "built-in" + "dependency" + "disabled" + "external" + "held" + "incompat" + "installed" + "new" + "unsigned")))) + (package--ensure-package-menu-mode) + (if (or (not status) (string-empty-p status)) + (package-menu--generate t t) + (package-menu--filter-by (lambda (pkg-desc) + (string-match-p status (package-desc-status pkg-desc))) + (format "status:%s" status)))) + +(defun package-menu-filter-by-version (version predicate) + "Filter the \"*Packages*\" buffer by VERSION and PREDICATE. +Display only packages with a matching version. + +When called interactively, prompt for one of the qualifiers `<', +`>' or `=', and a package version. Show only packages that has a +lower (`<'), equal (`=') or higher (`>') version than the +specified one. + +When called from Lisp, VERSION should be a version string and +PREDICATE should be the symbol `=', `<' or `>'. + +If VERSION is nil or the empty string, show all packages." + (interactive (let ((choice (intern + (char-to-string + (read-char-choice + "Filter by version? [Type =, <, > or q] " + '(?< ?> ?= ?q)))))) + (if (eq choice 'q) + '(quit nil) + (list (read-from-minibuffer + (concat "Filter by version (" + (pcase choice + ('= "= equal to") + ('< "< less than") + ('> "> greater than")) + "): ")) + choice)))) + (unless (equal predicate 'quit) + (if (or (not version) (string-empty-p version)) + (package-menu--generate t t) + (package-menu--filter-by + (let ((fun (pcase predicate + ('= #'version-list-=) + ('< #'version-list-<) + ('> (lambda (a b) (not (version-list-<= a b)))) + (_ (error "Unknown predicate: %s" predicate)))) + (ver (version-to-list version))) + (lambda (pkg-desc) + (funcall fun (package-desc-version pkg-desc) ver))) + (format "versions:%s%s" predicate version))))) + +(defun package-menu-filter-marked () + "Filter \"*Packages*\" buffer by non-empty upgrade mark. +Unlike other filters, this leaves the marks intact." + (interactive) + (package--ensure-package-menu-mode) + (widen) + (let (found-entries mark pkg-id entry marks) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (setq mark (char-after)) + (unless (eq mark ?\s) + (setq pkg-id (tabulated-list-get-id)) + (setq entry (package-menu--print-info-simple pkg-id)) + (push entry found-entries) + ;; remember the mark + (push (cons pkg-id mark) marks)) + (forward-line)) + (if found-entries + (progn + (setq tabulated-list-entries found-entries) + (package-menu--display t nil) + ;; redo the marks, but we must remember the marks!! + (goto-char (point-min)) + (while (not (eobp)) + (setq mark (cdr (assq (tabulated-list-get-id) marks))) + (tabulated-list-put-tag (char-to-string mark) t))) + (user-error "No packages found"))))) + +(defun package-menu-filter-upgradable () + "Filter \"*Packages*\" buffer to show only upgradable packages." + (interactive) + (let ((pkgs (mapcar #'car (package-menu--find-upgrades)))) + (package-menu--filter-by + (lambda (pkg) + (memql (package-desc-name pkg) pkgs)) + "upgradable"))) (defun package-menu-clear-filter () "Clear any filter currently applied to the \"*Packages*\" buffer." @@ -3790,6 +4039,7 @@ The return value is a string (or nil in case we can't find it)." (or (lm-header "package-version") (lm-header "version"))))))))) + ;;;; Quickstart: precompute activation actions for faster start up. ;; Activating packages via `package-initialize' is costly: for N installed @@ -3811,10 +4061,12 @@ activations need to be changed, such as when `package-load-list' is modified." :type 'boolean :version "27.1") +;;;###autoload (defcustom package-quickstart-file (locate-user-emacs-file "package-quickstart.el") "Location of the file used to speed up activation of packages at startup." :type 'file + :initialize #'custom-initialize-delay :version "27.1") (defun package--quickstart-maybe-refresh () @@ -3822,6 +4074,7 @@ activations need to be changed, such as when `package-load-list' is modified." ;; FIXME: Delay refresh in case we're installing/deleting ;; several packages! (package-quickstart-refresh) + (delete-file (concat package-quickstart-file "c")) (delete-file package-quickstart-file))) (defun package-quickstart-refresh () @@ -3876,10 +4129,12 @@ activations need to be changed, such as when `package-load-list' is modified." (insert " ;; Local\sVariables: ;; version-control: never -;;\sno-byte-compile: t ;; no-update-autoloads: t ;; End: -")))) +")) + ;; FIXME: Do it asynchronously in an Emacs subprocess, and + ;; don't show the byte-compiler warnings. + (byte-compile-file package-quickstart-file))) (defun package--imenu-prev-index-position-function () "Move point to previous line in package-menu buffer. @@ -3899,6 +4154,15 @@ beginning of the line." (package-version-join (package-desc-version package-desc)) (package-desc-summary package-desc)))) +;;;; Introspection + +(defun package-get-descriptor (pkg-name) + "Return the `package-desc' of PKG-NAME." + (unless package--initialized (package-initialize 'no-activate)) + (or (package--get-activatable-pkg pkg-name) + (cadr (assq pkg-name package-alist)) + (cadr (assq pkg-name package-archive-contents)))) + (provide 'package) ;;; package.el ends here diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 9656053ca12..cf129c453ec 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2010-2021 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> -;; Keywords: +;; Keywords: extensions ;; This file is part of GNU Emacs. @@ -39,10 +39,10 @@ ;; - along these lines, provide patterns to match CL structs. ;; - provide something like (setq VAR) so a var can be set rather than ;; let-bound. -;; - provide a way to fallthrough to subsequent cases (not sure what I meant by -;; this :-() +;; - provide a way to fallthrough to subsequent cases +;; (e.g. Like Racket's (=> ID). ;; - try and be more clever to reduce the size of the decision tree, and -;; to reduce the number of leaves that need to be turned into function: +;; to reduce the number of leaves that need to be turned into functions: ;; - first, do the tests shared by all remaining branches (it will have ;; to be performed anyway, so better do it first so it's shared). ;; - then choose the test that discriminates more (?). @@ -97,11 +97,15 @@ (declare-function get-edebug-spec "edebug" (symbol)) (declare-function edebug-match "edebug" (cursor specs)) +(defun pcase--get-macroexpander (s) + "Return the macroexpander for pcase pattern head S, or nil" + (get s 'pcase-macroexpander)) + (defun pcase--edebug-match-macro (cursor) (let (specs) (mapatoms (lambda (s) - (let ((m (get s 'pcase-macroexpander))) + (let ((m (pcase--get-macroexpander s))) (when (and m (get-edebug-spec m)) (push (cons (symbol-name s) (get-edebug-spec m)) specs))))) @@ -128,6 +132,7 @@ PATTERN matches. PATTERN can take one of the forms: If a SYMBOL is used twice in the same pattern the second occurrence becomes an `eq'uality test. (pred FUN) matches if FUN called on EXPVAL returns non-nil. + (pred (not FUN)) matches if FUN called on EXPVAL returns nil. (app FUN PAT) matches if FUN called on EXPVAL matches PAT. (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. (let PAT EXPR) matches if EXPR matches PAT. @@ -193,7 +198,7 @@ Emacs Lisp manual for more information and examples." (let (more) ;; Collect all the extensions. (mapatoms (lambda (symbol) - (let ((me (get symbol 'pcase-macroexpander))) + (let ((me (pcase--get-macroexpander symbol))) (when me (push (cons symbol me) more))))) @@ -344,7 +349,8 @@ of the elements of LIST is performed as if by `pcase-let'. (seen '()) (codegen (lambda (code vars) - (let ((prev (assq code seen))) + (let ((vars (macroexp--fgrep vars code)) + (prev (assq code seen))) (if (not prev) (let ((res (pcase-codegen code vars))) (push (list code vars res) seen) @@ -398,14 +404,18 @@ of the elements of LIST is performed as if by `pcase-let'. (if (pcase--small-branch-p (cdr case)) ;; Don't bother sharing multiple ;; occurrences of this leaf since it's small. - #'pcase-codegen codegen) + (lambda (code vars) + (pcase-codegen code + (macroexp--fgrep vars code))) + codegen) (cdr case) vars)))) cases)))) (dolist (case cases) (unless (or (memq case used-cases) (memq (car case) pcase--dontwarn-upats)) - (message "Redundant pcase pattern: %S" (car case)))) + (message "pcase pattern %S shadowed by previous pcase pattern" + (car case)))) (macroexp-let* defs main)))) (defun pcase--macroexpand (pat) @@ -419,7 +429,7 @@ of the elements of LIST is performed as if by `pcase-let'. ((eq head 'let) `(let ,(pcase--macroexpand (cadr pat)) ,@(cddr pat))) ((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat)))) (t - (let* ((expander (get head 'pcase-macroexpander)) + (let* ((expander (pcase--get-macroexpander head)) (npat (if expander (apply expander (cdr pat))))) (if (null npat) (error (if expander @@ -590,7 +600,7 @@ MATCH is the pattern that needs to be matched, of the form: ((null (cdr else-alts)) (car else-alts)) (t (cons (car match) (nreverse else-alts))))))) ((memq match '(:pcase--succeed :pcase--fail)) (cons match match)) - (t (error "Uknown MATCH %s" match)))) + (t (error "Unknown MATCH %s" match)))) (defun pcase--split-rest (sym splitter rest) (let ((then-rest '()) @@ -653,6 +663,14 @@ MATCH is the pattern that needs to be matched, of the form: '(:pcase--succeed . nil)))) (defun pcase--split-pred (vars upat pat) + "Indicate the overlap or mutual-exclusion between UPAT and PAT. +More specifically retuns a pair (A . B) where A indicates whether PAT +can match when UPAT has matched, and B does the same for the case +where UPAT failed to match. +A and B can be one of: +- nil if we don't know +- `:pcase--fail' if UPAT match's result implies that PAT can't match +- `:pcase--succeed' if UPAT match's result implies that PAT matches" (let (test) (cond ((and (equal upat pat) @@ -663,21 +681,44 @@ MATCH is the pattern that needs to be matched, of the form: ;; run, but we don't have the environment in which `pat' will ;; run, so we can't do a reliable verification. But let's try ;; and catch at least the easy cases such as (bug#14773). - (not (pcase--fgrep (mapcar #'car vars) (cadr upat))))) + (not (macroexp--fgrep (mapcar #'car vars) (cadr upat))))) '(:pcase--succeed . :pcase--fail)) - ((and (eq 'pred (car upat)) - (let ((otherpred - (cond ((eq 'pred (car-safe pat)) (cadr pat)) - ((not (eq 'quote (car-safe pat))) nil) - ((consp (cadr pat)) #'consp) - ((stringp (cadr pat)) #'stringp) - ((vectorp (cadr pat)) #'vectorp) - ((byte-code-function-p (cadr pat)) - #'byte-code-function-p)))) - (pcase--mutually-exclusive-p (cadr upat) otherpred))) + ;; In case PAT is of the form (pred (not PRED)) + ((and (eq 'pred (car-safe pat)) (eq 'not (car-safe (cadr pat)))) + (let* ((test (cadr (cadr pat))) + (res (pcase--split-pred vars upat `(pred ,test))) + (reverse (lambda (x) (cond ((eq x :pcase--succeed) :pcase--fail) + ((eq x :pcase--fail) :pcase--succeed))))) + (cons (funcall reverse (car res)) + (funcall reverse (cdr res))))) + ;; All the rest below presumes UPAT is of the form (pred ...). + ((not (eq 'pred (car upat))) nil) + ;; In case UPAT is of the form (pred (not PRED)) + ((eq 'not (car-safe (cadr upat))) + (let* ((test (cadr (cadr upat))) + (res (pcase--split-pred vars `(pred ,test) pat))) + (cons (cdr res) (car res)))) + ((let ((otherpred + (cond ((eq 'pred (car-safe pat)) (cadr pat)) + ((not (eq 'quote (car-safe pat))) nil) + ((consp (cadr pat)) #'consp) + ((stringp (cadr pat)) #'stringp) + ((vectorp (cadr pat)) #'vectorp) + ((byte-code-function-p (cadr pat)) + #'byte-code-function-p)))) + (pcase--mutually-exclusive-p (cadr upat) otherpred)) '(:pcase--fail . nil)) - ((and (eq 'pred (car upat)) - (eq 'quote (car-safe pat)) + ;; Since we turn (or 'a 'b 'c) into (pred (pcase--flip (memq '(a b c)))) + ;; try and preserve the info we get from that memq test. + ((and (eq 'pcase--flip (car-safe (cadr upat))) + (memq (cadr (cadr upat)) '(memq member memql)) + (eq 'quote (car-safe (nth 2 (cadr upat)))) + (eq 'quote (car-safe pat))) + (let ((set (cadr (nth 2 (cadr upat))))) + (if (member (cadr pat) set) + '(nil . :pcase--fail) + '(:pcase--fail . nil)))) + ((and (eq 'quote (car-safe pat)) (symbolp (cadr upat)) (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat))) (get (cadr upat) 'side-effect-free) @@ -687,15 +728,6 @@ MATCH is the pattern that needs to be matched, of the form: '(nil . :pcase--fail) '(:pcase--fail . nil)))))) -(defun pcase--fgrep (vars sexp) - "Check which of the symbols VARS appear in SEXP." - (let ((res '())) - (while (consp sexp) - (dolist (var (pcase--fgrep vars (pop sexp))) - (unless (memq var res) (push var res)))) - (and (memq sexp vars) (not (memq sexp res)) (push sexp res)) - res)) - (defun pcase--self-quoting-p (upat) (or (keywordp upat) (integerp upat) (stringp upat))) @@ -713,7 +745,7 @@ MATCH is the pattern that needs to be matched, of the form: (pcase--app-subst-match match sym fun nsym)) (cdr match)))) ((memq match '(:pcase--succeed :pcase--fail)) match) - (t (error "Uknown MATCH %s" match)))) + (t (error "Unknown MATCH %s" match)))) (defun pcase--app-subst-rest (rest sym fun nsym) (mapcar (lambda (branch) @@ -732,15 +764,15 @@ MATCH is the pattern that needs to be matched, of the form: (defun pcase--funcall (fun arg vars) "Build a function call to FUN with arg ARG." - (if (symbolp fun) - `(,fun ,arg) - (let* (;; `vs' is an upper bound on the vars we need. - (vs (pcase--fgrep (mapcar #'car vars) fun)) - (env (mapcar (lambda (var) - (list var (cdr (assq var vars)))) - vs)) + (cond + ((symbolp fun) `(,fun ,arg)) + ((eq 'not (car-safe fun)) `(not ,(pcase--funcall (cadr fun) arg vars))) + (t + (let* (;; `env' is an upper bound on the bindings we need. + (env (mapcar (lambda (x) (list (car x) (cdr x))) + (macroexp--fgrep vars fun))) (call (progn - (when (memq arg vs) + (when (assq arg env) ;; `arg' is shadowed by `env'. (let ((newsym (gensym "x"))) (push (list newsym arg) env) @@ -748,21 +780,23 @@ MATCH is the pattern that needs to be matched, of the form: (if (functionp fun) `(funcall #',fun ,arg) `(,@fun ,arg))))) - (if (null vs) + (if (null env) call ;; Let's not replace `vars' in `fun' since it's ;; too difficult to do it right, instead just ;; let-bind `vars' around `fun'. - `(let* ,env ,call))))) + `(let* ,env ,call)))))) (defun pcase--eval (exp vars) "Build an expression that will evaluate EXP." (let* ((found (assq exp vars))) (if found (cdr found) - (let* ((vs (pcase--fgrep (mapcar #'car vars) exp)) - (env (mapcar (lambda (v) (list v (cdr (assq v vars)))) - vs))) - (if env (macroexp-let* env exp) exp))))) + (let* ((env (macroexp--fgrep vars exp))) + (if env + (macroexp-let* (mapcar (lambda (x) (list (car x) (cdr x))) + env) + exp) + exp))))) ;; It's very tempting to use `pcase' below, tho obviously, it'd create ;; bootstrapping problems. diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index cd2e80907a8..ef4c9603284 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -94,33 +94,31 @@ after OUT-BUFFER-NAME." ;; This function either decides not to display it at all ;; or displays it in the usual way. (temp-buffer-show-function - (function - (lambda (buf) - (with-current-buffer buf - (goto-char (point-min)) - (end-of-line 1) - (if (or (< (1+ (point)) (point-max)) - (>= (- (point) (point-min)) (frame-width))) - (let ((temp-buffer-show-function old-show-function) - (old-selected (selected-window)) - (window (display-buffer buf))) - (goto-char (point-min)) ; expected by some hooks ... - (make-frame-visible (window-frame window)) - (unwind-protect - (progn - (select-window window) - (run-hooks 'temp-buffer-show-hook)) - (when (window-live-p old-selected) - (select-window old-selected)) - (message "See buffer %s." out-buffer-name))) - (message "%s" (buffer-substring (point-min) (point))) - )))))) + (lambda (buf) + (with-current-buffer buf + (goto-char (point-min)) + (end-of-line 1) + (if (or (< (1+ (point)) (point-max)) + (>= (- (point) (point-min)) (frame-width))) + (let ((temp-buffer-show-function old-show-function) + (old-selected (selected-window)) + (window (display-buffer buf))) + (goto-char (point-min)) ; expected by some hooks ... + (make-frame-visible (window-frame window)) + (unwind-protect + (progn + (select-window window) + (run-hooks 'temp-buffer-show-hook)) + (when (window-live-p old-selected) + (select-window old-selected)) + (message "See buffer %s." out-buffer-name))) + (message "%s" (buffer-substring (point-min) (point)))))))) (with-output-to-temp-buffer out-buffer-name (pp expression) (with-current-buffer standard-output (emacs-lisp-mode) (setq buffer-read-only nil) - (set (make-local-variable 'font-lock-verbose) nil))))) + (setq-local font-lock-verbose nil))))) ;;;###autoload (defun pp-eval-expression (expression) @@ -164,8 +162,11 @@ With argument, pretty-print output into current buffer. Ignores leading comment characters." (interactive "P") (if arg - (insert (pp-to-string (eval (pp-last-sexp) lexical-binding))) - (pp-eval-expression (pp-last-sexp)))) + (insert (pp-to-string (eval (elisp--eval-defun-1 + (macroexpand (pp-last-sexp))) + lexical-binding))) + (pp-eval-expression (elisp--eval-defun-1 + (macroexpand (pp-last-sexp)))))) ;;;###autoload (defun pp-macroexpand-last-sexp (arg) diff --git a/lisp/emacs-lisp/radix-tree.el b/lisp/emacs-lisp/radix-tree.el index 6a483a6d498..0905ac608bb 100644 --- a/lisp/emacs-lisp/radix-tree.el +++ b/lisp/emacs-lisp/radix-tree.el @@ -198,9 +198,10 @@ If not found, return nil." (pcase-defmacro radix-tree-leaf (vpat) "Pattern which matches a radix-tree leaf. The pattern VPAT is matched against the leaf's carried value." - ;; FIXME: We'd like to use a negative pattern (not consp), but pcase - ;; doesn't support it. Using `atom' works but generates sub-optimal code. - `(or `(t . ,,vpat) (and (pred atom) ,vpat)))) + ;; We used to use `(pred atom)', but `pcase' doesn't understand that + ;; `atom' is equivalent to the negation of `consp' and hence generates + ;; suboptimal code. + `(or `(t . ,,vpat) (and (pred (not consp)) ,vpat)))) (defun radix-tree-iter-subtrees (tree fun) "Apply FUN to every immediate subtree of radix TREE. diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index 86215f6519c..ce8d98df807 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -96,7 +96,7 @@ ;; out. ;; Q: But how can I then make out the sub-expressions? -;; A: Thats where the `sub-expression mode' comes in. In it only the +;; A: That's where the `sub-expression mode' comes in. In it only the ;; digit keys are assigned to perform an update that will flash the ;; corresponding subexp only. @@ -187,14 +187,14 @@ Set it to nil if you don't want limits here." (defvar reb-target-window nil "Window to which the RE is applied to.") -(defvar reb-regexp nil +(defvar-local reb-regexp nil "Last regexp used by RE Builder.") -(defvar reb-regexp-src nil +(defvar-local reb-regexp-src nil "Last regexp used by RE Builder before processing it. Except for Lisp syntax this is the same as `reb-regexp'.") -(defvar reb-overlays nil +(defvar-local reb-overlays nil "List of overlays of the RE Builder.") (defvar reb-window-config nil @@ -212,10 +212,6 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (defvar reb-valid-string "" "String in mode line showing validity of RE.") -(make-variable-buffer-local 'reb-overlays) -(make-variable-buffer-local 'reb-regexp) -(make-variable-buffer-local 'reb-regexp-src) - (defconst reb-buffer "*RE-Builder*" "Buffer to use for the RE Builder.") @@ -271,7 +267,7 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (define-derived-mode reb-mode nil "RE Builder" "Major mode for interactively building Regular Expressions." - (set (make-local-variable 'blink-matching-paren) nil) + (setq-local blink-matching-paren nil) (reb-mode-common)) (defvar reb-lisp-mode-map @@ -489,7 +485,7 @@ Optional argument SYNTAX must be specified if called non-interactively." (interactive (list (intern (completing-read - (format "Select syntax (default %s): " reb-re-syntax) + (format-prompt "Select syntax" reb-re-syntax) '(read string sregex rx) nil t nil nil (symbol-name reb-re-syntax) 'reb-change-syntax-hist)))) @@ -832,8 +828,8 @@ If SUBEXP is non-nil mark only the corresponding sub-expressions." (let ((font-lock-is-on font-lock-mode)) (font-lock-mode -1) (kill-local-variable 'font-lock-set-defaults) - ;;(set (make-local-variable 'reb-re-syntax) 'string) - ;;(set (make-local-variable 'reb-re-syntax) 'rx) + ;;(setq-local reb-re-syntax 'string) + ;;(setq-local reb-re-syntax 'rx) (setq font-lock-defaults (cond ((memq reb-re-syntax '(read string)) diff --git a/lisp/emacs-lisp/regi.el b/lisp/emacs-lisp/regi.el index da520f94566..527af1ddf24 100644 --- a/lisp/emacs-lisp/regi.el +++ b/lisp/emacs-lisp/regi.el @@ -1,10 +1,10 @@ -;;; regi.el --- REGular expression Interpreting engine +;;; regi.el --- REGular expression Interpreting engine -*- lexical-binding: t; -*- ;; Copyright (C) 1993, 2001-2021 Free Software Foundation, Inc. ;; Author: 1993 Barry A. Warsaw, Century Computing, Inc. <bwarsaw@cen.com> ;; Created: 24-Feb-1993 -;; Version: 1.8 +;; Old-Version: 1.8 ;; Last Modified: 1993/06/01 21:33:00 ;; Keywords: extensions, matching @@ -153,7 +153,7 @@ useful information: ;; set up the narrowed region (and start end - (let* ((tstart start) + (let* (;; (tstart start) (start (min start end)) (end (max start end))) (narrow-to-region @@ -163,18 +163,15 @@ useful information: ;; let's find the special tags and remove them from the working ;; frame. note that only the last special tag is used. (mapc - (function - (lambda (entry) - (let ((pred (car entry)) - (func (car (cdr entry)))) - (cond - ((eq pred 'begin) (setq begin-tag func)) - ((eq pred 'end) (setq end-tag func)) - ((eq pred 'every) (setq every-tag func)) - (t - (setq working-frame (append working-frame (list entry)))) - ) ; end-cond - ))) + (lambda (entry) + (let ((pred (car entry)) + (func (car (cdr entry)))) + (cond + ((eq pred 'begin) (setq begin-tag func)) + ((eq pred 'end) (setq end-tag func)) + ((eq pred 'every) (setq every-tag func)) + (t + (setq working-frame (append working-frame (list entry))))))) frame) ; end-mapcar ;; execute the begin entry @@ -209,30 +206,33 @@ useful information: ;; if the line matched, package up the argument list and ;; funcall the FUNC (if match-p - (let* ((curline (buffer-substring - (regi-pos 'bol) - (regi-pos 'eol))) - (curframe current-frame) - (curentry entry) - (result (eval func)) - (step (or (cdr (assq 'step result)) 1)) - ) - ;; changing frame on the fly? - (if (assq 'frame result) - (setq working-frame (cdr (assq 'frame result)))) - - ;; continue processing current frame? - (if (memq 'continue result) - (setq current-frame (cdr current-frame)) - (forward-line step) - (setq current-frame working-frame)) - - ;; abort current frame? - (if (memq 'abort result) - (progn - (setq donep t) - (throw 'regi-throw-top t))) - ) ; end-let + (with-suppressed-warnings + ((lexical curframe curentry curline)) + (defvar curframe) (defvar curentry) (defvar curline) + (let* ((curline (buffer-substring + (regi-pos 'bol) + (regi-pos 'eol))) + (curframe current-frame) + (curentry entry) + (result (eval func)) + (step (or (cdr (assq 'step result)) 1)) + ) + ;; changing frame on the fly? + (if (assq 'frame result) + (setq working-frame (cdr (assq 'frame result)))) + + ;; continue processing current frame? + (if (memq 'continue result) + (setq current-frame (cdr current-frame)) + (forward-line step) + (setq current-frame working-frame)) + + ;; abort current frame? + (if (memq 'abort result) + (progn + (setq donep t) + (throw 'regi-throw-top t))) + )) ; end-let ;; else if no match occurred, then process the next ;; frame-entry on the current line diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index 8de98b4cfb4..b29b870061d 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -1381,7 +1381,7 @@ To make local rx extensions, use `rx-let' for `rx', For more details, see Info node `(elisp) Extending Rx'. \(fn NAME [(ARGS...)] RX)" - (declare (indent 1)) + (declare (indent defun)) `(eval-and-compile (put ',name 'rx-definition ',(rx--make-binding name definition)) ',name)) @@ -1418,6 +1418,7 @@ into a plain rx-expression, collecting names into `rx--pcase-vars'." (cons head (mapcar #'rx--pcase-transform rest))) (_ rx))) +;;;###autoload (pcase-defmacro rx (&rest regexps) "A pattern that matches strings against `rx' REGEXPS in sexp form. REGEXPS are interpreted as in `rx'. The pattern matches any diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index ef2b1092c83..31c15fea90d 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -4,7 +4,7 @@ ;; Author: Nicolas Petton <nicolas@petton.fr> ;; Keywords: sequences -;; Version: 2.21 +;; Version: 2.22 ;; Package: seq ;; Maintainer: emacs-devel@gnu.org @@ -284,9 +284,6 @@ sorted. FUNCTION must be a function of one argument." (cl-defmethod seq-reverse ((sequence sequence)) (reverse sequence)) -;; We are autoloading seq-concatenate because cl-concatenate needs -;; that when it's inlined, per the cl-proclaim in cl-macs.el. -;;;###autoload (cl-defgeneric seq-concatenate (type &rest sequences) "Concatenate SEQUENCES into a single sequence of type TYPE. TYPE must be one of following symbols: vector, string or list. @@ -320,7 +317,7 @@ list." ;;;###autoload (cl-defgeneric seq-filter (pred sequence) - "Return a list of all the elements for which (PRED element) is non-nil in SEQUENCE." + "Return a list of all elements for which (PRED element) is non-nil in SEQUENCE." (let ((exclude (make-symbol "exclude"))) (delq exclude (seq-map (lambda (elt) (if (funcall pred elt) @@ -353,6 +350,7 @@ If SEQUENCE is empty, return INITIAL-VALUE and FUNCTION is not called." (setq acc (funcall function acc elt))) acc))) +;;;###autoload (cl-defgeneric seq-every-p (pred sequence) "Return non-nil if (PRED element) is non-nil for all elements of SEQUENCE." (catch 'seq--break @@ -413,7 +411,8 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil." nil)) (cl-defgeneric seq-set-equal-p (sequence1 sequence2 &optional testfn) - "Return non-nil if SEQUENCE1 and SEQUENCE2 contain the same elements, regardless of order. + "Return non-nil if SEQUENCE1 and SEQUENCE2 contain the same elements. +This does not depend on the order of the elements. Equality is defined by TESTFN if non-nil or by `equal' if nil." (and (seq-every-p (lambda (item1) (seq-contains-p sequence2 item1 testfn)) sequence1) (seq-every-p (lambda (item2) (seq-contains-p sequence1 item2 testfn)) sequence2))) @@ -446,7 +445,7 @@ The result is a sequence of type TYPE, or a list if TYPE is nil." (seq-map function sequence))) (cl-defgeneric seq-partition (sequence n) - "Return a list of the elements of SEQUENCE grouped into sub-sequences of length N. + "Return list of elements of SEQUENCE grouped into sub-sequences of length N. The last sequence may contain less than N elements. If N is a negative integer or 0, nil is returned." (unless (< n 1) @@ -476,6 +475,7 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil." (seq-reverse sequence1) '())) +;;;###autoload (cl-defgeneric seq-group-by (function sequence) "Apply FUNCTION to each element of SEQUENCE. Separate the elements of SEQUENCE into an alist using the results as @@ -496,6 +496,7 @@ keys. Keys are compared using `equal'." SEQUENCE must be a sequence of numbers or markers." (apply #'min (seq-into sequence 'list))) +;;;###autoload (cl-defgeneric seq-max (sequence) "Return the largest element of SEQUENCE. SEQUENCE must be a sequence of numbers or markers." diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index 6b6b8d966dd..c1d05941239 100644 --- a/lisp/emacs-lisp/shadow.el +++ b/lisp/emacs-lisp/shadow.el @@ -1,4 +1,4 @@ -;;; shadow.el --- locate Emacs Lisp file shadowings +;;; shadow.el --- locate Emacs Lisp file shadowings -*- lexical-binding: t; -*- ;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc. @@ -55,14 +55,10 @@ :prefix "load-path-shadows-" :group 'lisp) -(define-obsolete-variable-alias 'shadows-compare-text-p - 'load-path-shadows-compare-text "23.3") - (defcustom load-path-shadows-compare-text nil "If non-nil, then shadowing files are reported only if their text differs. This is slower, but filters out some innocuous shadowing." - :type 'boolean - :group 'lisp-shadow) + :type 'boolean) (defun load-path-shadows-find (&optional path) "Return a list of Emacs Lisp files that create shadows. @@ -81,8 +77,7 @@ See the documentation for `list-load-path-shadows' for further information." dir-case-insensitive ; `file-name-case-insensitive-p' of dir. curr-files ; This dir's Emacs Lisp files. orig-dir ; Where the file was first seen. - files-seen-this-dir ; Files seen so far in this dir. - file) ; The current file. + files-seen-this-dir) ; Files seen so far in this dir. (dolist (pp (or path load-path)) (setq dir (directory-file-name (file-truename (or pp ".")))) (if (member dir true-names) @@ -112,7 +107,7 @@ See the documentation for `list-load-path-shadows' for further information." (dolist (file curr-files) - (if (string-match "\\.gz$" file) + (if (string-match "\\.gz\\'" file) (setq file (substring file 0 -3))) (setq file (substring file 0 (if (string= (substring file -1) "c") -4 -3))) @@ -128,9 +123,13 @@ See the documentation for `list-load-path-shadows' for further information." ;; XXX.elc (or vice-versa) when they are in the same directory. (setq files-seen-this-dir (cons file files-seen-this-dir)) - (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))))) + (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))))) ;; 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))) @@ -145,7 +144,7 @@ See the documentation for `list-load-path-shadows' for further information." (append shadows (list base1 base2))))) ;; Not seen before, add it to the list of seen files. - (setq files (cons (cons file dir) files))))))) + (push (cons file dir) files)))))) ;; Return the list of shadowings. shadows)) @@ -180,13 +179,12 @@ See the documentation for `list-load-path-shadows' for further information." (define-derived-mode load-path-shadows-mode fundamental-mode "LP-Shadows" "Major mode for load-path shadows buffer." - (set (make-local-variable 'font-lock-defaults) - '((load-path-shadows-font-lock-keywords))) + (setq-local font-lock-defaults + '((load-path-shadows-font-lock-keywords))) (setq buffer-undo-list t buffer-read-only t)) ;; TODO use text-properties instead, a la dired. -(require 'button) (define-button-type 'load-path-shadows-find-file 'follow-link t ;; 'face 'default diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el new file mode 100644 index 00000000000..39e69f5aab9 --- /dev/null +++ b/lisp/emacs-lisp/shortdoc.el @@ -0,0 +1,1293 @@ +;;; shortdoc.el --- Short function summaries -*- lexical-binding: t -*- + +;; Copyright (C) 2020-2021 Free Software Foundation, Inc. + +;; Keywords: lisp, help +;; 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: + +;;; Code: + +(require 'seq) +(require 'text-property-search) +(eval-when-compile (require 'cl-lib)) + +(defgroup shortdoc nil + "Short documentation." + :group 'lisp) + +(defface shortdoc-separator + '((((class color) (background dark)) + :height 0.1 :background "#505050" :extend t) + (((class color) (background light)) + :height 0.1 :background "#a0a0a0" :extend t) + (t :height 0.1 :inverse-video t :extend t)) + "Face used to separate sections.") + +(defface shortdoc-section + '((t :inherit variable-pitch)) + "Face used for a section.") + +(defvar shortdoc--groups nil) + +(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: + + (fun + :no-manual BOOL + :args ARGS + :eval EXAMPLE-FORM + :no-eval EXAMPLE-FORM + :no-value EXAMPLE-FORM + :result RESULT-FORM + :eg-result RESULT-FORM + :eg-result-string RESULT-FORM) + +BOOL should be non-nil if the function isn't documented in the +manual. + +ARGS is optional; the function's signature is displayed if ARGS +is not present. + +If EVAL isn't a string, it will be printed with `prin1', and then +evaluated to give a result, which is also printed. If it's a +string, it'll be inserted as is, then the string will be `read', +and then evaluated. + +There can be any number of :example/:result elements." + `(progn + (setq shortdoc--groups (delq (assq ',group shortdoc--groups) + shortdoc--groups)) + (push (cons ',group ',functions) shortdoc--groups))) + +(define-short-documentation-group alist + "Alist Basics" + (assoc + :eval (assoc 'foo '((foo . bar) (zot . baz)))) + (rassoc + :eval (rassoc 'bar '((foo . bar) (zot . baz)))) + (assq + :eval (assq 'foo '((foo . bar) (zot . baz)))) + (rassq + :eval (rassq 'bar '((foo . bar) (zot . baz)))) + (assoc-string + :eval (assoc-string "foo" '(("foo" . "bar") ("zot" "baz")))) + "Manipulating Alists" + (assoc-delete-all + :eval (assoc-delete-all "foo" '(("foo" . "bar") ("zot" . "baz")) #'equal)) + (assq-delete-all + :eval (assq-delete-all 'foo '((foo . bar) (zot . baz)))) + (rassq-delete-all + :eval (rassq-delete-all 'bar '((foo . bar) (zot . baz)))) + (alist-get + :eval (let ((foo '((bar . baz)))) + (setf (alist-get 'bar foo) 'zot) + foo)) + "Misc" + (assoc-default + :eval (assoc-default "foobar" '(("foo" . baz)) #'string-match)) + (copy-alist + :eval (let* ((old '((foo . bar))) + (new (copy-alist old))) + (eq old new))) + ;; FIXME: Outputs "\.rose" for the symbol `.rose'. + ;; (let-alist + ;; :eval (let ((colors '((rose . red) + ;; (lily . white)))) + ;; (let-alist colors + ;; (if (eq .rose 'red) + ;; .lily)))) + ) + +(define-short-documentation-group string + "Making Strings" + (make-string + :args (length init) + :eval "(make-string 5 ?x)") + (string + :eval "(string ?a ?b ?c)") + (concat + :eval (concat "foo" "bar" "zot")) + (string-join + :no-manual t + :eval (string-join '("foo" "bar" "zot") " ")) + (mapconcat + :eval (mapconcat (lambda (a) (concat "[" a "]")) + '("foo" "bar" "zot") " ")) + (string-pad + :eval (string-pad "foo" 5) + :eval (string-pad "foobar" 5) + :eval (string-pad "foo" 5 ?- t)) + (mapcar + :eval (mapcar #'identity "123")) + (format + :eval (format "This number is %d" 4)) + "Manipulating Strings" + (substring + :eval (substring "foobar" 0 3) + :eval (substring "foobar" 3)) + (string-limit + :eval (string-limit "foobar" 3) + :eval (string-limit "foobar" 3 t) + :eval (string-limit "foobar" 10) + :eval (string-limit "fo好" 3 nil 'utf-8)) + (truncate-string-to-width + :eval (truncate-string-to-width "foobar" 3) + :eval (truncate-string-to-width "ä½ å¥½bar" 5)) + (split-string + :eval (split-string "foo bar") + :eval (split-string "|foo|bar|" "|") + :eval (split-string "|foo|bar|" "|" t)) + (string-lines + :eval (string-lines "foo\n\nbar") + :eval (string-lines "foo\n\nbar" t)) + (string-replace + :eval (string-replace "foo" "bar" "foozot")) + (replace-regexp-in-string + :eval (replace-regexp-in-string "[a-z]+" "_" "*foo*")) + (string-trim + :no-manual t + :args (string) + :doc "Trim STRING of leading and trailing white space." + :eval (string-trim " foo ")) + (string-trim-left + :no-manual t + :eval (string-trim-left "oofoo" "o+")) + (string-trim-right + :no-manual t + :eval (string-trim-right "barkss" "s+")) + (string-truncate-left + :no-manual t + :eval (string-truncate-left "longstring" 8)) + (string-remove-suffix + :no-manual t + :eval (string-remove-suffix "bar" "foobar")) + (string-remove-prefix + :no-manual t + :eval (string-remove-prefix "foo" "foobar")) + (string-chop-newline + :eval (string-chop-newline "foo\n")) + (string-clean-whitespace + :eval (string-clean-whitespace " foo bar ")) + (string-fill + :eval (string-fill "Three short words" 12) + :eval (string-fill "Long-word" 3)) + (reverse + :eval (reverse "foo")) + (substring-no-properties + :eval (substring-no-properties (propertize "foobar" 'face 'bold) 0 3)) + (try-completion + :eval (try-completion "foo" '("foobar" "foozot" "gazonk"))) + "Predicates for Strings" + (string-equal + :eval (string-equal "foo" "foo")) + (eq + :eval (eq "foo" "foo")) + (eql + :eval (eql "foo" "foo")) + (equal + :eval (equal "foo" "foo")) + (cl-equalp + :eval (cl-equalp "Foo" "foo")) + (stringp + :eval "(stringp ?a)") + (string-empty-p + :no-manual t + :eval (string-empty-p "")) + (string-blank-p + :no-manual t + :eval (string-blank-p " \n")) + (string-lessp + :eval (string-lessp "foo" "bar")) + (string-greaterp + :eval (string-greaterp "foo" "bar")) + (string-version-lessp + :eval (string-lessp "foo32.png" "bar4.png")) + (string-prefix-p + :eval (string-prefix-p "foo" "foobar")) + (string-suffix-p + :eval (string-suffix-p "bar" "foobar")) + "Case Manipulation" + (upcase + :eval (upcase "foo")) + (downcase + :eval (downcase "FOObar")) + (capitalize + :eval (capitalize "foo bar zot")) + (upcase-initials + :eval (upcase-initials "The CAT in the hAt")) + "Converting Strings" + (string-to-number + :eval (string-to-number "42") + :eval (string-to-number "deadbeef" 16)) + (number-to-string + :eval (number-to-string 42)) + "Data About Strings" + (length + :eval (length "foo")) + (string-search + :eval (string-search "bar" "foobarzot")) + (assoc-string + :eval (assoc-string "foo" '(("a" 1) (foo 2)))) + (seq-position + :eval "(seq-position \"foobarzot\" ?z)")) + +(define-short-documentation-group file-name + "File Name Manipulation" + (file-name-directory + :eval (file-name-directory "/tmp/foo") + :eval (file-name-directory "/tmp/foo/")) + (file-name-nondirectory + :eval (file-name-nondirectory "/tmp/foo") + :eval (file-name-nondirectory "/tmp/foo/")) + (file-name-sans-versions + :args (filename) + :eval (file-name-sans-versions "/tmp/foo~")) + (file-name-extension + :eval (file-name-extension "/tmp/foo.txt")) + (file-name-sans-extension + :eval (file-name-sans-extension "/tmp/foo.txt")) + (file-name-base + :eval (file-name-base "/tmp/foo.txt")) + (file-relative-name + :eval (file-relative-name "/tmp/foo" "/tmp")) + (make-temp-name + :eval (make-temp-name "/tmp/foo-")) + (expand-file-name + :eval (expand-file-name "foo" "/tmp/")) + (substitute-in-file-name + :eval (substitute-in-file-name "$HOME/foo")) + "Directory Functions" + (file-name-as-directory + :eval (file-name-as-directory "/tmp/foo")) + (directory-file-name + :eval (directory-file-name "/tmp/foo/")) + (abbreviate-file-name + :no-eval (abbreviate-file-name "/home/some-user") + :eg-result "~some-user") + "Quoted File Names" + (file-name-quote + :args (name) + :eval (file-name-quote "/tmp/foo")) + (file-name-unquote + :args (name) + :eval (file-name-unquote "/:/tmp/foo")) + "Predicates" + (file-name-absolute-p + :eval (file-name-absolute-p "/tmp/foo") + :eval (file-name-absolute-p "foo")) + (directory-name-p + :eval (directory-name-p "/tmp/foo/")) + (file-name-quoted-p + :eval (file-name-quoted-p "/:/tmp/foo"))) + +(define-short-documentation-group file + "Inserting Contents" + (insert-file-contents + :no-eval (insert-file-contents "/tmp/foo") + :eg-result ("/tmp/foo" 6)) + (insert-file-contents-literally + :no-eval (insert-file-contents-literally "/tmp/foo") + :eg-result ("/tmp/foo" 6)) + (find-file + :no-eval (find-file "/tmp/foo") + :eg-result-string "#<buffer foo>") + "Predicates" + (file-symlink-p + :no-eval (file-symlink-p "/tmp/foo") + :eg-result t) + (file-directory-p + :no-eval (file-directory-p "/tmp") + :eg-result t) + (file-regular-p + :no-eval (file-regular-p "/tmp/foo") + :eg-result t) + (file-exists-p + :no-eval (file-exists-p "/tmp/foo") + :eg-result t) + (file-readable-p + :no-eval (file-readable-p "/tmp/foo") + :eg-result t) + (file-writeable-p + :no-eval (file-writeable-p "/tmp/foo") + :eg-result t) + (file-accessible-directory-p + :no-eval (file-accessible-directory-p "/tmp") + :eg-result t) + (file-executable-p + :no-eval (file-executable-p "/bin/cat") + :eg-result t) + (file-newer-than-file-p + :no-eval (file-newer-than-file-p "/tmp/foo" "/tmp/bar") + :eg-result nil) + (file-equal-p + :no-eval (file-equal-p "/tmp/foo" "/tmp/bar") + :eg-result nil) + (file-in-directory-p + :no-eval (file-in-directory-p "/tmp/foo" "/tmp/") + :eg-result t) + (file-locked-p + :no-eval (file-locked-p "/tmp/foo") + :eg-result nil) + "Information" + (file-attributes + :no-eval* (file-attributes "/tmp")) + (file-truename + :no-eval (file-truename "/tmp/foo/bar") + :eg-result "/tmp/foo/zot") + (file-chase-links + :no-eval (file-chase-links "/tmp/foo/bar") + :eg-result "/tmp/foo/zot") + (vc-responsible-backend + :args (file &optional no-error) + :no-eval (vc-responsible-backend "/src/foo/bar.c") + :eg-result Git) + (file-acl + :no-eval (file-acl "/tmp/foo") + :eg-result "user::rw-\ngroup::r--\nother::r--\n") + (file-extended-attributes + :no-eval* (file-extended-attributes "/tmp/foo")) + (file-selinux-context + :no-eval* (file-selinux-context "/tmp/foo")) + (locate-file + :no-eval (locate-file "syslog" '("/var/log" "/usr/bin")) + :eg-result "/var/log/syslog") + (executable-find + :no-eval (executable-find "ls") + :eg-result "/usr/bin/ls") + "Creating" + (make-temp-file + :no-eval (make-temp-file "/tmp/foo-") + :eg-result "/tmp/foo-ZcXFMj") + (make-nearby-temp-file + :no-eval (make-nearby-temp-file "/tmp/foo-") + :eg-result "/tmp/foo-xe8iON") + (write-region + :no-value (write-region (point-min) (point-max) "/tmp/foo")) + "Directories" + (make-directory + :no-value (make-directory "/tmp/bar/zot/" t)) + (directory-files + :no-eval (directory-files "/tmp/") + :eg-result ("." ".." ".ICE-unix" ".Test-unix")) + (directory-files-recursively + :no-eval (directory-files-recursively "/tmp/" "\\.png\\'") + :eg-result ("/tmp/foo.png" "/tmp/zot.png" "/tmp/bar/foobar.png")) + (directory-files-and-attributes + :no-eval* (directory-files-and-attributes "/tmp/foo")) + (file-expand-wildcards + :no-eval (file-expand-wildcards "/tmp/*.png") + :eg-result ("/tmp/foo.png" "/tmp/zot.png")) + (locate-dominating-file + :no-eval (locate-dominating-file "foo.png" "/tmp/foo/bar/zot") + :eg-result "/tmp/foo.png") + (copy-directory + :no-value (copy-directory "/tmp/bar/" "/tmp/barcopy")) + (delete-directory + :no-value (delete-directory "/tmp/bar/")) + "File Operations" + (rename-file + :no-value (rename-file "/tmp/foo" "/tmp/newname")) + (copy-file + :no-value (copy-file "/tmp/foo" "/tmp/foocopy")) + (delete-file + :no-value (delete-file "/tmp/foo")) + (make-empty-file + :no-value (make-empty-file "/tmp/foo")) + (make-symbolic-link + :no-value (make-symbolic-link "/tmp/foo" "/tmp/foosymlink")) + (add-name-to-file + :no-value (add-name-to-file "/tmp/foo" "/tmp/bar")) + (set-file-modes + :no-value "(set-file-modes \"/tmp/foo\" #o644)") + (set-file-times + :no-value (set-file-times "/tmp/foo" (current-time))) + "File Modes" + (set-default-file-modes + :no-value "(set-default-file-modes #o755)") + (default-file-modes + :no-eval (default-file-modes) + :eg-result-string "#o755") + (file-modes-symbolic-to-number + :no-eval (file-modes-symbolic-to-number "a+r") + :eg-result-string "#o444") + (file-modes-number-to-symbolic + :eval "(file-modes-number-to-symbolic #o444)") + (set-file-extended-attributes + :no-eval (set-file-extended-attributes + "/tmp/foo" '((acl . "group::rxx"))) + :eg-result t) + (set-file-selinux-context + :no-eval (set-file-selinux-context + "/tmp/foo" '(unconfined_u object_r user_home_t s0)) + :eg-result t) + (set-file-acl + :no-eval (set-file-acl "/tmp/foo" "group::rxx") + :eg-result t)) + +(define-short-documentation-group hash-table + "Hash Table Basics" + (make-hash-table + :no-eval (make-hash-table) + :result-string "#s(hash-table ...)") + (puthash + :no-eval (puthash 'key "value" table)) + (gethash + :no-eval (gethash 'key table) + :eg-result "value") + (remhash + :no-eval (remhash 'key table) + :result nil) + (clrhash + :no-eval (clrhash table) + :result-string "#s(hash-table ...)") + (maphash + :no-eval (maphash (lambda (key value) (message value)) table) + :result nil) + "Other Hash Table Functions" + (hash-table-p + :eval (hash-table-p 123)) + (copy-hash-table + :no-eval (copy-hash-table table) + :result-string "#s(hash-table ...)") + (hash-table-count + :no-eval (hash-table-count table) + :eg-result 15) + (hash-table-size + :no-eval (hash-table-size table) + :eg-result 65)) + +(define-short-documentation-group list + "Making Lists" + (make-list + :eval (make-list 5 'a)) + (cons + :eval (cons 1 '(2 3 4))) + (list + :eval (list 1 2 3)) + (number-sequence + :eval (number-sequence 5 8)) + "Operations on Lists" + (append + :eval (append '("foo" "bar") '("zot"))) + (copy-tree + :eval (copy-tree '(1 (2 3) 4))) + (flatten-tree + :eval (flatten-tree '(1 (2 3) 4))) + (car + :eval (car '(one two three))) + (cdr + :eval (cdr '(one two three))) + (last + :eval (last '(one two three))) + (butlast + :eval (butlast '(one two three))) + (nbutlast + :eval (nbutlast (list 'one 'two 'three))) + (nth + :eval (nth 1 '(one two three))) + (nthcdr + :eval (nthcdr 1 '(one two three))) + (elt + :eval (elt '(one two three) 1)) + (car-safe + :eval (car-safe '(one two three))) + (cdr-safe + :eval (cdr-safe '(one two three))) + (push + :no-eval* (push 'a list)) + (pop + :no-eval* (pop list)) + (setcar + :no-eval (setcar list 'c) + :result c) + (setcdr + :no-eval (setcdr list (list c)) + :result '(c)) + (nconc + :eval (nconc (list 1) (list 2 3 4))) + (delq + :eval (delq 2 (list 1 2 3 4)) + :eval (delq "a" (list "a" "b" "c" "d"))) + (delete + :eval (delete 2 (list 1 2 3 4)) + :eval (delete "a" (list "a" "b" "c" "d"))) + (remove + :eval (remove 2 '(1 2 3 4)) + :eval (remove "a" '("a" "b" "c" "d"))) + (delete-dups + :eval (delete-dups (list 1 2 4 3 2 4))) + "Mapping Over Lists" + (mapcar + :eval (mapcar #'list '(1 2 3))) + (mapcan + :eval (mapcan #'list '(1 2 3))) + (mapc + :eval (mapc #'insert '("1" "2" "3"))) + (reduce + :eval (reduce #'+ '(1 2 3))) + (mapconcat + :eval (mapconcat #'identity '("foo" "bar") "|")) + "Predicates" + (listp + :eval (listp '(1 2 3)) + :eval (listp nil) + :eval (listp '(1 . 2))) + (consp + :eval (consp '(1 2 3)) + :eval (consp nil)) + (proper-list-p + :eval (proper-list-p '(1 2 3)) + :eval (proper-list-p nil) + :eval (proper-list-p '(1 . 2))) + (null + :eval (null nil)) + (atom + :eval (atom 'a)) + (nlistp + :eval (nlistp '(1 2 3)) + :eval (nlistp t) + :eval (nlistp '(1 . 2))) + "Finding Elements" + (memq + :eval (memq 2 '(1 2 3)) + :eval (memq 2.0 '(1.0 2.0 3.0)) + :eval (memq "b" '("a" "b" "c"))) + (member + :eval (member 2 '(1 2 3)) + :eval (member "b" '("a" "b" "c"))) + (remq + :eval (remq 2 '(1 2 3 2 4 2)) + :eval (remq "b" '("a" "b" "c"))) + (memql + :eval (memql 2.0 '(1.0 2.0 3.0))) + (member-ignore-case + :eval (member-ignore-case "foo" '("bar" "Foo" "zot"))) + "Association Lists" + (assoc + :eval (assoc 'b '((a 1) (b 2)))) + (rassoc + :eval (rassoc '2 '((a . 1) (b . 2)))) + (assq + :eval (assq 'b '((a 1) (b 2))) + :eval (assq "a" '(("a" 1) ("b" 2)))) + (rassq + :eval (rassq '2 '((a . 1) (b . 2)))) + (assoc-string + :eval (assoc-string "foo" '(("a" 1) (foo 2)))) + (alist-get + :eval (alist-get 2 '((1 . a) (2 . b)))) + (assoc-default + :eval (assoc-default 2 '((1 . a) (2 . b) #'=))) + (copy-alist + :eval (copy-alist '((1 . a) (2 . b)))) + (assq-delete-all + :eval (assq-delete-all 2 (list '(1 . a) '(2 . b) '(2 . c)))) + (assoc-delete-all + :eval (assoc-delete-all "b" (list '("a" . a) '("b" . b) '("b" . c)))) + "Property Lists" + (plist-get + :eval (plist-get '(a 1 b 2 c 3) 'b)) + (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 (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" + (length + :eval (length '(a b c))) + (length< + :eval (length< '(a b c) 1)) + (length> + :eval (length> '(a b c) 1)) + (length= + :eval (length> '(a b c) 3)) + (safe-length + :eval (safe-length '(a b c)))) + + +(define-short-documentation-group vector + (make-vector + :eval (make-vector 5 "foo")) + (vector + :eval (vector 1 "b" 3)) + (vectorp + :eval (vectorp [1]) + :eval (vectorp "1")) + (vconcat + :eval (vconcat '(1 2) [3 4])) + (append + :eval (append [1 2] nil)) + (length + :eval (length [1 2 3])) + (mapcar + :eval (mapcar #'identity [1 2 3])) + (reduce + :eval (reduce #'+ [1 2 3])) + (seq-subseq + :eval (seq-subseq [1 2 3 4 5] 1 3) + :eval (seq-subseq [1 2 3 4 5] 1))) + +(define-short-documentation-group regexp + "Matching Strings" + (replace-regexp-in-string + :eval (replace-regexp-in-string "[a-z]+" "_" "*foo*")) + (string-match-p + :eval (string-match-p "^[fo]+" "foobar")) + "Looking in Buffers" + (re-search-forward + :no-eval (re-search-forward "^foo$" nil t) + :eg-result 43) + (re-search-backward + :no-eval (re-search-backward "^foo$" nil t) + :eg-result 43) + (looking-at-p + :no-eval (looking-at "f[0-9]") + :eg-result t) + "Match Data" + (match-string + :eval (and (string-match "^\\([fo]+\\)b" "foobar") + (match-string 0 "foobar"))) + (match-beginning + :no-eval (match-beginning 1) + :eg-result 0) + (match-end + :no-eval (match-end 1) + :eg-result 3) + (save-match-data + :no-eval (save-match-data ...)) + "Replacing Match" + (replace-match + :no-eval (replace-match "new") + :eg-result nil) + (match-substitute-replacement + :no-eval (match-substitute-replacement "new") + :eg-result "new") + "Utilities" + (regexp-quote + :eval (regexp-quote "foo.*bar")) + (regexp-opt + :eval (regexp-opt '("foo" "bar"))) + (regexp-opt-depth + :eval (regexp-opt-depth "\\(a\\(b\\)\\)")) + (regexp-opt-charset + :eval (regexp-opt-charset '(?a ?b ?c ?d ?e))) + "The `rx' Structured Regexp Notation" + (rx + :eval (rx "IP=" (+ digit) (= 3 "." (+ digit)))) + (rx-to-string + :eval (rx-to-string '(| "foo" "bar"))) + (rx-define + :no-eval "(and (rx-define haskell-comment (seq \"--\" (zero-or-more nonl))) + (rx haskell-comment))" + :result "--.*") + (rx-let + :eval "(rx-let ((comma-separated (item) (seq item (0+ \",\" item))) + (number (1+ digit)) + (numbers (comma-separated number))) + (rx \"(\" numbers \")\"))" + :result "([[:digit:]]+\\(?:,[[:digit:]]+\\)*)") + (rx-let-eval + :eval "(rx-let-eval + '((ponder (x) (seq \"Where have all the \" x \" gone?\"))) + (rx-to-string + '(ponder (or \"flowers\" \"cars\" \"socks\"))))" + :result "\\(?:Where have all the \\(?:\\(?:car\\|flower\\|sock\\)s\\) gone\\?\\)")) + +(define-short-documentation-group sequence + "Sequence Predicates" + (seq-contains-p + :eval (seq-contains-p '(a b c) 'b) + :eval (seq-contains-p '(a b c) 'd)) + (seq-every-p + :eval (seq-every-p #'numberp '(1 2 3))) + (seq-empty-p + :eval (seq-empty-p [])) + (seq-set-equal-p + :eval (seq-set-equal-p '(1 2 3) '(3 1 2))) + (seq-some + :eval (seq-some #'cl-evenp '(1 2 3))) + "Building Sequences" + (seq-concatenate + :eval (seq-concatenate 'vector '(1 2) '(c d))) + (seq-copy + :eval (seq-copy '(a 2))) + (seq-into + :eval (seq-into '(1 2 3) 'vector)) + "Utility Functions" + (seq-count + :eval (seq-count #'numberp '(1 b c 4))) + (seq-elt + :eval (seq-elt '(a b c) 1)) + (seq-random-elt + :no-eval (seq-random-elt '(a b c)) + :eg-result c) + (seq-find + :eval (seq-find #'numberp '(a b 3 4 f 6))) + (seq-position + :eval (seq-position '(a b c) 'c)) + (seq-length + :eval (seq-length "abcde")) + (seq-max + :eval (seq-max [1 2 3])) + (seq-min + :eval (seq-min [1 2 3])) + (seq-first + :eval (seq-first [a b c])) + (seq-rest + :eval (seq-rest '[1 2 3])) + (seq-reverse + :eval (seq-reverse '(1 2 3))) + (seq-sort + :eval (seq-sort #'> '(1 2 3))) + (seq-sort-by + :eval (seq-sort-by (lambda (a) (/ 1.0 a)) #'< '(1 2 3))) + "Mapping Over Sequences" + (seq-map + :eval (seq-map #'1+ '(1 2 3))) + (seq-map-indexed + :eval (seq-map-indexed (lambda (a i) (cons i a)) '(a b c))) + (seq-mapcat + :eval (seq-mapcat #'upcase '("a" "b" "c") 'string)) + (seq-do + :no-eval (seq-do (lambda (a) (insert a)) '("foo" "bar")) + :eg-result ("foo" "bar")) + (seq-do-indexed + :no-eval (seq-do-indexed + (lambda (a index) (message "%s:%s" index a)) + '("foo" "bar")) + :eg-result nil) + (seq-reduce + :eval (seq-reduce #'* [1 2 3] 2)) + "Excerpting Sequences" + (seq-drop + :eval (seq-drop '(a b c) 2)) + (seq-drop-while + :eval (seq-drop-while #'numberp '(1 2 c d 5))) + (seq-filter + :eval (seq-filter #'numberp '(a b 3 4 f 6))) + (seq-remove + :eval (seq-remove #'numberp '(1 2 c d 5))) + (seq-group-by + :eval (seq-group-by #'cl-plusp '(-1 2 3 -4 -5 6))) + (seq-difference + :eval (seq-difference '(1 2 3) '(2 3 4))) + (seq-intersection + :eval (seq-intersection '(1 2 3) '(2 3 4))) + (seq-partition + :eval (seq-partition '(a b c d e f g h) 3)) + (seq-subseq + :eval (seq-subseq '(a b c d e) 2 4)) + (seq-take + :eval (seq-take '(a b c d e) 3)) + (seq-take-while + :eval (seq-take-while #'cl-evenp [2 4 9 6 5])) + (seq-uniq + :eval (seq-uniq '(a b d b a c)))) + +(define-short-documentation-group buffer + "Buffer Basics" + (current-buffer + :no-eval (current-buffer) + :eg-result-string "#<buffer shortdoc.el>") + (bufferp + :eval (bufferp 23)) + (buffer-live-p + :no-eval (buffer-live-p some-buffer) + :eg-result t) + (buffer-modified-p + :eval (buffer-modified-p (current-buffer))) + (buffer-name + :eval (buffer-name)) + (window-buffer + :eval (window-buffer)) + "Selecting Buffers" + (get-buffer-create + :no-eval (get-buffer-create "*foo*") + :eg-result-string "#<buffer *foo*>") + (pop-to-buffer + :no-eval (pop-to-buffer "*foo*") + :eg-result-string "#<buffer *foo*>") + (with-current-buffer + :no-eval* (with-current-buffer buffer (buffer-size))) + "Points and Positions" + (point + :eval (point)) + (point-min + :eval (point-max)) + (point-max + :eval (point-max)) + (line-beginning-position + :eval (line-beginning-position)) + (line-end-position + :eval (line-end-position)) + (buffer-size + :eval (buffer-size)) + "Moving Around" + (goto-char + :no-eval (goto-char (point-max)) + :eg-result 342) + (search-forward + :no-eval (search-forward "some-string" nil t) + :eg-result 245) + (re-search-forward + :no-eval (re-search-forward "some-s.*g" nil t) + :eg-result 245) + (forward-line + :no-eval (forward-line 1) + :eg-result 0 + :no-eval (forward-line -2) + :eg-result 0) + "Strings from Buffers" + (buffer-string + :no-eval* (buffer-string)) + (buffer-substring + :eval (buffer-substring (point-min) (+ (point-min) 10))) + (buffer-substring-no-properties + :eval (buffer-substring-no-properties (point-min) (+ (point-min) 10))) + (following-char + :no-eval (following-char) + :eg-result 67) + (char-after + :eval (char-after 45)) + "Altering Buffers" + (delete-region + :no-value (delete-region (point-min) (point-max))) + (erase-buffer + :no-value (erase-buffer)) + (insert + :no-value (insert "This string will be inserted in the buffer\n")) + "Locking" + (lock-buffer + :no-value (lock-buffer "/tmp/foo")) + (unlock-buffer + :no-value (lock-buffer))) + +(define-short-documentation-group process + (make-process + :no-eval (make-process :name "foo" :command '("cat" "/tmp/foo")) + :eg-result-string "#<process foo>") + (processp + :eval (processp t)) + (delete-process + :no-value (delete-process process)) + (kill-process + :no-value (kill-process process)) + (set-process-sentinel + :no-value (set-process-sentinel process (lambda (proc string)))) + (process-buffer + :no-eval (process-buffer process) + :eg-result-string "#<buffer *foo*>") + (get-buffer-process + :no-eval (get-buffer-process buffer) + :eg-result-string "#<process foo>") + (process-live-p + :no-eval (process-live-p process) + :eg-result t)) + +(define-short-documentation-group number + "Arithmetic" + (+ + :args (&rest numbers) + :eval (+ 1 2) + :eval (+ 1 2 3 4)) + (- + :args (&rest numbers) + :eval (- 3 2) + :eval (- 6 3 2)) + (* + :args (&rest numbers) + :eval (* 3 4 5)) + (/ + :eval (/ 10 5) + :eval (/ 10 6) + :eval (/ 10.0 6) + :eval (/ 10.0 3 3)) + (% + :eval (% 10 5) + :eval (% 10 6)) + (mod + :eval (mod 10 5) + :eval (mod 10 6) + :eval (mod 10.5 6)) + (1+ + :eval (1+ 2)) + (1- + :eval (1- 4)) + "Predicates" + (= + :args (number &rest numbers) + :eval (= 4 4) + :eval (= 4.0 4.0) + :eval (= 4 5 6 7)) + (eq + :eval (eq 4 4) + :eval (eq 4.0 4.0)) + (eql + :eval (eql 4 4) + :eval (eql 4 "4") + :eval (eql 4.0 4.0)) + (/= + :eval (/= 4 4)) + (< + :args (number &rest numbers) + :eval (< 4 4) + :eval (< 1 2 3)) + (<= + :args (number &rest numbers) + :eval (<= 4 4) + :eval (<= 1 2 3)) + (> + :args (number &rest numbers) + :eval (> 4 4) + :eval (> 1 2 3)) + (>= + :args (number &rest numbers) + :eval (>= 4 4) + :eval (>= 1 2 3)) + (zerop + :eval (zerop 0)) + (cl-plusp + :eval (cl-plusp 0) + :eval (cl-plusp 1)) + (cl-minusp + :eval (cl-minusp 0) + :eval (cl-minusp -1)) + (cl-oddp + :eval (cl-oddp 3)) + (cl-evenp + :eval (cl-evenp 6)) + (natnump + :eval (natnump -1) + :eval (natnump 23)) + (bignump + :eval (bignump 4) + :eval (bignump (expt 2 90))) + (fixnump + :eval (fixnump 4) + :eval (fixnump (expt 2 90))) + (floatp + :eval (floatp 5.4)) + (integerp + :eval (integerp 5.4)) + (numberp + :eval (numberp "5.4")) + (cl-digit-char-p + :eval (cl-digit-char-p ?5 10) + :eval (cl-digit-char-p ?f 16)) + "Operations" + (max + :args (number &rest numbers) + :eval (max 7 9 3)) + (min + :args (number &rest numbers) + :eval (min 7 9 3)) + (abs + :eval (abs -4)) + (float + :eval (float 2)) + (truncate + :eval (truncate 1.2) + :eval (truncate -1.2) + :eval (truncate 5.4 2)) + (floor + :eval (floor 1.2) + :eval (floor -1.2) + :eval (floor 5.4 2)) + (ceiling + :eval (ceiling 1.2) + :eval (ceiling -1.2) + :eval (ceiling 5.4 2)) + (round + :eval (round 1.2) + :eval (round -1.2) + :eval (round 5.4 2)) + (random + :eval (random 6)) + "Bit Operations" + (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") + (logior + :eval (logior 4 16)) + (logxor + :eval (logxor 4 16)) + (lognot + :eval (lognot 5)) + (logcount + :eval (logcount 5)) + "Floating Point" + (isnan + :eval (isnan 5.0)) + (frexp + :eval (frexp 5.7)) + (ldexp + :eval (ldexp 0.7125 3)) + (logb + :eval (logb 10.5)) + (ffloor + :eval (floor 1.2)) + (fceiling + :eval (fceiling 1.2)) + (ftruncate + :eval (ftruncate 1.2)) + (fround + :eval (fround 1.2)) + "Standard Math Functions" + (sin + :eval (sin float-pi)) + (cos + :eval (cos float-pi)) + (tan + :eval (tan float-pi)) + (asin + :eval (asin float-pi)) + (acos + :eval (acos float-pi)) + (atan + :eval (atan float-pi)) + (exp + :eval (exp 4)) + (log + :eval (log 54.59)) + (expt + :eval (expt 2 16)) + (sqrt + :eval (sqrt -1))) + +;;;###autoload +(defun shortdoc-display-group (group) + "Pop to a buffer with short documentation summary for functions in GROUP." + (interactive (list (completing-read "Show summary for functions in: " + (mapcar #'car shortdoc--groups)))) + (when (stringp group) + (setq group (intern group))) + (unless (assq group shortdoc--groups) + (error "No such documentation group %s" group)) + (pop-to-buffer (format "*Shortdoc %s*" group)) + (let ((inhibit-read-only t) + (prev nil)) + (erase-buffer) + (shortdoc-mode) + (button-mode) + (mapc + (lambda (data) + (cond + ((stringp data) + (setq prev nil) + (unless (bobp) + (insert "\n")) + (insert (propertize + (concat (substitute-command-keys data) "\n\n") + 'face '(variable-pitch (:height 1.3 :weight bold)) + 'shortdoc-section t))) + ;; There may be functions not yet defined in the data. + ((fboundp (car data)) + (when prev + (insert (propertize "\n" 'face 'shortdoc-separator))) + (setq prev t) + (shortdoc--display-function data)))) + (cdr (assq group shortdoc--groups)))) + (goto-char (point-min))) + +(defun shortdoc--display-function (data) + (let ((function (pop data)) + (start-section (point)) + arglist-start) + ;; Function calling convention. + (insert (propertize "(" + 'shortdoc-function t)) + (if (plist-get data :no-manual) + (insert-text-button + (symbol-name function) + 'face 'button + 'action (lambda (_) + (describe-function function)) + 'follow-link t + 'help-echo (purecopy "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"))) + (setq arglist-start (point)) + (insert ")\n") + ;; Doc string. + (insert " " + (or (plist-get data :doc) + (car (split-string (documentation function) "\n")))) + (insert "\n") + (add-face-text-property start-section (point) 'shortdoc-section t) + (let ((print-escape-newlines t) + (double-arrow (if (char-displayable-p ?⇒) + "⇒" + "=>")) + (single-arrow (if (char-displayable-p ?→) + "→" + "->"))) + (cl-loop for (type value) on data by #'cddr + do + (cl-case type + (:eval + (if (stringp value) + (insert " " value "\n") + (insert " ") + (prin1 value (current-buffer)) + (insert "\n") + (insert " " double-arrow " ") + (prin1 (eval value) (current-buffer)) + (insert "\n"))) + (:no-eval* + (if (stringp value) + (insert " " value "\n") + (insert " ") + (prin1 value (current-buffer))) + (insert "\n " single-arrow " " + (propertize "[it depends]" + 'face 'variable-pitch) + "\n")) + (:no-value + (if (stringp value) + (insert " " value) + (insert " ") + (prin1 value (current-buffer))) + (insert "\n")) + (:no-eval + (if (stringp value) + (insert " " value) + (insert " ") + (prin1 value (current-buffer))) + (insert "\n")) + (:result + (insert " " double-arrow " ") + (prin1 value (current-buffer)) + (insert "\n")) + (:result-string + (insert " " double-arrow " ") + (princ value (current-buffer)) + (insert "\n")) + (:eg-result + (insert " eg. " double-arrow " ") + (prin1 value (current-buffer)) + (insert "\n")) + (:eg-result-string + (insert " eg. " double-arrow " ") + (princ value (current-buffer)) + (insert "\n"))))) + ;; Insert the arglist after doing the evals, in case that's pulled + ;; in the function definition. + (save-excursion + (goto-char arglist-start) + (dolist (param (or (plist-get data :args) + (help-function-arglist function t))) + (insert " " (symbol-name param))) + (add-face-text-property arglist-start (point) 'shortdoc-section t)))) + +(defun shortdoc-function-groups (function) + "Return all shortdoc groups FUNCTION appears in." + (cl-loop for group in shortdoc--groups + when (assq function (cdr group)) + collect (car group))) + +(defun shortdoc-add-function (group section elem) + "Add ELEM to shortdoc GROUP in SECTION. +If GROUP doesn't exist, it will be created. +If SECTION doesn't exist, it will be added. + +Example: + + (shortdoc-add-function + 'file \"Predicates\" + '(file-locked-p :no-eval (file-locked-p \"/tmp\")))" + (let ((glist (assq group shortdoc--groups))) + (unless glist + (setq glist (list group)) + (setq shortdoc--groups (append shortdoc--groups (list glist)))) + (let ((slist (member section glist))) + (unless slist + (setq slist (list section)) + (setq slist (append glist slist))) + (while (and (cdr slist) + (not (stringp (cadr slist)))) + (setq slist (cdr slist))) + (setcdr slist (cons elem (cdr slist)))))) + +(defvar shortdoc-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "n") 'shortdoc-next) + (define-key map (kbd "p") 'shortdoc-previous) + (define-key map (kbd "C-c C-n") 'shortdoc-next-section) + (define-key map (kbd "C-c C-p") 'shortdoc-previous-section) + map) + "Keymap for `shortdoc-mode'") + +(define-derived-mode shortdoc-mode special-mode "shortdoc" + "Mode for shortdoc.") + +(defmacro shortdoc--goto-section (arg sym &optional reverse) + `(progn + (unless (natnump ,arg) + (setq ,arg 1)) + (while (< 0 ,arg) + (,(if reverse + 'text-property-search-backward + 'text-property-search-forward) + ,sym t) + (setq ,arg (1- ,arg))))) + +(defun shortdoc-next (&optional arg) + "Move cursor to next function." + (interactive "p") + (shortdoc--goto-section arg 'shortdoc-function)) + +(defun shortdoc-previous (&optional arg) + "Move cursor to previous function." + (interactive "p") + (shortdoc--goto-section arg 'shortdoc-function t) + (backward-char 1)) + +(defun shortdoc-next-section (&optional arg) + "Move cursor to next section." + (interactive "p") + (shortdoc--goto-section arg 'shortdoc-section)) + +(defun shortdoc-previous-section (&optional arg) + "Move cursor to previous section." + (interactive "p") + (shortdoc--goto-section arg 'shortdoc-section t) + (forward-line -2)) + +(provide 'shortdoc) + +;;; shortdoc.el ends here diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index 26aa9b91927..44be9afbfae 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -52,6 +52,13 @@ ;; error because the parser just automatically does something. Better yet, ;; we can afford to use a sloppy grammar. +;; The benefits of this approach were presented in the following article, +;; which includes a kind of tutorial to get started with SMIE: +;; +;; SMIE: Weakness is Power! Auto-indentation with incomplete information +;; Stefan Monnier, <Programming> Journal 2020, volumn 5, issue 1. +;; doi: 10.22152/programming-journal.org/2020/5/1 + ;; A good background to understand the development (especially the parts ;; building the 2D precedence tables and then computing the precedence levels ;; from it) can be found in pages 187-194 of "Parsing techniques" by Dick Grune @@ -63,6 +70,7 @@ ;; Since then, some of that code has been beaten into submission, but the ;; smie-indent-keyword is still pretty obscure. + ;; Conflict resolution: ;; ;; - One source of conflicts is when you have: @@ -1356,9 +1364,9 @@ Only meaningful when called from within `smie-rules-function'." (funcall smie-rules-function :elem 'basic)) smie-indent-basic)) -(defun smie-indent--rule (method token - ;; FIXME: Too many parameters. - &optional after parent base-pos) +(defun smie-indent--rule ( method token + ;; FIXME: Too many parameters. + &optional after parent base-pos) "Compute indentation column according to `smie-rules-function'. METHOD and TOKEN are passed to `smie-rules-function'. AFTER is the position after TOKEN, if known. @@ -1883,9 +1891,9 @@ KEYWORDS are additional arguments, which can use the following keywords: (v (pop keywords))) (pcase k (:forward-token - (set (make-local-variable 'smie-forward-token-function) v)) + (setq-local smie-forward-token-function v)) (:backward-token - (set (make-local-variable 'smie-backward-token-function) v)) + (setq-local smie-backward-token-function v)) (_ (message "smie-setup: ignoring unknown keyword %s" k))))) (let ((ca (cdr (assq :smie-closer-alist grammar)))) (when ca @@ -2112,10 +2120,9 @@ position corresponding to each rule." (throw 'found (list kind token (or (nth 3 rewrite) res))))))))) (default-new (smie-config--guess-value sig)) - (newstr (read-string (format "Adjust rule (%S %S -> %S) to%s: " - (nth 0 sig) (nth 1 sig) (nth 2 sig) - (if (not default-new) "" - (format " (default %S)" default-new))) + (newstr (read-string (format-prompt + "Adjust rule (%S %S -> %S) to" default-new + (nth 0 sig) (nth 1 sig) (nth 2 sig)) nil nil (format "%S" default-new))) (new (car (read-from-string newstr)))) (let ((old (rassoc sig smie-config--buffer-local))) diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index a53cec4d625..a4514454c0b 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -156,6 +156,7 @@ are non-nil, then the result is non-nil." ,@(or body `(,res)))) `(let* () ,@(or body '(t)))))) +;;;###autoload (defmacro if-let (spec then &rest else) "Bind variables according to SPEC and evaluate THEN or ELSE. Evaluate each binding in turn, as in `let*', stopping if a @@ -236,6 +237,15 @@ REGEXP defaults to \"[ \\t\\n\\r]+\"." TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"." (string-trim-left (string-trim-right string trim-right) trim-left)) +;;;###autoload +(defun string-truncate-left (string length) + "Truncate STRING to LENGTH, replacing initial surplus with \"...\"." + (let ((strlen (length string))) + (if (<= strlen length) + string + (setq length (max 0 (- length 3))) + (concat "..." (substring string (max 0 (- strlen 1 length))))))) + (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 @@ -254,6 +264,102 @@ carriage return." (substring string 0 (- (length string) (length suffix))) string)) +(defun string-clean-whitespace (string) + "Clean up whitespace in STRING. +All sequences of whitespaces in STRING are collapsed into a +single space character, and leading/trailing whitespace is +removed." + (let ((blank "[[:blank:]\r\n]+")) + (string-trim (replace-regexp-in-string blank " " string t t) + blank blank))) + +(defun string-fill (string length) + "Try to word-wrap STRING so that no lines are longer than LENGTH. +Wrapping is done where there is whitespace. If there are +individual words in STRING that are longer than LENGTH, the +result will have lines that are longer than LENGTH." + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (let ((fill-column length) + (adaptive-fill-mode nil)) + (fill-region (point-min) (point-max))) + (buffer-string))) + +(defun string-limit (string length &optional end coding-system) + "Return (up to) a LENGTH substring of STRING. +If STRING is shorter than or equal to LENGTH, the entire string +is returned unchanged. + +If STRING is longer than LENGTH, return a substring consisting of +the first LENGTH characters of STRING. If END is 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. + +When shortening strings for display purposes, +`truncate-string-to-width' is almost always a better alternative +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))) + (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)))) + (cond + ((<= (length string) length) string) + (end (substring string (- (length string) length))) + (t (substring string 0 length))))) + +(defun string-lines (string &optional omit-nulls) + "Split STRING into a list of lines. +If OMIT-NULLS, empty lines will be removed from the results." + (split-string string "\n" omit-nulls)) + +(defun string-pad (string length &optional padding start) + "Pad STRING to LENGTH using PADDING. +If PADDING is nil, the space character is used. If not nil, it +should be a character. + +If STRING is longer than the absolute value of LENGTH, no padding +is done. + +If START is nil (or not present), the padding is done to the end +of the string, and if non-nil, padding is done to the start of +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))))))) + +(defun string-chop-newline (string) + "Remove the final newline (if any) from STRING." + (string-remove-suffix "\n" string)) + (defun replace-region-contents (beg end replace-fn &optional max-secs max-costs) "Replace the region between BEG and END using REPLACE-FN. @@ -283,6 +389,28 @@ it makes no sense to convert it to a string using (set-buffer source-buffer) (replace-buffer-contents tmp-buffer max-secs max-costs))))))))) +(defmacro named-let (name bindings &rest body) + "Looping construct taken from Scheme. +Like `let', bind variables in BINDINGS and then evaluate BODY, +but with the twist that BODY can evaluate itself recursively by +calling NAME, where the arguments passed to NAME are used +as the new values of the bound variables in the recursive invocation." + (declare (indent 2) (debug (symbolp (&rest (symbolp form)) body))) + (require 'cl-lib) + (let ((fargs (mapcar (lambda (b) (if (consp b) (car b) b)) bindings)) + (aargs (mapcar (lambda (b) (if (consp b) (cadr b))) bindings))) + ;; According to the Scheme semantics of named let, `name' is not in scope + ;; while evaluating the expressions in `bindings', and for this reason, the + ;; "initial" function call below needs to be outside of the `cl-labels'. + ;; When the "self-tco" eliminates all recursive calls, the `cl-labels' + ;; expands to a lambda which the byte-compiler then combines with the + ;; funcall to make a `let' so we end up with a plain `while' loop and no + ;; remaining `lambda' at all. + `(funcall + (cl-labels ((,name ,fargs . ,body)) #',name) + . ,aargs))) + + (provide 'subr-x) ;;; subr-x.el ends here diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el index e0639118d80..bee2f9639e7 100644 --- a/lisp/emacs-lisp/syntax.el +++ b/lisp/emacs-lisp/syntax.el @@ -63,9 +63,10 @@ override the buffer's syntax table for special syntactic constructs that cannot be handled just by the buffer's syntax-table. The specified function may call `syntax-ppss' on any position -before END, but it should not call `syntax-ppss-flush-cache', -which means that it should not call `syntax-ppss' on some -position and later modify the buffer on some earlier position. +before END, but if it calls `syntax-ppss' on some +position and later modifies the buffer on some earlier position, +then it is its responsibility to call `syntax-ppss-flush-cache' to flush +the now obsolete ppss info from the cache. Note: When this variable is a function, it must apply _all_ the `syntax-table' properties needed in the given text interval. @@ -74,7 +75,7 @@ properties won't work properly.") (defvar syntax-propertize-chunk-size 500) -(defvar syntax-propertize-extend-region-functions +(defvar-local syntax-propertize-extend-region-functions '(syntax-propertize-wholelines) "Special hook run just before proceeding to propertize a region. This is used to allow major modes to help `syntax-propertize' find safe buffer @@ -88,7 +89,6 @@ These functions are run in turn repeatedly until they all return nil. Put first the functions more likely to cause a change and cheaper to compute.") ;; Mark it as a special hook which doesn't use any global setting ;; (i.e. doesn't obey the element t in the buffer-local value). -(make-variable-buffer-local 'syntax-propertize-extend-region-functions) (cl-defstruct (ppss (:constructor make-ppss) @@ -143,14 +143,28 @@ delimiter or an Escaped or Char-quoted character.")) (point-max)))) (cons beg end)) -(defun syntax-propertize--shift-groups (re n) - (replace-regexp-in-string - "\\\\(\\?\\([0-9]+\\):" - (lambda (s) - (replace-match - (number-to-string (+ n (string-to-number (match-string 1 s)))) - t t s 1)) - re t t)) +(defun syntax-propertize--shift-groups-and-backrefs (re n) + (let ((new-re (replace-regexp-in-string + "\\\\(\\?\\([0-9]+\\):" + (lambda (s) + (replace-match + (number-to-string + (+ n (string-to-number (match-string 1 s)))) + t t s 1)) + re t t)) + (pos 0)) + (while (string-match "\\\\\\([0-9]+\\)" new-re pos) + (setq pos (+ 1 (match-beginning 1))) + (when (save-match-data + ;; With \N, the \ must be in a subregexp context, i.e., + ;; not in a character class or in a \{\} repetition. + (subregexp-context-p new-re (match-beginning 0))) + (let ((shifted (+ n (string-to-number (match-string 1 new-re))))) + (when (> shifted 9) + (error "There may be at most nine back-references")) + (setq new-re (replace-match (number-to-string shifted) + t t new-re 1))))) + new-re)) (defmacro syntax-propertize-precompile-rules (&rest rules) "Return a precompiled form of RULES to pass to `syntax-propertize-rules'. @@ -194,7 +208,8 @@ for subsequent HIGHLIGHTs. Also SYNTAX is free to move point, in which case RULES may not be applied to some parts of the text or may be applied several times to other parts. -Note: back-references in REGEXPs do not work." +Note: There may be at most nine back-references in the REGEXPs of +all RULES in total." (declare (debug (&rest &or symbolp ;FIXME: edebug this eval step. (form &rest (numberp @@ -223,7 +238,7 @@ Note: back-references in REGEXPs do not work." ;; tell when *this* match 0 has succeeded. (cl-incf offset) (setq re (concat "\\(" re "\\)"))) - (setq re (syntax-propertize--shift-groups re offset)) + (setq re (syntax-propertize--shift-groups-and-backrefs re offset)) (let ((code '()) (condition (cond @@ -325,6 +340,11 @@ 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 (pos) "Ensure that syntax-table properties are set until POS (a buffer point)." (when (< syntax-propertize--done pos) @@ -332,7 +352,7 @@ END) suitable for `syntax-propertize-function'." (setq syntax-propertize--done (max (point-max) pos)) ;; (message "Needs to syntax-propertize from %s to %s" ;; syntax-propertize--done pos) - (set (make-local-variable 'parse-sexp-lookup-properties) t) + (setq-local parse-sexp-lookup-properties t) (when (< syntax-propertize--done (point-min)) ;; *Usually* syntax-propertize is called via syntax-ppss which ;; takes care of adding syntax-ppss-flush-cache to b-c-f, but this @@ -350,23 +370,27 @@ END) suitable for `syntax-propertize-function'." (end (max pos (min (point-max) (+ start syntax-propertize-chunk-size)))) - (funs syntax-propertize-extend-region-functions)) - (while funs - (let ((new (funcall (pop funs) start end)) - ;; Avoid recursion! - (syntax-propertize--done most-positive-fixnum)) - (if (or (null new) - (and (>= (car new) start) (<= (cdr new) end))) - nil - (setq start (car new)) - (setq end (cdr new)) - ;; If there's been a change, we should go through the - ;; list again since this new position may - ;; warrant a different answer from one of the funs we've - ;; already seen. - (unless (eq funs - (cdr syntax-propertize-extend-region-functions)) - (setq funs syntax-propertize-extend-region-functions))))) + (first t) + (repeat t)) + (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)) + (if (or (null new) + (and (>= (car new) start) (<= (cdr new) end))) + nil + (setq start (car new)) + (setq end (cdr new)) + ;; If there's been a change, we should go through the + ;; list again since this new position may + ;; warrant a different answer from one of the funs we've + ;; already seen. + (unless first (setq repeat t)))) + (setq first nil)))) ;; Flush ppss cache between the original value of `start' and that ;; set above by syntax-propertize-extend-region-functions. (syntax-ppss-flush-cache start) @@ -376,8 +400,13 @@ END) suitable for `syntax-propertize-function'." ;; (message "syntax-propertizing from %s to %s" start end) (remove-text-properties start end '(syntax-table nil syntax-multiline nil)) - ;; Avoid recursion! - (let ((syntax-propertize--done most-positive-fixnum)) + ;; 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))))))))) ;;; Link syntax-propertize with syntax.c. @@ -456,7 +485,8 @@ These are valid when the buffer has no restriction.") (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. - (setq syntax-propertize--done (min beg syntax-propertize--done)) + (unless syntax-propertize--inhibit-flush + (setq syntax-propertize--done (min beg syntax-propertize--done))) ;; Flush invalid cache entries. (dolist (cell (list syntax-ppss-wide syntax-ppss-narrow)) (pcase cell diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index e9bb8a8ac0d..0c299b48b90 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -269,42 +269,48 @@ Populated by `tabulated-list-init-header'.") ;; FIXME: Should share code with tabulated-list-print-col! (let ((x (max tabulated-list-padding 0)) (button-props `(help-echo "Click to sort by column" - mouse-face header-line-highlight - keymap ,tabulated-list-sort-button-map)) + mouse-face header-line-highlight + keymap ,tabulated-list-sort-button-map)) + (len (length tabulated-list-format)) (cols nil)) (if display-line-numbers (setq x (+ x (tabulated-list-line-number-width)))) (push (propertize " " 'display `(space :align-to ,x)) cols) - (dotimes (n (length tabulated-list-format)) + (dotimes (n len) (let* ((col (aref tabulated-list-format n)) + (not-last-col (< n (1- len))) (label (nth 0 col)) + (lablen (length label)) + (pname label) (width (nth 1 col)) (props (nthcdr 3 col)) (pad-right (or (plist-get props :pad-right) 1)) (right-align (plist-get props :right-align)) (next-x (+ x pad-right width))) + (when (and (>= lablen 3) (> lablen width) not-last-col) + (setq label (truncate-string-to-width label (- lablen 1) nil nil t))) (push (cond ;; An unsortable column ((not (nth 2 col)) - (propertize label 'tabulated-list-column-name label)) + (propertize label 'tabulated-list-column-name pname)) ;; The selected sort column ((equal (car col) (car tabulated-list-sort-key)) (apply 'propertize - (concat label - (cond - ((> (+ 2 (length label)) width) "") - ((cdr tabulated-list-sort-key) + (concat label + (cond + ((and (< lablen 3) not-last-col) "") + ((cdr tabulated-list-sort-key) (format " %c" tabulated-list-gui-sort-indicator-desc)) - (t (format " %c" + (t (format " %c" tabulated-list-gui-sort-indicator-asc)))) - 'face 'bold - 'tabulated-list-column-name label - button-props)) + 'face 'bold + 'tabulated-list-column-name pname + button-props)) ;; Unselected sortable column. (t (apply 'propertize label - 'tabulated-list-column-name label + 'tabulated-list-column-name pname button-props))) cols) (when right-align @@ -547,10 +553,10 @@ Return the column number after insertion." ;; Don't truncate to `width' if the next column is align-right ;; and has some space left, truncate to `available-space' instead. (when (and not-last-col - (> label-width available-space) - (setq label (truncate-string-to-width - label available-space nil nil t t) - label-width available-space))) + (> label-width available-space)) + (setq label (truncate-string-to-width + label available-space nil nil t t) + label-width available-space)) (setq label (bidi-string-mark-left-to-right label)) (when (and right-align (> width label-width)) (let ((shift (- width label-width))) @@ -761,6 +767,7 @@ as the ewoc pretty-printer." (setq-local revert-buffer-function #'tabulated-list-revert) (setq-local glyphless-char-display (tabulated-list-make-glyphless-char-display-table)) + (setq-local text-scale-remap-header-line t) ;; Avoid messing up the entries' display just because the first ;; column of the first entry happens to begin with a R2L letter. (setq bidi-paragraph-direction 'left-to-right) diff --git a/lisp/emacs-lisp/tcover-ses.el b/lisp/emacs-lisp/tcover-ses.el index 7de9d547ce4..fb9cd8f47df 100644 --- a/lisp/emacs-lisp/tcover-ses.el +++ b/lisp/emacs-lisp/tcover-ses.el @@ -1,4 +1,4 @@ -;;;; testcover-ses.el -- Example use of `testcover' to test "SES" +;;;; testcover-ses.el -- Example use of `testcover' to test "SES" -*- lexical-binding: t; -*- ;; Copyright (C) 2002-2021 Free Software Foundation, Inc. @@ -19,21 +19,14 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. -(require 'testcover) +;;; Commentary: -(defvar ses-initial-global-parameters) -(defvar ses-mode-map) +;; FIXME: Convert to ERT and move to `test/'? -(declare-function ses-set-curcell "ses") -(declare-function ses-update-cells "ses") -(declare-function ses-load "ses") -(declare-function ses-vector-delete "ses") -(declare-function ses-create-header-string "ses") -(declare-function ses-read-cell "ses") -(declare-function ses-read-symbol "ses") -(declare-function ses-command-hook "ses") -(declare-function ses-jump "ses") +;;; Code: +(require 'testcover) +(require 'ses) ;;;Here are some macros that exercise SES. Set `pause' to t if you want the ;;;macros to pause after each step. @@ -652,6 +645,7 @@ spreadsheet files with invalid formatting." (testcover-start "ses.el" t)) (require 'unsafep)) ;In case user has safe-functions = t! +(defvar ses--curcell-overlay) ;;;######################################################################### (defun ses-exercise () @@ -674,8 +668,8 @@ spreadsheet files with invalid formatting." (ses-load)) ;;ses-vector-delete is always called from buffer-undo-list with the same ;;symbol as argument. We'll give it a different one here. - (let ((x [1 2 3])) - (ses-vector-delete 'x 0 0)) + (dlet ((tcover-ses--x [1 2 3])) + (ses-vector-delete 'tcover-ses--x 0 0)) ;;ses-create-header-string behaves differently in a non-window environment ;;but we always test under windows. (let ((window-system (not window-system))) @@ -704,7 +698,7 @@ spreadsheet files with invalid formatting." (ses-mode))))) ;;Test error-handling in command hook, outside a macro. ;;This will ring the bell. - (let (curcell-overlay) + (let (ses--curcell-overlay) (ses-command-hook)) ;;Due to use of run-with-timer, ses-command-hook sometimes gets called ;;after we switch to another buffer. @@ -720,4 +714,4 @@ spreadsheet files with invalid formatting." ;;Could do this here: (testcover-end "ses.el") (message "Done")) -;; testcover-ses.el ends here. +;;; testcover-ses.el ends here. diff --git a/lisp/emacs-lisp/tcover-unsafep.el b/lisp/emacs-lisp/tcover-unsafep.el deleted file mode 100644 index 7a75755a529..00000000000 --- a/lisp/emacs-lisp/tcover-unsafep.el +++ /dev/null @@ -1,140 +0,0 @@ -;;;; testcover-unsafep.el -- Use testcover to test unsafep's code coverage - -;; Copyright (C) 2002-2021 Free Software Foundation, Inc. - -;; Author: Jonathan Yavner <jyavner@member.fsf.org> -;; Keywords: safety lisp utility -;; Package: testcover - -;; 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/>. - -(require 'testcover) - -(defvar safe-functions) - -;;;These forms are all considered safe -(defconst testcover-unsafep-safe - '(((lambda (x) (* x 2)) 14) - (apply 'cdr (mapcar (lambda (x) (car x)) y)) - (cond ((= x 4) 5) (t 27)) - (condition-case x (car y) (error (car x))) - (dolist (x y) (message "here: %s" x)) - (dotimes (x 14 (* x 2)) (message "here: %d" x)) - (let (x) (dolist (y '(1 2 3) (1+ y)) (push y x))) - (let (x) (apply (lambda (x) (* x 2)) 14)) - (let ((x '(2))) (push 1 x) (pop x) (add-to-list 'x 2)) - (let ((x 1) (y 2)) (setq x (+ x y))) - (let ((x 1)) (let ((y (+ x 3))) (* x y))) - (let* nil (current-time)) - (let* ((x 1) (y (+ x 3))) (* x y)) - (mapcar (lambda (x &optional y &rest z) (setq y (+ x 2)) (* y 3)) '(1 2 3)) - (mapconcat #'(lambda (var) (propertize var 'face 'bold)) '("1" "2") ", ") - (setq buffer-display-count 14 mark-active t) - ;;This is not safe if you insert it into a buffer! - (propertize "x" 'display '(height (progn (delete-file "x") 1)))) - "List of forms that `unsafep' should decide are safe.") - -;;;These forms are considered unsafe -(defconst testcover-unsafep-unsafe - '(( (add-to-list x y) - . (unquoted x)) - ( (add-to-list y x) - . (unquoted y)) - ( (add-to-list 'y x) - . (global-variable y)) - ( (not (delete-file "unsafep.el")) - . (function delete-file)) - ( (cond (t (aset local-abbrev-table 0 0))) - . (function aset)) - ( (cond (t (setq unsafep-vars ""))) - . (risky-local-variable unsafep-vars)) - ( (condition-case format-alist 1) - . (risky-local-variable format-alist)) - ( (condition-case x 1 (error (setq format-alist ""))) - . (risky-local-variable format-alist)) - ( (dolist (x (sort globalvar 'car)) (princ x)) - . (function sort)) - ( (dotimes (x 14) (delete-file "x")) - . (function delete-file)) - ( (let ((post-command-hook "/tmp/")) 1) - . (risky-local-variable post-command-hook)) - ( (let ((x (delete-file "x"))) 2) - . (function delete-file)) - ( (let (x) (add-to-list 'x (delete-file "x"))) - . (function delete-file)) - ( (let (x) (condition-case y (setq x 1 z 2))) - . (global-variable z)) - ( (let (x) (condition-case z 1 (error (delete-file "x")))) - . (function delete-file)) - ( (let (x) (mapc (lambda (x) (setcar x 1)) '((1 . 2) (3 . 4)))) - . (function setcar)) - ( (let (y) (push (delete-file "x") y)) - . (function delete-file)) - ( (let* ((x 1)) (setq y 14)) - . (global-variable y)) - ( (mapc 'car (list '(1 . 2) (cons 3 4) (kill-buffer "unsafep.el"))) - . (function kill-buffer)) - ( (mapcar x y) - . (unquoted x)) - ( (mapcar (lambda (x) (rename-file x "x")) '("unsafep.el")) - . (function rename-file)) - ( (mapconcat x1 x2 " ") - . (unquoted x1)) - ( (pop format-alist) - . (risky-local-variable format-alist)) - ( (push 1 format-alist) - . (risky-local-variable format-alist)) - ( (setq buffer-display-count (delete-file "x")) - . (function delete-file)) - ;;These are actually safe (they signal errors) - ( (apply '(x) '(1 2 3)) - . (function (x))) - ( (let (((x))) 1) - . (variable (x))) - ( (let (1) 2) - . (variable 1)) - ) - "A-list of (FORM . REASON)... that`unsafep' should decide are unsafe.") - -(declare-function unsafep-function "unsafep" (fun)) - -;;;######################################################################### -(defun testcover-unsafep () - "Executes all unsafep tests and displays the coverage results." - (interactive) - (testcover-unmark-all "unsafep.el") - (testcover-start "unsafep.el") - (let (save-functions) - (dolist (x testcover-unsafep-safe) - (if (unsafep x) - (error "%S should be safe" x))) - (dolist (x testcover-unsafep-unsafe) - (if (not (equal (unsafep (car x)) (cdr x))) - (error "%S should be unsafe: %s" (car x) (cdr x)))) - (setq safe-functions t) - (if (or (unsafep '(delete-file "x")) - (unsafep-function 'delete-file)) - (error "safe-functions=t should allow delete-file")) - (setq safe-functions '(setcar)) - (if (unsafep '(setcar x 1)) - (error "safe-functions=(setcar) should allow setcar")) - (if (not (unsafep '(setcdr x 1))) - (error "safe-functions=(setcar) should not allow setcdr"))) - (testcover-mark-all "unsafep.el") - (testcover-end "unsafep.el") - (message "Done")) - -;; testcover-unsafep.el ends here. diff --git a/lisp/emacs-lisp/text-property-search.el b/lisp/emacs-lisp/text-property-search.el index 6b315a11066..e909e4bf760 100644 --- a/lisp/emacs-lisp/text-property-search.el +++ b/lisp/emacs-lisp/text-property-search.el @@ -34,11 +34,11 @@ "Search for the next region of text whose PROPERTY matches VALUE. If not found, return nil and don't move point. -If found, move point to end of the region and return a `prop-match' -object describing the match. To access the details of the match, -use `prop-match-beginning' and `prop-match-end' for the buffer -positions that limit the region, and `prop-match-value' for the -value of PROPERTY in the region. +If found, move point to the start of the region and return a +`prop-match' object describing the match. To access the details +of the match, use `prop-match-beginning' and `prop-match-end' for +the buffer positions that limit the region, and +`prop-match-value' for the value of PROPERTY in the region. PREDICATE is used to decide whether a value of PROPERTY should be considered as matching VALUE. @@ -125,7 +125,7 @@ that matches VALUE." "Search for the previous region of text whose PROPERTY matches VALUE. Like `text-property-search-forward', which see, but searches backward, -and if a matching region is found, moves point to its beginning." +and if a matching region is found, place point at its end." (interactive (list (let ((string (completing-read "Search for property: " obarray))) @@ -137,11 +137,19 @@ and if a matching region is found, moves point to its beginning." nil) ;; We're standing in the property we're looking for, so find the ;; end. - ((and (text-property--match-p - value (get-text-property (1- (point)) property) - predicate) - (not not-current)) - (text-property--find-end-backward (1- (point)) property value predicate)) + ((text-property--match-p + value (get-text-property (1- (point)) property) + predicate) + (let ((origin (point)) + (match (text-property--find-end-backward + (1- (point)) property value predicate))) + ;; When we want to ignore the current element, then repeat the + ;; search if we haven't moved out of it yet. + (if (and not-current + (equal (get-text-property (point) property) + (get-text-property origin property))) + (text-property-search-backward property value predicate) + match))) (t (let ((origin (point)) (ended nil) diff --git a/lisp/emacs-lisp/thunk.el b/lisp/emacs-lisp/thunk.el index f8b56f12a2a..83e0fa75aa7 100644 --- a/lisp/emacs-lisp/thunk.el +++ b/lisp/emacs-lisp/thunk.el @@ -122,7 +122,7 @@ Using `thunk-let' and `thunk-let*' requires `lexical-binding'." (declare (indent 1) (debug let)) (cl-reduce (lambda (expr binding) `(thunk-let (,binding) ,expr)) - (nreverse bindings) + (reverse bindings) :initial-value (macroexp-progn body))) ;; (defalias 'lazy-let #'thunk-let) diff --git a/lisp/emacs-lisp/timer-list.el b/lisp/emacs-lisp/timer-list.el index 28fef48fe2e..d5bbe7d72cd 100644 --- a/lisp/emacs-lisp/timer-list.el +++ b/lisp/emacs-lisp/timer-list.el @@ -32,41 +32,51 @@ "List all timers in a buffer." (interactive) (pop-to-buffer-same-window (get-buffer-create "*timer-list*")) - (let ((inhibit-read-only t)) - (erase-buffer) - (timer-list-mode) - (dolist (timer (append timer-list timer-idle-list)) - (insert (format "%4s %10s %8s %s" - ;; Idle. - (if (aref timer 7) "*" " ") - ;; Next time. - (let ((time (list (aref timer 1) - (aref timer 2) - (aref timer 3)))) - (format "%.2f" - (float-time - (if (aref timer 7) - time - (time-subtract time nil))))) - ;; Repeat. - (let ((repeat (aref timer 4))) - (cond - ((numberp repeat) - (format "%.2f" (/ repeat 60))) - ((null repeat) - "-") - (t - (format "%s" repeat)))) - ;; Function. - (let ((cl-print-compiled 'static) - (cl-print-compiled-button nil) - (print-escape-newlines t)) - (cl-prin1-to-string (aref timer 5))))) - (put-text-property (line-beginning-position) - (1+ (line-beginning-position)) - 'timer timer) - (insert "\n"))) - (goto-char (point-min))) + (timer-list-mode) + (tabulated-list-init-header) + (setq tabulated-list-entries + (mapcar + (lambda (timer) + (list + nil + `[ ;; Idle. + ,(propertize + (if (aref timer 7) " *" " ") + 'help-echo "* marks idle timers" + 'timer timer) + ;; Next time. + ,(propertize + (let ((time (list (aref timer 1) + (aref timer 2) + (aref timer 3)))) + (format "%12s" + (format-seconds "%dd %hh %mm %z%,1ss" + (float-time + (if (aref timer 7) + time + (time-subtract time nil)))))) + 'help-echo "Time until next invocation") + ;; Repeat. + ,(let ((repeat (aref timer 4))) + (cond + ((numberp repeat) + (propertize + (format "%12s" (format-seconds + "%dd %hh %mm %z%,1ss" repeat)) + 'help-echo "Repeat interval")) + ((null repeat) + (propertize " -" 'help-echo "Runs once")) + (t + (format "%12s" repeat)))) + ;; Function. + ,(propertize + (let ((cl-print-compiled 'static) + (cl-print-compiled-button nil) + (print-escape-newlines t)) + (cl-prin1-to-string (aref timer 5))) + 'help-echo "Function called by timer")])) + (append timer-list timer-idle-list))) + (tabulated-list-print)) ;; This command can be destructive if they don't know what they are ;; doing. Kids, don't try this at home! ;;;###autoload (put 'list-timers 'disabled "Beware: manually canceling timers can ruin your Emacs session.") @@ -74,24 +84,47 @@ (defvar timer-list-mode-map (let ((map (make-sparse-keymap))) (define-key map "c" 'timer-list-cancel) - (define-key map "n" 'next-line) - (define-key map "p" 'previous-line) (easy-menu-define nil map "" '("Timers" ["Cancel" timer-list-cancel t])) map)) -(define-derived-mode timer-list-mode special-mode "Timer-List" +(define-derived-mode timer-list-mode tabulated-list-mode "Timer-List" "Mode for listing and controlling timers." - (setq bidi-paragraph-direction 'left-to-right) - (setq truncate-lines t) (buffer-disable-undo) (setq-local revert-buffer-function #'list-timers) - (setq buffer-read-only t) - (setq header-line-format - (concat (propertize " " 'display '(space :align-to 0)) - (format "%4s %10s %8s %s" - "Idle" "Next" "Repeat" "Function")))) + (setq tabulated-list-format + '[("Idle" 6 timer-list--idle-predicate) + ("Next" 12 timer-list--next-predicate :right-align t :pad-right 1) + ("Repeat" 12 timer-list--repeat-predicate :right-align t :pad-right 1) + ("Function" 10 timer-list--function-predicate)])) + +(defun timer-list--idle-predicate (A B) + "Predicate to sort Timer-List by the Idle column." + (let ((iA (aref (cadr A) 0)) + (iB (aref (cadr B) 0))) + (cond ((string= iA iB) + (timer-list--next-predicate A B)) + ((string= iA " *") nil) + (t t)))) + +(defun timer-list--next-predicate (A B) + "Predicate to sort Timer-List by the Next column." + (let ((nA (string-to-number (aref (cadr A) 1))) + (nB (string-to-number (aref (cadr B) 1)))) + (< nA nB))) + +(defun timer-list--repeat-predicate (A B) + "Predicate to sort Timer-List by the Repeat column." + (let ((rA (aref (cadr A) 2)) + (rB (aref (cadr B) 2))) + (string< rA rB))) + +(defun timer-list--function-predicate (A B) + "Predicate to sort Timer-List by the Function column." + (let ((fA (aref (cadr A) 3)) + (fB (aref (cadr B) 3))) + (string< fA fB))) (defun timer-list-cancel () "Cancel the timer on the line under point." diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index 5561c5fe834..36de29a73a8 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -378,9 +378,6 @@ This function returns a timer object which you can use in (decoded-time-year now) (decoded-time-zone now))))))) - (or (time-equal-p time time) - (error "Invalid time format")) - (let ((timer (timer-create))) (timer-set-time timer time repeat) (timer-set-function timer function args) diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el index 68759335df5..fa07d622484 100644 --- a/lisp/emacs-lisp/trace.el +++ b/lisp/emacs-lisp/trace.el @@ -225,7 +225,7 @@ be printed along with the arguments in the trace." (ctx (funcall context))) (unless inhibit-trace (with-current-buffer trace-buffer - (set (make-local-variable 'window-point-insertion-type) t) + (setq-local window-point-insertion-type t) (unless background (trace--display-buffer trace-buffer)) (goto-char (point-max)) ;; Insert a separator from previous trace output: @@ -265,20 +265,13 @@ be printed along with the arguments in the trace." If `current-prefix-arg' is non-nil, also read a buffer and a \"context\" \(Lisp expression). Return (FUNCTION BUFFER FUNCTION-CONTEXT)." (cons - (let ((default (function-called-at-point)) - (beg (string-match ":[ \t]*\\'" prompt))) - (intern (completing-read (if default - (format - "%s (default %s)%s" - (substring prompt 0 beg) - default - (if beg (substring prompt beg) ": ")) - prompt) + (let ((default (function-called-at-point))) + (intern (completing-read (format-prompt prompt default) obarray 'fboundp t nil nil (if default (symbol-name default))))) (when current-prefix-arg (list - (read-buffer "Output to buffer: " trace-buffer) + (read-buffer (format-prompt "Output to buffer" trace-buffer)) (let ((exp (let ((minibuffer-completing-symbol t)) (read-from-minibuffer "Context expression: " @@ -308,7 +301,7 @@ functions that switch buffers, or do any other display-oriented stuff - use `trace-function-background' instead. To stop tracing a function, use `untrace-function' or `untrace-all'." - (interactive (trace--read-args "Trace function: ")) + (interactive (trace--read-args "Trace function")) (trace-function-internal function buffer nil context)) ;;;###autoload @@ -316,7 +309,7 @@ To stop tracing a function, use `untrace-function' or `untrace-all'." "Trace calls to function FUNCTION, quietly. This is like `trace-function-foreground', but without popping up the output buffer or changing the window configuration." - (interactive (trace--read-args "Trace function in background: ")) + (interactive (trace--read-args "Trace function in background")) (trace-function-internal function buffer t context)) ;;;###autoload diff --git a/lisp/emacs-lisp/unsafep.el b/lisp/emacs-lisp/unsafep.el index 05013abb7dc..d52a6c796db 100644 --- a/lisp/emacs-lisp/unsafep.el +++ b/lisp/emacs-lisp/unsafep.el @@ -1,4 +1,4 @@ -;;;; unsafep.el -- Determine whether a Lisp form is safe to evaluate +;;;; unsafep.el -- Determine whether a Lisp form is safe to evaluate -*- lexical-binding: t; -*- ;; Copyright (C) 2002-2021 Free Software Foundation, Inc. @@ -91,29 +91,54 @@ in the parse.") (put 'unsafep-vars 'risky-local-variable t) -;;Other safe functions +;; Other safe forms. +;; +;; A function, macro or special form may be put here only if all of +;; the following statements are true: +;; +;; * It is not already marked `pure' or `side-effect-free', or handled +;; explicitly by `unsafep'. +;; +;; * It is not inherently unsafe; eg, would allow the execution of +;; arbitrary code, interact with the file system, network or other +;; processes, or otherwise exfiltrate information from the running +;; Emacs process or manipulate the user's environment. +;; +;; * It does not have side-effects that can make other code behave in +;; unsafe and/or unexpected ways; eg, set variables, mutate data, or +;; change control flow. +;; Any side effect must be innocuous; altering the match data is +;; explicitly permitted. +;; +;; * It does not allow Emacs to behave deceptively to the user; eg, +;; display arbitrary messages. +;; +;; * It does not present a potentially large attack surface; eg, +;; play arbitrary audio files. + (dolist (x '(;;Special forms - and catch if or prog1 prog2 progn while unwind-protect + and if or prog1 prog2 progn while unwind-protect ;;Safe subrs that have some side-effects - ding error random signal sleep-for string-match throw + ding random sleep-for string-match ;;Defsubst functions from subr.el caar cadr cdar cddr ;;Macros from subr.el save-match-data unless when ;;Functions from subr.el that have side effects - split-string replace-regexp-in-string play-sound-file)) + split-string)) (put x 'safe-function t)) ;;;###autoload -(defun unsafep (form &optional unsafep-vars) +(defun unsafep (form &optional vars) "Return nil if evaluating FORM couldn't possibly do any harm. Otherwise result is a reason why FORM is unsafe. -UNSAFEP-VARS is a list of symbols with local bindings." +VARS is a list of symbols with local bindings like `unsafep-vars'." (catch 'unsafep (if (or (eq safe-functions t) ;User turned off safety-checking (atom form)) ;Atoms are never unsafe (throw 'unsafep nil)) - (let* ((fun (car form)) + (let* ((unsafep-vars vars) + (fun (car form)) (reason (unsafep-function fun)) arg) (cond diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index bb707e52b6d..67de690e67d 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -1,4 +1,4 @@ -;;; warnings.el --- log and display warnings +;;; warnings.el --- log and display warnings -*- lexical-binding:t -*- ;; Copyright (C) 2002-2021 Free Software Foundation, Inc. @@ -67,26 +67,27 @@ Level :debug is ignored by default (see `warning-minimum-level').") Each element looks like (ALIAS . LEVEL) and defines ALIAS as equivalent to LEVEL. LEVEL must be defined in `warning-levels'; it may not itself be an alias.") +(make-obsolete-variable 'warning-level-aliases 'warning-levels "28.1") -(defvaralias 'display-warning-minimum-level 'warning-minimum-level) +(define-obsolete-variable-alias 'display-warning-minimum-level + 'warning-minimum-level "28.1") (defcustom warning-minimum-level :warning "Minimum severity level for displaying the warning buffer. If a warning's severity level is lower than this, the warning is logged in the warnings buffer, but the buffer is not immediately displayed. See also `warning-minimum-log-level'." - :group 'warnings :type '(choice (const :emergency) (const :error) (const :warning) (const :debug)) :version "22.1") -(defvaralias 'log-warning-minimum-level 'warning-minimum-log-level) +(define-obsolete-variable-alias 'log-warning-minimum-level + 'warning-minimum-log-level "28.1") (defcustom warning-minimum-log-level :warning "Minimum severity level for logging a warning. If a warning severity level is lower than this, the warning is completely ignored. Value must be lower or equal than `warning-minimum-level', because warnings not logged aren't displayed either." - :group 'warnings :type '(choice (const :emergency) (const :error) (const :warning) (const :debug)) :version "22.1") @@ -100,7 +101,6 @@ Thus, (foo bar) as an element matches (foo bar) or (foo bar ANYTHING...) as TYPE. If TYPE is a symbol FOO, that is equivalent to the list (FOO), so only the element (FOO) will match it." - :group 'warnings :type '(repeat (repeat symbol)) :version "22.1") @@ -115,7 +115,6 @@ or (foo bar ANYTHING...) as TYPE. If TYPE is a symbol FOO, that is equivalent to the list (FOO), so only the element (FOO) will match it. See also `warning-suppress-log-types'." - :group 'warnings :type '(repeat (repeat symbol)) :version "22.1") @@ -202,6 +201,21 @@ 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))) + ;;;###autoload (defun display-warning (type message &optional level buffer-name) "Display a warning message, MESSAGE. @@ -229,7 +243,12 @@ See the `warnings' custom group for user customization features. See also `warning-series', `warning-prefix-function', `warning-fill-prefix', and `warning-fill-column' for additional -programming features." +programming features. + +This will also display buttons allowing the user to permanently +disable automatic display of the warning or disable the warning +entirely by setting `warning-suppress-types' or +`warning-suppress-log-types' on their behalf." (if (not (or after-init-time noninteractive (daemonp))) ;; Ensure warnings that happen early in the startup sequence ;; are visible when startup completes (bug#20792). @@ -238,8 +257,10 @@ programming features." (setq level :warning)) (unless buffer-name (setq buffer-name "*Warnings*")) - (if (assq level warning-level-aliases) - (setq level (cdr (assq level warning-level-aliases)))) + (with-suppressed-warnings ((obsolete warning-level-aliases)) + (when-let ((new (cdr (assq level warning-level-aliases)))) + (warn "Warning level `%s' is obsolete; use `%s' instead" level new) + (setq level new))) (or (< (warning-numeric-level level) (warning-numeric-level warning-minimum-log-level)) (warning-suppress-p type warning-suppress-log-types) @@ -274,6 +295,17 @@ programming features." (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-match "\n" message))) (let ((fill-prefix warning-fill-prefix) |