diff options
Diffstat (limited to 'lisp/emacs-lisp')
84 files changed, 9651 insertions, 5218 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..ae17039645a 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. @@ -141,9 +141,12 @@ expression, in which case we want to handle forms differently." ((stringp (car-safe rest)) (car rest)))) ;; Look for an interactive spec. (interactive (pcase body - ((or `((interactive . ,_) . ,_) - `(,_ (interactive . ,_) . ,_)) - t)))) + ((or `((interactive . ,iargs) . ,_) + `(,_ (interactive . ,iargs) . ,_)) + ;; List of modes or just t. + (if (nthcdr 1 iargs) + (list 'quote (nthcdr 1 iargs)) + t))))) ;; Add the usage form at the end where describe-function-1 ;; can recover it. (when (consp args) (setq doc (help-add-fundoc-usage doc args))) @@ -207,7 +210,11 @@ expression, in which case we want to handle forms differently." easy-mmode-define-minor-mode define-minor-mode)) t) - (eq (car-safe (car body)) 'interactive)) + (and (eq (car-safe (car body)) 'interactive) + ;; List of modes or just t. + (or (if (nthcdr 1 (car body)) + (list 'quote (nthcdr 1 (car body))) + t)))) ,(if macrop ''macro nil)))) ;; For defclass forms, use `eieio-defclass-autoload'. @@ -220,16 +227,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 +272,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 +285,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 +386,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 +474,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 +509,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 +625,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 +636,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 +693,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 +730,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 +756,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 +775,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 +807,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 +819,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 +912,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 +942,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 +968,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 +1054,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 +1089,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 +1100,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 +1160,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 +1202,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 +1238,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/backtrace.el b/lisp/emacs-lisp/backtrace.el index 3e1c3292650..ea70baa9532 100644 --- a/lisp/emacs-lisp/backtrace.el +++ b/lisp/emacs-lisp/backtrace.el @@ -190,7 +190,7 @@ This is commonly used to recompute `backtrace-frames'.") (defvar-local backtrace-print-function #'cl-prin1 "Function used to print values in the current Backtrace buffer.") -(defvar-local backtrace-goto-source-functions nil +(defvar backtrace-goto-source-functions nil "Abnormal hook used to jump to the source code for the current frame. Each hook function is called with no argument, and should return non-nil if it is able to switch to the buffer containing the @@ -638,10 +638,8 @@ content of the sexp." (source-available (plist-get (backtrace-frame-flags frame) :source-available))) (unless (and source-available - (catch 'done - (dolist (func backtrace-goto-source-functions) - (when (funcall func) - (throw 'done t))))) + (run-hook-with-args-until-success + 'backtrace-goto-source-functions)) (user-error "Source code location not known")))) (defun backtrace-help-follow-symbol (&optional pos) diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el index 701e6c513f3..439d3bd363e 100644 --- a/lisp/emacs-lisp/benchmark.el +++ b/lisp/emacs-lisp/benchmark.el @@ -31,6 +31,8 @@ ;;; Code: +(eval-when-compile (require 'subr-x)) ;For `named-let'. + (defmacro benchmark-elapse (&rest forms) "Return the time in seconds elapsed for execution of FORMS." (declare (indent 0) (debug t)) @@ -41,6 +43,61 @@ (float-time (time-since ,t1))))) ;;;###autoload +(defun benchmark-call (func &optional repetitions) + "Measure the run time of calling FUNC a number REPETITIONS of times. +The result is a list (TIME GC GCTIME) +where TIME is the total time it took, in seconds. +GCTIME is the amount of time that was spent in the GC +and GC is the number of times the GC was called. + +REPETITIONS can also be a floating point number, in which case it +specifies a minimum number of seconds that the benchmark execution +should take. In that case the return value is prepended with the +number of repetitions actually used." + (if (floatp repetitions) + (benchmark--adaptive func repetitions) + (unless repetitions (setq repetitions 1)) + (let ((gc gc-elapsed) + (gcs gcs-done) + (empty-func (lambda () 'empty-func))) + (list + (if (> repetitions 1) + (- (benchmark-elapse (dotimes (_ repetitions) (funcall func))) + (benchmark-elapse (dotimes (_ repetitions) (funcall empty-func)))) + (- (benchmark-elapse (funcall func)) + (benchmark-elapse (funcall empty-func)))) + (- gcs-done gcs) + (- gc-elapsed gc))))) + +(defun benchmark--adaptive (func time) + "Measure the run time of FUNC, calling it enough times to last TIME seconds. +Result is (REPETITIONS . DATA) where DATA is as returned by `branchmark-call'." + (named-let loop ((repetitions 1) + (data (let ((x (list 0))) (setcdr x x) x))) + ;; (message "Running %d iteration" repetitions) + (let ((newdata (benchmark-call func repetitions))) + (if (<= (car newdata) 0) + ;; This can happen if we're unlucky, e.g. the process got preempted + ;; (or the GC ran) just during the empty-func loop. + ;; Just try again, hopefully this won't repeat itself. + (progn + ;; (message "Ignoring the %d iterations" repetitions) + (loop (* 2 repetitions) data)) + (let* ((sum (cl-mapcar #'+ data (cons repetitions newdata))) + (totaltime (nth 1 sum))) + (if (>= totaltime time) + sum + (let* ((iter-time (/ totaltime (car sum))) + (missing-time (- time totaltime)) + (missing-iter (/ missing-time iter-time))) + ;; `iter-time' is approximate because of effects like the GC, + ;; so multiply at most by 10, in case we are wildly off the mark. + (loop (max repetitions + (min (ceiling missing-iter) + (* 10 repetitions))) + sum)))))))) + +;;;###autoload (defmacro benchmark-run (&optional repetitions &rest forms) "Time execution of FORMS. If REPETITIONS is supplied as a number, run FORMS that many times, @@ -53,19 +110,7 @@ See also `benchmark-run-compiled'." (unless (or (natnump repetitions) (and repetitions (symbolp repetitions))) (setq forms (cons repetitions forms) repetitions 1)) - (let ((i (make-symbol "i")) - (gcs (make-symbol "gcs")) - (gc (make-symbol "gc"))) - `(let ((,gc gc-elapsed) - (,gcs gcs-done)) - (list ,(if (or (symbolp repetitions) (> repetitions 1)) - ;; Take account of the loop overhead. - `(- (benchmark-elapse (dotimes (,i ,repetitions) - ,@forms)) - (benchmark-elapse (dotimes (,i ,repetitions)))) - `(benchmark-elapse ,@forms)) - (- gcs-done ,gcs) - (- gc-elapsed ,gc))))) + `(benchmark-call (lambda () ,@forms) ,repetitions)) ;;;###autoload (defmacro benchmark-run-compiled (&optional repetitions &rest forms) @@ -77,21 +122,7 @@ result. The overhead of the `lambda's is accounted for." (unless (or (natnump repetitions) (and repetitions (symbolp repetitions))) (setq forms (cons repetitions forms) repetitions 1)) - (let ((i (make-symbol "i")) - (gcs (make-symbol "gcs")) - (gc (make-symbol "gc")) - (code (byte-compile `(lambda () ,@forms))) - (lambda-code (byte-compile '(lambda ())))) - `(let ((,gc gc-elapsed) - (,gcs gcs-done)) - (list ,(if (or (symbolp repetitions) (> repetitions 1)) - ;; Take account of the loop overhead. - `(- (benchmark-elapse (dotimes (,i ,repetitions) - (funcall ,code))) - (benchmark-elapse (dotimes (,i ,repetitions) - (funcall ,lambda-code)))) - `(benchmark-elapse (funcall ,code))) - (- gcs-done ,gcs) (- gc-elapsed ,gc))))) + `(benchmark-call (byte-compile '(lambda () ,@forms)) ,repetitions)) ;;;###autoload (defun benchmark (repetitions form) @@ -99,9 +130,15 @@ result. The overhead of the `lambda's is accounted for." Interactively, REPETITIONS is taken from the prefix arg, and the command prompts for the form to benchmark. For non-interactive use see also `benchmark-run' and -`benchmark-run-compiled'." +`benchmark-run-compiled'. +FORM can also be a function in which case we measure the time it takes +to call it without any argument." (interactive "p\nxForm: ") - (let ((result (eval `(benchmark-run ,repetitions ,form) t))) + (let ((result (benchmark-call (eval (pcase form + ((or `#',_ `(lambda . ,_)) form) + (_ `(lambda () ,form))) + t) + repetitions))) (if (zerop (nth 1 result)) (message "Elapsed time: %fs" (car result)) (message "Elapsed time: %fs (%fs in %d GCs)" (car result) diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 8d384e2c240..247fb91379e 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. @@ -26,7 +26,7 @@ ;; Packing and unpacking of (binary) data structures. ;; ;; The data formats used in binary files and network protocols are -;; often structed data which can be described by a C-style structure +;; often structured data which can be described by a C-style structure ;; such as the one shown below. Using the bindat package, decoding ;; and encoding binary data formats like these is made simple using a ;; structure specification which closely resembles the C style @@ -41,57 +41,61 @@ ;; Consider the following C structures: ;; ;; struct header { -;; unsigned long dest_ip; -;; unsigned long src_ip; -;; unsigned short dest_port; -;; unsigned short src_port; +;; uint32_t dest_ip; +;; uint32_t src_ip; +;; uint16_t dest_port; +;; uint16_t src_port; ;; }; ;; ;; struct data { -;; unsigned char type; -;; unsigned char opcode; -;; unsigned long length; /* In little endian order */ +;; uint8_t type; +;; uint8_t opcode; +;; uint32_t length; /* In little endian order */ ;; unsigned char id[8]; /* nul-terminated string */ ;; unsigned char data[/* (length + 3) & ~3 */]; ;; }; ;; ;; struct packet { ;; struct header header; -;; unsigned char items; +;; uint8_t items; ;; unsigned char filler[3]; ;; struct data item[/* items */]; ;; }; ;; -;; The corresponding Lisp bindat specification looks like this: +;; The corresponding Lisp bindat specification could look like this: +;; +;; (bindat-defmacro ip () '(vec 4 byte)) ;; ;; (setq header-bindat-spec -;; '((dest-ip ip) +;; (bindat-type +;; (dest-ip ip) ;; (src-ip ip) -;; (dest-port u16) -;; (src-port u16))) +;; (dest-port uint 16) +;; (src-port uint 16))) ;; ;; (setq data-bindat-spec -;; '((type u8) +;; (bindat-type +;; (type u8) ;; (opcode u8) -;; (length u16r) ;; little endian order +;; (length uintr 32) ;; little endian order ;; (id strz 8) -;; (data vec (length)) -;; (align 4))) +;; (data vec length) +;; (_ align 4))) ;; ;; (setq packet-bindat-spec -;; '((header struct header-bindat-spec) -;; (items u8) -;; (fill 3) -;; (item repeat (items) -;; (struct data-bindat-spec)))) -;; +;; (bindat-type +;; (header type header-bindat-spec) +;; (nitems u8) +;; (_ fill 3) +;; (items repeat nitems type data-bindat-spec))) ;; ;; A binary data representation may look like ;; [ 192 168 1 100 192 168 1 101 01 28 21 32 2 0 0 0 ;; 2 3 5 0 ?A ?B ?C ?D ?E ?F 0 0 1 2 3 4 5 0 0 0 ;; 1 4 7 0 ?B ?C ?D ?E ?F ?G 0 0 6 7 8 9 10 11 12 0 ] ;; -;; The corresponding decoded structure looks like +;; The corresponding decoded structure returned by `bindat-unpack' (or taken +;; by `bindat-pack') looks like: ;; ;; ((header ;; (dest-ip . [192 168 1 100]) @@ -111,97 +115,30 @@ ;; (type . 1)))) ;; ;; To access a specific value in this structure, use the function -;; bindat-get-field with the structure as first arg followed by a list +;; `bindat-get-field' with the structure as first arg followed by a list ;; of field names and array indexes, e.g. using the data above, ;; (bindat-get-field decoded-structure 'item 1 'id) ;; returns "BCDEFG". -;; Binary Data Structure Specification Format -;; ------------------------------------------ - -;; We recommend using names that end in `-bindat-spec'; such names -;; are recognized automatically as "risky" variables. - -;; The data specification is formatted as follows: - -;; SPEC ::= ( ITEM... ) - -;; ITEM ::= ( [FIELD] TYPE ) -;; | ( [FIELD] eval FORM ) -- eval FORM for side-effect only -;; | ( [FIELD] fill LEN ) -- skip LEN bytes -;; | ( [FIELD] align LEN ) -- skip to next multiple of LEN bytes -;; | ( [FIELD] struct SPEC_NAME ) -;; | ( [FIELD] union TAG_VAL (TAG SPEC)... [(t SPEC)] ) -;; | ( [FIELD] repeat COUNT ITEM... ) - -;; -- In (eval EXPR), the value of the last field is available in -;; the dynamically bound variable `last'. - -;; TYPE ::= ( eval EXPR ) -- interpret result as TYPE -;; | u8 | byte -- length 1 -;; | u16 | word | short -- length 2, network byte order -;; | u24 -- 3-byte value -;; | u32 | dword | long -- length 4, network byte order -;; | u16r | u24r | u32r -- little endian byte order. -;; | str LEN -- LEN byte string -;; | strz LEN -- LEN byte (zero-terminated) string -;; | vec LEN [TYPE] -- vector of LEN items of TYPE (default: u8) -;; | 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). - -;; FIELD ::= ( eval EXPR ) -- use result as NAME -;; | NAME - -;; LEN ::= ARG -;; | <omitted> | nil -- LEN = 1 - - -;; TAG_VAL ::= ARG - -;; TAG ::= LISP_CONSTANT -;; | ( eval EXPR ) -- return non-nil if tag match; -;; current TAG_VAL in `tag'. - -;; ARG ::= ( eval EXPR ) -- interpret result as ARG -;; | INTEGER_CONSTANT -;; | DEREF - -;; DEREF ::= ( [NAME | INTEGER]... ) -- Field NAME or Array index relative -;; to current structure spec. -;; -- see bindat-get-field - -;; A `union' specification -;; ([FIELD] union TAG_VAL (TAG SPEC) ... [(t SPEC)]) -;; is interpreted by evalling TAG_VAL and then comparing that to -;; each TAG using equal; if a match is found, the corresponding SPEC -;; is used. -;; If TAG is a form (eval EXPR), EXPR is evalled with `tag' bound to the -;; value of TAG_VAL; the corresponding SPEC is used if the result is non-nil. -;; Finally, if TAG is t, the corresponding SPEC is used unconditionally. -;; -;; An `eval' specification -;; ([FIELD] eval FORM) -;; is interpreted by evalling FORM for its side effects only. -;; If FIELD is specified, the value is bound to that field. -;; The FORM may access and update `bindat-raw' and `bindat-idx' (see `bindat-unpack'). - ;;; Code: ;; Helper functions for structure unpacking. -;; Relies on dynamic binding of BINDAT-RAW and BINDAT-IDX +;; Relies on dynamic binding of `bindat-raw' and `bindat-idx'. + +(eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'subr-x)) ;For `named-let'. + +(cl-defstruct (bindat--type + (:predicate nil) + (:constructor bindat--make)) + le ue pe) (defvar bindat-raw) (defvar bindat-idx) -(defun bindat--unpack-u8 () +(defsubst bindat--unpack-u8 () (prog1 - (aref bindat-raw bindat-idx) + (aref bindat-raw bindat-idx) (setq bindat-idx (1+ bindat-idx)))) (defun bindat--unpack-u16 () @@ -222,133 +159,140 @@ (defun bindat--unpack-u32r () (logior (bindat--unpack-u16r) (ash (bindat--unpack-u16r) 16))) +(defun bindat--unpack-str (len) + (let ((s (substring bindat-raw bindat-idx (+ bindat-idx len)))) + (setq bindat-idx (+ bindat-idx len)) + (if (stringp s) s + (apply #'unibyte-string s)))) + +(defun bindat--unpack-strz (len) + (let ((i 0) s) + (while (and (if len (< i len) t) (/= (aref bindat-raw (+ bindat-idx i)) 0)) + (setq i (1+ i))) + (setq s (substring bindat-raw bindat-idx (+ bindat-idx i))) + (setq bindat-idx (+ bindat-idx len)) + (if (stringp s) s + (apply #'unibyte-string s)))) + +(defun bindat--unpack-bits (len) + (let ((bits nil) (bnum (1- (* 8 len))) j m) + (while (>= bnum 0) + (if (= (setq m (bindat--unpack-u8)) 0) + (setq bnum (- bnum 8)) + (setq j 128) + (while (> j 0) + (if (/= 0 (logand m j)) + (setq bits (cons bnum bits))) + (setq bnum (1- bnum) + j (ash j -1))))) + bits)) + (defun bindat--unpack-item (type len &optional vectype) (if (eq type 'ip) (setq type 'vec len 4)) - (cond - ((memq type '(u8 byte)) - (bindat--unpack-u8)) - ((memq type '(u16 word short)) - (bindat--unpack-u16)) - ((eq type 'u24) - (bindat--unpack-u24)) - ((memq type '(u32 dword long)) - (bindat--unpack-u32)) - ((eq type 'u16r) - (bindat--unpack-u16r)) - ((eq type 'u24r) - (bindat--unpack-u24r)) - ((eq type 'u32r) - (bindat--unpack-u32r)) - ((eq type 'bits) - (let ((bits nil) (bnum (1- (* 8 len))) j m) - (while (>= bnum 0) - (if (= (setq m (bindat--unpack-u8)) 0) - (setq bnum (- bnum 8)) - (setq j 128) - (while (> j 0) - (if (/= 0 (logand m j)) - (setq bits (cons bnum bits))) - (setq bnum (1- bnum) - j (ash j -1))))) - bits)) - ((eq type 'str) - (let ((s (substring bindat-raw bindat-idx (+ bindat-idx len)))) - (setq bindat-idx (+ bindat-idx len)) - (if (stringp s) s - (apply #'unibyte-string s)))) - ((eq type 'strz) - (let ((i 0) s) - (while (and (< i len) (/= (aref bindat-raw (+ bindat-idx i)) 0)) - (setq i (1+ i))) - (setq s (substring bindat-raw bindat-idx (+ bindat-idx i))) - (setq bindat-idx (+ bindat-idx len)) - (if (stringp s) s - (apply #'unibyte-string s)))) - ((eq type 'vec) - (let ((v (make-vector len 0)) (i 0) (vlen 1)) + (pcase type + ((or 'u8 'byte) (bindat--unpack-u8)) + ((or 'u16 'word 'short) (bindat--unpack-u16)) + ('u24 (bindat--unpack-u24)) + ((or 'u32 'dword 'long) (bindat--unpack-u32)) + ('u16r (bindat--unpack-u16r)) + ('u24r (bindat--unpack-u24r)) + ('u32r (bindat--unpack-u32r)) + ('bits (bindat--unpack-bits len)) + ('str (bindat--unpack-str len)) + ('strz (bindat--unpack-strz len)) + ('vec + (let ((v (make-vector len 0)) (vlen 1)) (if (consp vectype) (setq vlen (nth 1 vectype) vectype (nth 2 vectype)) (setq type (or vectype 'u8) vectype nil)) - (while (< i len) - (aset v i (bindat--unpack-item type vlen vectype)) - (setq i (1+ i))) + (dotimes (i len) + (aset v i (bindat--unpack-item type vlen vectype))) v)) - (t nil))) + (_ nil))) + +(defsubst bindat--align (n len) + (* len (/ (+ n (1- len)) len))) ;Isn't there a simpler way? (defun bindat--unpack-group (spec) + ;; FIXME: Introduce a new primitive so we can mark `bindat-unpack' + ;; as obsolete (maybe that primitive should be a macro which takes + ;; a bindat type *expression* as argument). + (if (cl-typep spec 'bindat--type) + (funcall (bindat--type-ue spec)) + (with-suppressed-warnings ((lexical struct last)) + (defvar struct) (defvar last)) (let (struct last) - (while spec - (let* ((item (car spec)) - (field (car item)) + (dolist (item spec) + (let* ((field (car item)) (type (nth 1 item)) (len (nth 2 item)) (vectype (and (eq type 'vec) (nth 3 item))) (tail 3) data) - (setq spec (cdr spec)) - (if (and (consp field) (eq (car field) 'eval)) - (setq field (eval (car (cdr field))))) (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 field) (eq (car field) 'eval)) + (setq field (eval (car (cdr field)) t))) (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) + (pcase type + ('eval (if field - (setq data (eval len)) - (eval len))) - ((eq type 'fill) + (setq data (eval len t)) + (eval len t))) + ('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)))) - ((eq type 'repeat) - (let ((index 0) (count len)) - (while (< index count) - (setq data (cons (bindat--unpack-group (nthcdr tail item)) data)) - (setq index (1+ index))) - (setq data (nreverse data)))) - ((eq type 'union) + ('align + (setq bindat-idx (bindat--align bindat-idx len))) + ('struct + (setq data (bindat--unpack-group (eval len t)))) + ('repeat + (dotimes (_ len) + (push (bindat--unpack-group (nthcdr tail item)) data)) + (setq data (nreverse data))) + ('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 + ((pred integerp) (debug 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)))))) - 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) + (setq struct (if field + (cons (cons field data) struct) + (append data struct)))))) + struct))) + +(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. @@ -359,14 +303,12 @@ An integer value in the field list is taken as an array index, e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (while (and struct field) (setq struct (if (integerp (car field)) - (nth (car field) struct) - (let ((val (assq (car field) struct))) - (if (consp val) (cdr val))))) + (elt struct (car field)) + (cdr (assq (car field) struct)))) (setq field (cdr field))) struct) - -;; Calculate bindat-raw length of structured data +;;;; Calculate bindat-raw length of structured data (defvar bindat--fixed-length-alist '((u8 . 1) (byte . 1) @@ -376,85 +318,85 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (ip . 4))) (defun bindat--length-group (struct spec) - (let (last) - (while spec - (let* ((item (car spec)) - (field (car item)) + (if (cl-typep spec 'bindat--type) + (funcall (bindat--type-le spec) struct) + (with-suppressed-warnings ((lexical struct last)) + (defvar struct) (defvar last)) + (let ((struct struct) last) + (dolist (item spec) + (let* ((field (car item)) (type (nth 1 item)) (len (nth 2 item)) (vectype (and (eq type 'vec) (nth 3 item))) (tail 3)) - (setq spec (cdr spec)) - (if (and (consp field) (eq (car field) 'eval)) - (setq field (eval (car (cdr field))))) (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 field) (eq (car field) 'eval)) + (setq field (eval (car (cdr field)) t))) (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)))) - (cond - ((eq type 'eval) + (if (consp vectype) + (setq len (* len (nth 1 vectype)) + type (nth 2 vectype)) + (setq type (or vectype 'u8) + vectype nil))) + (pcase type + ('eval (if field - (setq struct (cons (cons field (eval len)) struct)) - (eval len))) - ((eq type 'fill) + (setq struct (cons (cons field (eval len t)) struct)) + (eval len t))) + ('fill (setq bindat-idx (+ bindat-idx len))) - ((eq type 'align) - (while (/= (% bindat-idx len) 0) - (setq bindat-idx (1+ bindat-idx)))) - ((eq type 'struct) + ('align + (setq bindat-idx (bindat--align bindat-idx len))) + ('struct (bindat--length-group - (if field (bindat-get-field struct field) struct) (eval len))) - ((eq type 'repeat) - (let ((index 0) (count len)) - (while (< index count) - (bindat--length-group - (nth index (bindat-get-field struct field)) - (nthcdr tail item)) - (setq index (1+ index))))) - ((eq type 'union) + (if field (bindat-get-field struct field) struct) (eval len t))) + ('repeat + (dotimes (index len) + (bindat--length-group + (nth index (bindat-get-field struct field)) + (nthcdr tail item)))) + ('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)))))) - (t + (_ (if (setq type (assq type bindat--fixed-length-alist)) (setq len (* len (cdr type)))) (if field (setq last (bindat-get-field struct field))) - (setq bindat-idx (+ bindat-idx len)))))))) + (setq bindat-idx (+ bindat-idx len))))))))) (defun bindat-length (spec struct) - "Calculate bindat-raw length for STRUCT according to bindat SPEC." + "Calculate `bindat-raw' length for STRUCT according to bindat SPEC." (let ((bindat-idx 0)) (bindat--length-group struct spec) bindat-idx)) -;; Pack structured data into bindat-raw +;;;; Pack structured data into bindat-raw -(defun bindat--pack-u8 (v) +(defsubst bindat--pack-u8 (v) (aset bindat-raw bindat-idx (logand v 255)) (setq bindat-idx (1+ bindat-idx))) @@ -471,6 +413,10 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (bindat--pack-u16 (ash v -16)) (bindat--pack-u16 v)) +(defun bindat--pack-u64 (v) + (bindat--pack-u32 (ash v -32)) + (bindat--pack-u32 v)) + (defun bindat--pack-u16r (v) (aset bindat-raw (1+ bindat-idx) (logand (ash v -8) 255)) (aset bindat-raw bindat-idx (logand v 255)) @@ -484,150 +430,147 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (bindat--pack-u16r v) (bindat--pack-u16r (ash v -16))) +(defun bindat--pack-u64r (v) + (bindat--pack-u32r v) + (bindat--pack-u32r (ash v -32))) + +(defun bindat--pack-str (len v) + (dotimes (i (min len (length v))) + (aset bindat-raw (+ bindat-idx i) (aref v i))) + (setq bindat-idx (+ bindat-idx len))) + +(defun bindat--pack-strz (v) + (let ((len (length v))) + (dotimes (i len) + (aset bindat-raw (+ bindat-idx i) (aref v i))) + (setq bindat-idx (+ bindat-idx len 1)))) + +(defun bindat--pack-bits (len v) + (let ((bnum (1- (* 8 len))) j m) + (while (>= bnum 0) + (setq m 0) + (if (null v) + (setq bnum (- bnum 8)) + (setq j 128) + (while (> j 0) + (if (memq bnum v) + (setq m (logior m j))) + (setq bnum (1- bnum) + j (ash j -1)))) + (bindat--pack-u8 m)))) + (defun bindat--pack-item (v type len &optional vectype) (if (eq type 'ip) (setq type 'vec len 4)) - (cond - ((null v) - (setq bindat-idx (+ bindat-idx len))) - ((memq type '(u8 byte)) - (bindat--pack-u8 v)) - ((memq type '(u16 word short)) - (bindat--pack-u16 v)) - ((eq type 'u24) - (bindat--pack-u24 v)) - ((memq type '(u32 dword long)) - (bindat--pack-u32 v)) - ((eq type 'u16r) - (bindat--pack-u16r v)) - ((eq type 'u24r) - (bindat--pack-u24r v)) - ((eq type 'u32r) - (bindat--pack-u32r v)) - ((eq type 'bits) - (let ((bnum (1- (* 8 len))) j m) - (while (>= bnum 0) - (setq m 0) - (if (null v) - (setq bnum (- bnum 8)) - (setq j 128) - (while (> j 0) - (if (memq bnum v) - (setq m (logior m j))) - (setq bnum (1- bnum) - j (ash j -1)))) - (bindat--pack-u8 m)))) - ((memq type '(str strz)) - (let ((l (length v)) (i 0)) - (if (> l len) (setq l len)) - (while (< i l) - (aset bindat-raw (+ bindat-idx i) (aref v i)) - (setq i (1+ i))) - (setq bindat-idx (+ bindat-idx len)))) - ((eq type 'vec) - (let ((l (length v)) (i 0) (vlen 1)) + (pcase type + ((guard (null v)) (setq bindat-idx (+ bindat-idx len))) + ((or 'u8 'byte) (bindat--pack-u8 v)) + ((or 'u16 'word 'short) (bindat--pack-u16 v)) + ('u24 (bindat--pack-u24 v)) + ((or 'u32 'dword 'long) (bindat--pack-u32 v)) + ('u16r (bindat--pack-u16r v)) + ('u24r (bindat--pack-u24r v)) + ('u32r (bindat--pack-u32r v)) + ('bits (bindat--pack-bits len v)) + ((or 'str 'strz) (bindat--pack-str len v)) + ('vec + (let ((l (length v)) (vlen 1)) (if (consp vectype) (setq vlen (nth 1 vectype) vectype (nth 2 vectype)) (setq type (or vectype 'u8) vectype nil)) (if (> l len) (setq l len)) - (while (< i l) - (bindat--pack-item (aref v i) type vlen vectype) - (setq i (1+ i))))) - (t + (dotimes (i l) + (bindat--pack-item (aref v i) type vlen vectype)))) + (_ (setq bindat-idx (+ bindat-idx len))))) (defun bindat--pack-group (struct spec) - (let (last) - (while spec - (let* ((item (car spec)) - (field (car item)) + (if (cl-typep spec 'bindat--type) + (funcall (bindat--type-pe spec) struct) + (with-suppressed-warnings ((lexical struct last)) + (defvar struct) (defvar last)) + (let ((struct struct) last) + (dolist (item spec) + (let* ((field (car item)) (type (nth 1 item)) (len (nth 2 item)) (vectype (and (eq type 'vec) (nth 3 item))) (tail 3)) - (setq spec (cdr spec)) - (if (and (consp field) (eq (car field) 'eval)) - (setq field (eval (car (cdr field))))) (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 field) (eq (car field) 'eval)) + (setq field (eval (car (cdr field)) t))) (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) + (pcase type + ('eval (if field - (setq struct (cons (cons field (eval len)) struct)) - (eval len))) - ((eq type 'fill) + (setq struct (cons (cons field (eval len t)) struct)) + (eval len t))) + ('fill (setq bindat-idx (+ bindat-idx len))) - ((eq type 'align) - (while (/= (% bindat-idx len) 0) - (setq bindat-idx (1+ bindat-idx)))) - ((eq type 'struct) + ('align + (setq bindat-idx (bindat--align bindat-idx len))) + ('struct (bindat--pack-group - (if field (bindat-get-field struct field) struct) (eval len))) - ((eq type 'repeat) - (let ((index 0) (count len)) - (while (< index count) - (bindat--pack-group - (nth index (bindat-get-field struct field)) - (nthcdr tail item)) - (setq index (1+ index))))) - ((eq type 'union) + (if field (bindat-get-field struct field) struct) (eval len t))) + ('repeat + (dotimes (index len) + (bindat--pack-group + (nth index (bindat-get-field struct field)) + (nthcdr tail item)))) + ('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)))))) - (t + (_ (setq last (bindat-get-field struct field)) (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 +;;;; Misc. format conversions (defun bindat-format-vector (vect fmt sep &optional len) "Format vector VECT using element format FMT and separator SEP. Result is a string with each element of VECT formatted using FMT and separated by the string SEP. If optional fourth arg LEN is given, use only that many elements from VECT." - (unless len - (setq len (length vect))) - (let ((i len) (fmt2 (concat sep fmt)) (s nil)) - (while (> i 0) - (setq i (1- i) - s (cons (format (if (= i 0) fmt fmt2) (aref vect i)) s))) - (apply 'concat s))) + (when len (setq vect (substring vect 0 len))) + (mapconcat (lambda (x) (format fmt x)) vect sep)) (defun bindat-vector-to-dec (vect &optional sep) "Format vector VECT in decimal format separated by dots. @@ -635,7 +578,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 ":"))) @@ -647,6 +590,393 @@ The port (if any) is omitted. IP can be a string, as well." (format "%d.%d.%d.%d" (aref ip 0) (aref ip 1) (aref ip 2) (aref ip 3)))) +;;;; New approach based on macro-expansion + +;; Further improvements suggested by reading websocket.el: +;; - Support for bit-sized fields? +;; +;; - Add some way to verify redundant/checksum fields's contents without +;; having to provide a complete `:unpack-val' expression. +;; The `:pack-val' thingy can work nicely to compute checksum fields +;; based on previous fields's contents (without impacting or being impacted +;; by the unpacked representation), but if we want to verify +;; those checksums when unpacking, we have to use the :unpack-val +;; and build the whole object by hand instead of being able to focus +;; just on the checksum field. +;; Maybe this could be related to `unit' type fields where we might like +;; to make sure that the "value" we write into it is the same as the +;; value it holds (tho those checks don't happen at the same time (pack +;; vs unpack). +;; +;; - Support for packing/unpacking to/from something else than +;; a unibyte string, e.g. from a buffer. Problems to do that are: +;; - the `str' and `strz' types which use `substring' rather than reading +;; one byte at a time. +;; - the `align' and `fill' which just want to skip without reading/writing +;; - the `pack-uint' case, which would prefer writing the LSB first. +;; - the `align' case needs to now the current position in order to know +;; how far to advance +;; +;; - Don't write triple code when the type is only ever used at a single place +;; (e.g. to unpack). + +(defun bindat--unpack-uint (bitlen) + (let ((v 0) (bitsdone 0)) + (while (< bitsdone bitlen) + (setq v (logior (ash v 8) (bindat--unpack-u8))) + (setq bitsdone (+ bitsdone 8))) + v)) + +(defun bindat--unpack-uintr (bitlen) + (let ((v 0) (bitsdone 0)) + (while (< bitsdone bitlen) + (setq v (logior v (ash (bindat--unpack-u8) bitsdone))) + (setq bitsdone (+ bitsdone 8))) + v)) + +(defun bindat--pack-uint (bitlen v) + (let* ((len (/ bitlen 8)) + (shift (- (* 8 (1- len))))) + (dotimes (_ len) + (bindat--pack-u8 (logand 255 (ash v shift))) + (setq shift (+ 8 shift))))) + +(defun bindat--pack-uintr (bitlen v) + (let* ((len (/ bitlen 8))) + (dotimes (_ len) + (bindat--pack-u8 (logand v 255)) + (setq v (ash v -8))))) + +(defmacro bindat--pcase (&rest args) + "Like `pcase' but optimize the code under the assumption that it's exhaustive." + (declare (indent 1) (debug pcase)) + `(pcase ,@args (pcase--dontcare nil))) + +(cl-defgeneric bindat--type (op head &rest args) + "Return the code for the operation OP of the Bindat type (HEAD . ARGS). +OP can be one of: unpack', (pack VAL), or (length VAL) where VAL +is the name of a variable that will hold the value we need to pack.") + +(cl-defmethod bindat--type (op (_ (eql byte))) + (bindat--pcase op + ('unpack `(bindat--unpack-u8)) + (`(length . ,_) `(cl-incf bindat-idx 1)) + (`(pack . ,args) `(bindat--pack-u8 . ,args)))) + +(cl-defmethod bindat--type (op (_ (eql uint)) n) + (if (eq n 8) (bindat--type op 'byte) + (bindat--pcase op + ('unpack `(bindat--unpack-uint ,n)) + (`(length . ,_) `(cl-incf bindat-idx (/ ,n 8))) + (`(pack . ,args) `(bindat--pack-uint ,n . ,args))))) + +(cl-defmethod bindat--type (op (_ (eql uintr)) n) + (if (eq n 8) (bindat--type op 'byte) + (bindat--pcase op + ('unpack `(bindat--unpack-uintr ,n)) + (`(length . ,_) `(cl-incf bindat-idx (/ ,n 8))) + (`(pack . ,args) `(bindat--pack-uintr ,n . ,args))))) + +(cl-defmethod bindat--type (op (_ (eql str)) len) + (bindat--pcase op + ('unpack `(bindat--unpack-str ,len)) + (`(length . ,_) `(cl-incf bindat-idx ,len)) + (`(pack . ,args) `(bindat--pack-str ,len . ,args)))) + +(cl-defmethod bindat--type (op (_ (eql strz)) &optional len) + (bindat--pcase op + ('unpack `(bindat--unpack-strz ,len)) + (`(length ,val) + `(cl-incf bindat-idx ,(cond + ((null len) `(length ,val)) + ((numberp len) len) + (t `(or ,len (length ,val)))))) + (`(pack . ,args) + (macroexp-let2 nil len len + `(if ,len + ;; Same as non-zero terminated strings since we don't actually add + ;; the terminating zero anyway (because we rely on the fact that + ;; `bindat-raw' was presumably initialized with all-zeroes before + ;; we started). + (bindat--pack-str ,len . ,args) + (bindat--pack-strz . ,args)))))) + +(cl-defmethod bindat--type (op (_ (eql bits)) len) + (bindat--pcase op + ('unpack `(bindat--unpack-bits ,len)) + (`(length . ,_) `(cl-incf bindat-idx ,len)) + (`(pack . ,args) `(bindat--pack-bits ,len . ,args)))) + +(cl-defmethod bindat--type (_op (_ (eql fill)) len) + `(progn (cl-incf bindat-idx ,len) nil)) + +(cl-defmethod bindat--type (_op (_ (eql align)) len) + `(progn (cl-callf bindat--align bindat-idx ,len) nil)) + +(cl-defmethod bindat--type (op (_ (eql type)) exp) + (bindat--pcase op + ('unpack `(funcall (bindat--type-ue ,exp))) + (`(length . ,args) `(funcall (bindat--type-le ,exp) . ,args)) + (`(pack . ,args) `(funcall (bindat--type-pe ,exp) . ,args)))) + +(cl-defmethod bindat--type (op (_ (eql vec)) count &rest type) + (unless type (setq type '(byte))) + (let ((fun (macroexpand-all (bindat--fun type) macroexpand-all-environment))) + (bindat--pcase op + ('unpack + `(let* ((bindat--len ,count) + (bindat--v (make-vector bindat--len 0))) + (dotimes (bindat--i bindat--len) + (aset bindat--v bindat--i (funcall ,fun))) + bindat--v)) + ((and `(length . ,_) + ;; FIXME: Improve the pattern match to recognize more complex + ;; "constant" functions? + (let `#'(lambda (,val) (setq bindat-idx (+ bindat-idx ,len))) fun) + (guard (not (macroexp--fgrep `((,val)) len)))) + ;; Optimize the case where the size of each element is constant. + `(cl-incf bindat-idx (* ,count ,len))) + ;; FIXME: It's tempting to use `(mapc (lambda (,val) ,exp) ,val)' + ;; which would be more efficient when `val' is a list, + ;; but that's only right if length of `val' is indeed `count'. + (`(,_ ,val) + `(dotimes (bindat--i ,count) + (funcall ,fun (elt ,val bindat--i))))))) + +(cl-defmethod bindat--type (op (_ (eql unit)) val) + (pcase op ('unpack val) (_ nil))) + +(cl-defmethod bindat--type (op (_ (eql struct)) &rest args) + (apply #'bindat--type op args)) + +(cl-defmethod bindat--type (op (_ (eql :pack-var)) var &rest fields) + (unless (consp (cdr fields)) + (error "`:pack-var VAR' needs to be followed by fields")) + (bindat--pcase op + ((or 'unpack (guard (null var))) + (apply #'bindat--type op fields)) + (`(,_ ,val) + `(let ((,var ,val)) ,(apply #'bindat--type op fields))))) + +(cl-defmethod bindat--type (op (field cons) &rest fields) + (named-let loop + ((fields (cons field fields)) + (labels ())) + (bindat--pcase fields + ('nil + (bindat--pcase op + ('unpack + (let ((exp ())) + (pcase-dolist (`(,label . ,labelvar) labels) + (setq exp + (if (eq label '_) + (if exp `(nconc ,labelvar ,exp) labelvar) + `(cons (cons ',label ,labelvar) ,exp)))) + exp)) + (_ nil))) + (`(:unpack-val ,exp) + ;; Make it so `:kwd nil' is the same as the absence of the keyword arg. + (if exp (pcase op ('unpack exp)) (loop nil labels))) + + (`((,label . ,type) . ,fields) + (let* ((get-field-val + (let ((tail (memq :pack-val type))) + ;; FIXME: This `TYPE.. :pack EXP' syntax doesn't work well + ;; when TYPE is a struct (a list of fields) or with extensions + ;; such as allowing TYPE to be `if ...'. + (if tail + (prog1 (cadr tail) + (setq type (butlast type (length tail))))))) + (fieldvar (make-symbol (format "field%d" (length fields)))) + (labelvar + (cond + ((eq label '_) fieldvar) + ((keywordp label) + (intern (substring (symbol-name label) 1))) + (t label))) + (field-fun (bindat--fun type)) + (rest-exp (loop fields `((,label . ,labelvar) . ,labels)))) + (bindat--pcase op + ('unpack + (let ((code + `(let ((,labelvar (funcall ,field-fun))) + ,rest-exp))) + (if (or (eq label '_) (not (assq label labels))) + code + (macroexp-warn-and-return + (format "Duplicate label: %S" label) + code)))) + (`(,_ ,val) + ;; `cdr-safe' is easier to optimize (can't signal an error). + `(let ((,fieldvar ,(or get-field-val + (if (eq label '_) val + `(cdr-safe (assq ',label ,val)))))) + (funcall ,field-fun ,fieldvar) + ,@(when rest-exp + `((let ,(unless (eq labelvar fieldvar) + `((,labelvar ,fieldvar))) + (ignore ,labelvar) + ,rest-exp)))))))) + (_ (error "Unrecognized format in bindat fields: %S" fields))))) + +(def-edebug-elem-spec 'bindat-struct + '([&rest (symbolp bindat-type &optional ":pack-val" def-form)] + &optional ":unpack-val" def-form)) + +(def-edebug-elem-spec 'bindat-type + '(&or ["uint" def-form] + ["uintr" def-form] + ["str" def-form] + ["strz" &optional def-form] + ["bits" def-form] + ["fill" def-form] + ["align" def-form] + ["vec" def-form bindat-type] + ["repeat" def-form bindat-type] + ["type" def-form] + ["struct" bindat-struct] + ["unit" def-form] + [":pack-var" symbolp bindat-type] + symbolp ;; u8, u16, etc... + bindat-struct)) + +(defmacro bindat-type (&rest type) + "Return the Bindat type value to pack&unpack TYPE. +TYPE is a Bindat type expression. It can take the following forms: + + uint BITLEN - Big-endian unsigned integer + uintr BITLEN - Little-endian unsigned integer + str LEN - Byte string + strz [LEN] - Zero-terminated byte-string + bits LEN - Bit vector (LEN is counted in bytes) + fill LEN - Just a filler + align LEN - Fill up to the next multiple of LEN bytes + vec COUNT TYPE - COUNT repetitions of TYPE + type EXP - Indirection; EXP should return a Bindat type value + unit EXP - 0-width type holding the value returned by EXP + struct FIELDS... - A composite type + +When the context makes it clear, the symbol `struct' can be omitted. +A composite type is a list of FIELDS where each FIELD is of the form + + (LABEL TYPE) + +where LABEL can be `_' if the field should not deserve a name. + +Composite types get normally packed/unpacked to/from alists, but this can be +controlled in the following way: +- If the list of fields ends with `:unpack-val EXP', then unpacking will + return the value of EXP (which has the previous fields in its scope). +- If a field's TYPE is followed by `:pack-val EXP', then the value placed + into this field will be that returned by EXP instead of looking up the alist. +- If the list of fields is preceded with `:pack-var VAR' then the object to + be packed is bound to VAR when evaluating the EXPs of `:pack-val'. + +All the above BITLEN, LEN, COUNT, and EXP are ELisp expressions evaluated +in the current lexical context extended with the previous fields. + +TYPE can additionally be one of the Bindat type macros defined with +`bindat-defmacro' (and listed below) or an ELisp expression which returns +a bindat type expression." + (declare (indent 0) (debug (bindat-type))) + `(progn + (defvar bindat-idx) + (bindat--make :ue ,(bindat--toplevel 'unpack type) + :le ,(bindat--toplevel 'length type) + :pe ,(bindat--toplevel 'pack type)))) + +(eval-and-compile + (defconst bindat--primitives '(byte uint uintr str strz bits fill align + struct type vec unit))) + +(eval-and-compile + (defvar bindat--macroenv + (mapcar (lambda (s) (cons s (lambda (&rest args) + (bindat--makefun (cons s args))))) + bindat--primitives))) + +(defmacro bindat-defmacro (name args &rest body) + "Define a new Bindat type as a macro." + (declare (indent 2) (doc-string 3) (debug (&define name sexp def-body))) + (let ((leaders ())) + (while (and (cdr body) + (or (stringp (car body)) + (memq (car-safe (car body)) '(:documentation declare)))) + (push (pop body) leaders)) + ;; FIXME: Add support for Edebug decls to those macros. + `(eval-and-compile ;; Yuck! But needed to define types where you use them! + (setf (alist-get ',name bindat--macroenv) + (lambda ,args ,@(nreverse leaders) + (bindat--fun ,(macroexp-progn body))))))) + +(put 'bindat-type 'function-documentation '(bindat--make-docstring)) +(defun bindat--make-docstring () + ;; Largely inspired from `pcase--make-docstring'. + (let* ((main (documentation (symbol-function 'bindat-type) 'raw)) + (ud (help-split-fundoc main 'bindat-type))) + (require 'help-fns) + (declare-function help-fns--signature "help-fns") + (with-temp-buffer + (insert (or (cdr ud) main)) + (pcase-dolist (`(,name . ,me) (reverse bindat--macroenv)) + (unless (memq name bindat--primitives) + (let ((doc (documentation me 'raw))) + (insert "\n\n-- ") + (setq doc (help-fns--signature name doc me + (indirect-function me) + nil)) + (insert "\n" (or doc "Not documented."))))) + (let ((combined-doc (buffer-string))) + (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc))))) + +(bindat-defmacro u8 () "Unsigned 8bit integer." '(byte)) +(bindat-defmacro sint (bitlen r) + "Signed integer of size BITLEN. +Bigendian if R is nil and little endian if not." + (let ((bl (make-symbol "bitlen")) + (max (make-symbol "max")) + (wrap (make-symbol "wrap"))) + `(let* ((,bl ,bitlen) + (,max (ash 1 (1- ,bl))) + (,wrap (+ ,max ,max))) + (struct :pack-var v + (n if ,r (uintr ,bl) (uint ,bl) + :pack-val (if (< v 0) (+ v ,wrap) v)) + :unpack-val (if (>= n ,max) (- n ,wrap) n))))) + +(bindat-defmacro repeat (count &rest type) + "Like `vec', but unpacks to a list rather than a vector." + `(:pack-var v + (v vec ,count ,@type :pack-val v) + :unpack-val (append v nil))) + +(defvar bindat--op nil + "The operation we're currently building. +This is a simple symbol and can be one of: `unpack', `pack', or `length'. +This is used during macroexpansion of `bindat-type' so that the +macros know which code to generate. +FIXME: this is closely related and very similar to the `op' argument passed +to `bindat--type', yet it's annoyingly different.") + +(defun bindat--fun (type) + (if (or (keywordp (car type)) (consp (car type))) (cons 'struct type) + type)) + +(defun bindat--makefun (type) + (let* ((v (make-symbol "v")) + (args (pcase bindat--op ('unpack ()) (_ (list v))))) + (pcase (apply #'bindat--type + (pcase bindat--op ('unpack 'unpack) (op `(,op . ,args))) + type) + (`(funcall ,f . ,(pred (equal args))) f) ;η-reduce. + (exp `(lambda ,args ,exp))))) + +(defun bindat--toplevel (op type) + (let* ((bindat--op op) + (env `(,@bindat--macroenv + ,@macroexpand-all-environment))) + (macroexpand-all (bindat--fun type) env))) + (provide 'bindat) ;;; bindat.el ends here diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 492218fcd7c..e5265375314 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,10 +284,12 @@ ;; 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))) + (macroexp--unfold-lambda `(,(cadr newfn) ,@(cdr form))) ;; This can happen because of macroexp-warn-and-return &co. (byte-compile-warn "Inlining closure %S failed" name) @@ -295,77 +297,91 @@ (_ ;; Give up on inlining. form)))) - -;; ((lambda ...) ...) -(defun byte-compile-unfold-lambda (form &optional name) - ;; In lexical-binding mode, let and functions don't bind vars in the same way - ;; (let obey special-variable-p, but functions don't). But luckily, this - ;; doesn't matter here, because function's behavior is underspecified so it - ;; can safely be turned into a `let', even though the reverse is not true. - (or name (setq name "anonymous lambda")) - (let* ((lambda (car form)) - (values (cdr form)) - (arglist (nth 1 lambda)) - (body (cdr (cdr lambda))) - optionalp restp - bindings) - (if (and (stringp (car body)) (cdr body)) - (setq body (cdr body))) - (if (and (consp (car body)) (eq 'interactive (car (car body)))) - (setq body (cdr body))) - ;; FIXME: The checks below do not belong in an optimization phase. - (while arglist - (cond ((eq (car arglist) '&optional) - ;; ok, I'll let this slide because funcall_lambda() does... - ;; (if optionalp (error "multiple &optional keywords in %s" name)) - (if restp (error "&optional found after &rest in %s" name)) - (if (null (cdr arglist)) - (error "nothing after &optional in %s" name)) - (setq optionalp t)) - ((eq (car arglist) '&rest) - ;; ...but it is by no stretch of the imagination a reasonable - ;; thing that funcall_lambda() allows (&rest x y) and - ;; (&rest x &optional y) in arglists. - (if (null (cdr arglist)) - (error "nothing after &rest in %s" name)) - (if (cdr (cdr arglist)) - (error "multiple vars after &rest in %s" name)) - (setq restp t)) - (restp - (setq bindings (cons (list (car arglist) - (and values (cons 'list values))) - bindings) - values nil)) - ((and (not optionalp) (null values)) - (byte-compile-warn "attempt to open-code `%s' with too few arguments" name) - (setq arglist nil values 'too-few)) - (t - (setq bindings (cons (list (car arglist) (car values)) - bindings) - values (cdr values)))) - (setq arglist (cdr arglist))) - (if values - (progn - (or (eq values 'too-few) - (byte-compile-warn - "attempt to open-code `%s' with too many arguments" name)) - form) - - ;; The following leads to infinite recursion when loading a - ;; file containing `(defsubst f () (f))', and then trying to - ;; byte-compile that file. - ;(setq body (mapcar 'byte-optimize-form body))) - - (let ((newform - (if bindings - (cons 'let (cons (nreverse bindings) body)) - (cons 'progn body)))) - (byte-compile-log " %s\t==>\t%s" form newform) - newform)))) - ;;; implementing source-level optimizers +(defconst byte-optimize-enable-variable-constprop t + "If non-nil, enable constant propagation through local variables.") + +(defconst byte-optimize-warn-eliminated-variable nil + "Whether to warn when a variable is optimised away entirely. +This does usually not indicate a problem and makes the compiler +very chatty, but can be useful for debugging.") + +(defvar byte-optimize--lexvars nil + "Lexical variables in scope, in reverse order of declaration. +Each element is on the form (NAME KEEP [VALUE]), where: + NAME is the variable name, + KEEP is a boolean indicating whether the binding must be retained, + VALUE, if present, is a substitutable expression. +Earlier variables shadow later ones with the same name.") + +(defvar byte-optimize--vars-outside-condition nil + "Alist of variables lexically bound outside conditionally executed code. +Variables here are sensitive to mutation inside the conditional code, +since their contents in sequentially later code depends on the path taken +and may no longer be statically known. +Same format as `byte-optimize--lexvars', with shared structure and contents.") + +(defvar byte-optimize--vars-outside-loop nil + "Alist of variables lexically bound outside the innermost `while' loop. +Variables here are sensitive to mutation inside the loop, since this can +occur an indeterminate number of times and thus have effect on code +sequentially preceding the mutation itself. +Same format as `byte-optimize--lexvars', with shared structure and contents.") + +(defvar byte-optimize--dynamic-vars nil + "List of variables declared as dynamic during optimisation.") + +(defun byte-optimize--substitutable-p (expr) + "Whether EXPR is a constant that can be propagated." + ;; Only consider numbers, symbols and strings to be values for substitution + ;; purposes. Numbers and symbols are immutable, and mutating string + ;; literals (or results from constant-evaluated string-returning functions) + ;; can be considered undefined. + ;; (What about other quoted values, like conses?) + (or (booleanp expr) + (numberp expr) + (stringp expr) + (and (consp expr) + (eq (car expr) 'quote) + (symbolp (cadr expr))) + (keywordp expr))) + +(defmacro byte-optimize--pcase (exp &rest cases) + ;; When we do + ;; + ;; (pcase EXP + ;; (`(if ,exp ,then ,else) (DO-TEST)) + ;; (`(plus ,e2 ,e2) (DO-ADD)) + ;; (`(times ,e2 ,e2) (DO-MULT)) + ;; ...) + ;; + ;; we usually don't want to fall back to the default case if + ;; the value of EXP is of a form like `(if E1 E2)' or `(plus E1)' + ;; or `(times E1 E2 E3)', instead we either want to signal an error + ;; that EXP has an unexpected shape, or we want to carry on as if + ;; it had the right shape (ignore the extra data and pretend the missing + ;; data is nil) because it should simply never happen. + ;; + ;; The macro below implements the second option by rewriting patterns + ;; like `(if ,exp ,then ,else)' + ;; to `(if . (or `(,exp ,then ,else) pcase--dontcare))'. + ;; + ;; The resulting macroexpansion is also significantly cleaner/smaller/faster. + (declare (indent 1) (debug (form &rest (pcase-PAT body)))) + `(pcase ,exp + . ,(mapcar (lambda (case) + `(,(pcase (car case) + ((and `(,'\` (,_ . (,'\, ,_))) pat) pat) + (`(,'\` (,head . ,tail)) + (list '\` + (cons head + (list '\, `(or ,(list '\` tail) pcase--dontcare))))) + (pat pat)) + . ,(cdr case))) + cases))) + (defun byte-optimize-form-code-walker (form for-effect) ;; ;; For normal function calls, We can just mapcar the optimizer the cdr. But @@ -374,228 +390,346 @@ ;; 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 - (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)) + ;; 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))) + (byte-optimize--pcase form + ((pred (not consp)) + (cond + ((and for-effect + (or byte-compile-delete-errors + (not (symbolp form)) + (eq form t))) + nil) + ((symbolp form) + (let ((lexvar (assq form byte-optimize--lexvars))) + (if (cddr lexvar) ; Value available? + (if (assq form byte-optimize--vars-outside-loop) + ;; Cannot substitute; mark for retention to avoid the + ;; variable being eliminated. + (progn + (setcar (cdr lexvar) t) + form) + (caddr lexvar)) ; variable value to use + 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*) . ,rest) + (cons fn (byte-optimize-let-form fn rest for-effect))) + (`(cond . ,clauses) + ;; The condition in the first clause is always executed, but + ;; right now we treat all of them as conditional for simplicity. + (let ((byte-optimize--vars-outside-condition byte-optimize--lexvars)) + (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 ,exp . ,exps) + (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) + ;; FIXME: We are conservative here: any variable changed in the + ;; THEN branch will be barred from substitution in the ELSE + ;; branch, despite the branches being mutually exclusive. + + ;; The test is always executed. + (let* ((test-opt (byte-optimize-form test nil)) + (const (macroexp-const-p test-opt)) + ;; The branches are traversed unconditionally when possible. + (byte-optimize--vars-outside-condition + (if const + byte-optimize--vars-outside-condition + byte-optimize--lexvars)) + ;; Avoid traversing dead branches. + (then-opt (and test-opt (byte-optimize-form then for-effect))) + (else-opt (and (not (and test-opt const)) + (byte-optimize-body else for-effect)))) + `(if ,test-opt ,then-opt . ,else-opt))) + + (`(,(or 'and 'or) . ,exps) ; Remember, and/or are control structures. + ;; FIXME: We have to traverse the expressions in left-to-right + ;; order (because that is the order of evaluation and variable + ;; mutations must be found prior to their use), but doing so we miss + ;; some optimisation opportunities: + ;; consider (and A B) in a for-effect context, where B => nil. + ;; Then A could be optimised in a for-effect context too. + (let ((tail exps) + (args nil)) + (when tail + ;; The first argument is always unconditional. + (push (byte-optimize-form + (car tail) (and for-effect (null (cdr tail)))) + args) + (setq tail (cdr tail)) + ;; Remaining arguments are conditional. + (let ((byte-optimize--vars-outside-condition byte-optimize--lexvars)) + (while tail + (push (byte-optimize-form + (car tail) (and for-effect (null (cdr tail)))) + args) + (setq tail (cdr tail))))) + (cons fn (nreverse args)))) + + (`(while ,exp . ,exps) + ;; FIXME: We conservatively prevent the substitution of any variable + ;; bound outside the loop in case it is mutated later in the loop, + ;; but this misses many opportunities: variables not mutated in the + ;; loop at all, and variables affecting the initial condition (which + ;; is always executed unconditionally). + (let* ((byte-optimize--vars-outside-condition byte-optimize--lexvars) + (byte-optimize--vars-outside-loop byte-optimize--lexvars) + (condition (byte-optimize-form exp nil)) + (body (byte-optimize-body exps t))) + `(while ,condition . ,body))) + + + (`(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 ,var ,exp . ,clauses) + (let ((byte-optimize--vars-outside-condition byte-optimize--lexvars)) + `(condition-case ,var ;Not evaluated. + ,(byte-optimize-form exp for-effect) + ,@(mapcar (lambda (clause) + (let ((byte-optimize--lexvars + (and lexical-binding + (if var + (cons (list var t) + byte-optimize--lexvars) + byte-optimize--lexvars)))) + (cons (car clause) + (byte-optimize-body (cdr clause) for-effect)))) + clauses)))) + + (`(unwind-protect ,exp . ,exps) + ;; The unwinding part of an unwind-protect is compiled (and thus + ;; optimized) as a top-level form, but run the optimizer for it here + ;; anyway for lexical variable usage and substitution. But the + ;; protected part has the same for-effect status as the + ;; unwind-protect itself. (The unwinding part is always for effect, + ;; but that isn't handled properly yet.) + (let* ((byte-optimize--vars-outside-condition byte-optimize--lexvars) + (bodyform (byte-optimize-form exp for-effect))) + (pcase exps + (`(:fun-body ,f) + `(unwind-protect ,bodyform + :fun-body ,(byte-optimize-form f nil))) + (_ + `(unwind-protect ,bodyform + . ,(byte-optimize-body exps t)))))) + + (`(catch ,tag . ,exps) + (let ((byte-optimize--vars-outside-condition byte-optimize--lexvars)) + `(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 . ,_) + ;; Look up free vars and mark them to be kept, so that they + ;; won't be optimised away. + (dolist (var (caddr form)) + (let ((lexvar (assq var byte-optimize--lexvars))) + (when lexvar + (setcar (cdr lexvar) t)))) + form) + + (`((lambda . ,_) . ,_) + (let ((newform (macroexp--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) + + (`(setq . ,args) + (let ((var-expr-list nil)) + (while args + (unless (and (consp args) + (symbolp (car args)) (consp (cdr args))) + (byte-compile-warn "malformed setq form: %S" form)) + (let* ((var (car args)) + (expr (cadr args)) + (lexvar (assq var byte-optimize--lexvars)) + (value (byte-optimize-form expr nil))) + (when lexvar + ;; Set a new value or inhibit further substitution. + (setcdr (cdr lexvar) + (and + ;; Inhibit if bound outside conditional code. + (not (assq var byte-optimize--vars-outside-condition)) + ;; The new value must be substitutable. + (byte-optimize--substitutable-p value) + (list value))) + (setcar (cdr lexvar) t)) ; Mark variable to be kept. + (push var var-expr-list) + (push value var-expr-list)) + (setq args (cddr args))) + (cons fn (nreverse var-expr-list)))) + + (`(defvar ,(and (pred symbolp) name) . ,rest) + (let ((optimized-rest (and rest + (cons (byte-optimize-form (car rest) nil) + (cdr rest))))) + (push name byte-optimize--dynamic-vars) + `(defvar ,name . ,optimized-rest))) + + (`(,(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." - ;; - ;; First, optimize all sub-forms of this one. - (setq form (byte-optimize-form-code-walker form for-effect)) - ;; - ;; after optimizing all subforms, optimize this form until it doesn't - ;; optimize any further. This means that some forms will be passed through - ;; the optimizer many times, but that's necessary to make the for-effect - ;; processing do as much as possible. - ;; - (let (opt new) - (if (and (consp form) - (symbolp (car form)) - (or ;; (and for-effect - ;; ;; We don't have any of these yet, but we might. - ;; (setq opt (get (car form) - ;; 'byte-for-effect-optimizer))) - (setq opt (function-get (car form) 'byte-optimizer))) - (not (eq form (setq new (funcall opt form))))) - (progn -;; (if (equal form new) (error "bogus optimizer -- %s" opt)) - (byte-compile-log " %s\t==>\t%s" form new) - (setq new (byte-optimize-form new for-effect)) - new) - form))) + (while + (progn + ;; First, optimize all sub-forms of this one. + (setq form (byte-optimize-form-code-walker form for-effect)) + + ;; If a form-specific optimiser is available, run it and start over + ;; until a fixpoint has been reached. + (and (consp form) + (symbolp (car form)) + (let ((opt (function-get (car form) 'byte-optimizer))) + (and opt + (let ((old form) + (new (funcall opt form))) + (byte-compile-log " %s\t==>\t%s" old new) + (setq form new) + (not (eq new old)))))))) + ;; Normalise (quote nil) to nil, for a single representation of constant nil. + (and (not (equal form '(quote nil))) form)) + +(defun byte-optimize-let-form (head form for-effect) + ;; 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. + (if (and lexical-binding byte-optimize-enable-variable-constprop) + (let* ((byte-optimize--lexvars byte-optimize--lexvars) + (new-lexvars nil) + (let-vars nil)) + (dolist (binding (car form)) + (let (name expr) + (cond ((consp binding) + (setq name (car binding)) + (unless (symbolp name) + (byte-compile-warn "let-bind nonvariable: `%S'" name)) + (setq expr (byte-optimize-form (cadr binding) nil))) + ((symbolp binding) + (setq name binding)) + (t (byte-compile-warn "malformed let binding: `%S'" binding))) + (let* ( + (value (and (byte-optimize--substitutable-p expr) + (list expr))) + (lexical (not (or (and (symbolp name) + (special-variable-p name)) + (memq name byte-compile-bound-variables) + (memq name byte-optimize--dynamic-vars)))) + (lexinfo (and lexical (cons name (cons nil value))))) + (push (cons name (cons expr (cdr lexinfo))) let-vars) + (when lexinfo + (push lexinfo (if (eq head 'let*) + byte-optimize--lexvars + new-lexvars)))))) + (setq byte-optimize--lexvars + (append new-lexvars byte-optimize--lexvars)) + ;; Walk the body expressions, which may mutate some of the records, + ;; and generate new bindings that exclude unused variables. + (let* ((byte-optimize--dynamic-vars byte-optimize--dynamic-vars) + (opt-body (byte-optimize-body (cdr form) for-effect)) + (bindings nil)) + (dolist (var let-vars) + ;; VAR is (NAME EXPR [KEEP [VALUE]]) + (if (and (nthcdr 3 var) (not (nth 2 var))) + ;; Value present and not marked to be kept: eliminate. + (when byte-optimize-warn-eliminated-variable + (byte-compile-warn "eliminating local variable %S" (car var))) + (push (list (nth 0 var) (nth 1 var)) bindings))) + (cons bindings opt-body))) + + ;; With dynamic binding, no substitutions are in effect. + (let ((byte-optimize--lexvars nil)) + (cons + (mapcar (lambda (binding) + (if (symbolp binding) + binding + (when (or (atom binding) (cddr binding)) + (byte-compile-warn "malformed let binding: `%S'" binding)) + (list (car binding) + (byte-optimize-form (nth 1 binding) nil)))) + (car form)) + (byte-optimize-body (cdr form) for-effect))))) (defun byte-optimize-body (forms all-for-effect) @@ -664,45 +798,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 +850,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 +875,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 +895,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 +927,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 +945,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 +977,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 +1028,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 +1078,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 +1091,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 +1173,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 +1196,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 +1234,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 +1253,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 +1296,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 +1317,26 @@ 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> string-greaterp string-empty-p + string-prefix-p string-suffix-p string-blank-p + string-search string-to-char + string-to-number string-to-syntax substring sxhash sxhash-equal sxhash-eq sxhash-eql symbol-function symbol-name symbol-plist symbol-value string-make-unibyte string-make-multibyte string-as-multibyte string-as-unibyte @@ -1252,7 +1359,7 @@ window-total-height window-total-width window-use-time window-vscroll window-width zerop)) (side-effect-and-error-free-fns - '(arrayp atom + '(always arrayp atom bignump bobp bolp bool-vector-p buffer-end buffer-list buffer-size buffer-string bufferp car-safe case-table-p cdr-safe char-or-string-p characterp @@ -1279,7 +1386,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 +1403,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 +1415,43 @@ ;; 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> string-greaterp + string-empty-p string-blank-p string-prefix-p string-suffix-p + 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))) @@ -1433,10 +1574,7 @@ ;; so we create a copy of it, and replace the addresses with ;; TAGs. (let ((orig-table last-constant)) - (cl-loop for e across constvec - when (eq e last-constant) - do (setq last-constant (copy-hash-table e)) - and return nil) + (setq last-constant (copy-hash-table last-constant)) ;; Replace all addresses with TAGs. (maphash #'(lambda (value offset) (let ((match (assq offset tags))) @@ -1473,10 +1611,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 +1648,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 +1712,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 +2317,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 +2343,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 +2365,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..119d39713fe 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -82,65 +82,99 @@ 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)))) + +(put 'compiler-macro 'edebug-declaration-spec + '(&or symbolp ("lambda" &define lambda-list lambda-doc def-body))) + +(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)))) + +(defalias 'byte-run--set-completion + #'(lambda (f _args val) + (list 'function-put (list 'quote f) + ''completion-predicate (list 'function val)))) + +(defalias 'byte-run--set-modes + #'(lambda (f _args &rest val) + (list 'function-put (list 'quote f) + ''command-modes (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 'completion #'byte-run--set-completion) + (list 'modes #'byte-run--set-modes)) "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 +184,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 +247,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 +319,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 +393,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 +402,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 +423,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 +437,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 +468,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 +592,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..4f91f0d5dea 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") @@ -193,7 +195,6 @@ otherwise adds \".elc\"." (autoload 'byte-optimize-form "byte-opt") ;; This is the entry point to the lapcode optimizer pass2. (autoload 'byte-optimize-lapcode "byte-opt") -(autoload 'byte-compile-unfold-lambda "byte-opt") ;; This is the entry point to the decompiler, which is used by the ;; disassembler. The disassembler just requires 'byte-compile, but @@ -268,6 +269,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 +292,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 +314,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 @@ -537,6 +548,10 @@ has the form (autoload . FILENAME).") (defvar byte-compile-unresolved-functions nil "Alist of undefined functions to which calls have been compiled. +Each element in the list has the form (FUNCTION POSITION . CALLS) +where CALLS is a list whose elements are integers (indicating the +number of arguments passed in the function call) or the constant `t' +if the function is called indirectly. This variable is only significant whilst compiling an entire buffer. Used for warnings when a function is not known to be defined or is later defined with incorrect args.") @@ -698,7 +713,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 +734,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 +801,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 +978,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 +1008,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 +1019,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 +1203,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) @@ -1425,9 +1427,9 @@ when printing the error message." ;; Remember number of args in call. (let ((cons (assq f byte-compile-unresolved-functions))) (if cons - (or (memq nargs (cdr cons)) - (push nargs (cdr cons))) - (push (list f nargs) + (or (memq nargs (cddr cons)) + (push nargs (cddr cons))) + (push (list f byte-compile-last-position nargs) byte-compile-unresolved-functions))))) ;; Warn if the form is calling a function with the wrong number of arguments. @@ -1527,14 +1529,14 @@ extra args." (setq byte-compile-unresolved-functions (delq calls byte-compile-unresolved-functions)) (setq calls (delq t calls)) ;Ignore higher-order uses of the function. - (when (cdr calls) + (when (cddr calls) (when (and (symbolp name) (eq (function-get name 'byte-optimizer) 'byte-compile-inline-expand)) (byte-compile-warn "defsubst `%s' was used before it was defined" name)) (setq sig (byte-compile-arglist-signature arglist) - nums (sort (copy-sequence (cdr calls)) (function <)) + nums (sort (copy-sequence (cddr calls)) (function <)) min (car nums) max (car (nreverse nums))) (when (or (< min (car sig)) @@ -1567,95 +1569,96 @@ 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) - (when syms - (byte-compile-set-symbol-position (car syms) t)) - (cond ((and (cdr syms) (not noninteractive)) - (let* ((str strn) - (L (length str)) - s) - (while syms - (setq s (symbol-name (pop syms)) - L (+ L (length s) 2)) - (if (< L (1- (buffer-local-value 'fill-column - (or (get-buffer - byte-compile-log-buffer) - (current-buffer))))) - (setq str (concat str " " s (and syms ","))) - (setq str (concat str "\n " s (and syms ",")) - L (+ (length s) 4)))) - (byte-compile-warn "%s" str))) - ((cdr syms) - (byte-compile-warn "%s %s" - strn - (mapconcat #'symbol-name syms ", "))) - - (syms - (byte-compile-warn str1 (car syms))))) - ;; If we have compiled any calls to functions which are not known to be ;; defined, issue a warning enumerating them. ;; `unresolved' in the list `byte-compile-warnings' disables this. (defun byte-compile-warn-about-unresolved-functions () (when (byte-compile-warning-enabled-p 'unresolved) - (let ((byte-compile-current-form :end) - (noruntime nil) - (unresolved nil)) + (let ((byte-compile-current-form :end)) ;; Separate the functions that will not be available at runtime ;; from the truly unresolved ones. - (dolist (f byte-compile-unresolved-functions) - (setq f (car f)) - (when (not (memq f byte-compile-new-defuns)) - (if (fboundp f) (push f noruntime) (push f unresolved)))) - ;; Complain about the no-run-time functions - (byte-compile-print-syms - "the function `%s' might not be defined at runtime." - "the following functions might not be defined at runtime:" - noruntime) - ;; Complain about the unresolved functions - (byte-compile-print-syms - "the function `%s' is not known to be defined." - "the following functions are not known to be defined:" - unresolved))) + (dolist (urf byte-compile-unresolved-functions) + (let ((f (car urf))) + (when (not (memq f byte-compile-new-defuns)) + (let ((byte-compile-last-position (cadr urf))) + (byte-compile-warn + (if (fboundp f) "the function `%s' might not be defined at runtime." "the function `%s' is not known to be defined.") + (car urf)))))))) nil) @@ -1693,6 +1696,11 @@ extra args." ;; (byte-compile-generate-emacs19-bytecodes ;; byte-compile-generate-emacs19-bytecodes) (byte-compile-warnings byte-compile-warnings) + ;; Indicate that we're not currently loading some file. + ;; This is used in `macroexp-file-name' to make sure that + ;; loading file A which does (byte-compile-file B) won't + ;; cause macro calls in B to think they come from A. + (current-load-list (list nil)) ) ,@body)) @@ -1703,7 +1711,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 +1743,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 +1756,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 +1793,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 +1847,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 +1866,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 +1903,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 +1935,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 +1992,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 +2001,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 +2016,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 +2071,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 +2079,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 +2193,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 +2213,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 +2237,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 @@ -2379,8 +2391,6 @@ list that represents a doc string reference. byte-compile-output nil byte-compile-jump-tables nil)))) -(defvar byte-compile-force-lexical-warnings nil) - (defun byte-compile-preprocess (form &optional _for-effect) (setq form (macroexpand-all form byte-compile-macro-environment)) ;; FIXME: We should run byte-optimize-form here, but it currently does not @@ -2391,7 +2401,6 @@ list that represents a doc string reference. ;; (setq form (byte-optimize-form form for-effect))) (cond (lexical-binding (cconv-closure-convert form)) - (byte-compile-force-lexical-warnings (cconv-warnings-only form)) (t form))) ;; byte-hunk-handlers cannot call this! @@ -2449,24 +2458,29 @@ 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))) (put 'defvar 'byte-hunk-handler 'byte-compile-file-form-defvar) (put 'defconst 'byte-hunk-handler 'byte-compile-file-form-defvar) -(defun byte-compile--declare-var (sym) +(defun byte-compile--check-prefixed-var (sym) (when (and (symbolp sym) (not (string-match "[-*/:$]" (symbol-name sym))) (byte-compile-warning-enabled-p 'lexical sym)) - (byte-compile-warn "global/dynamic var `%s' lacks a prefix" - sym)) + (byte-compile-warn "global/dynamic var `%s' lacks a prefix" sym))) + +(defun byte-compile--declare-var (sym) + (byte-compile--check-prefixed-var sym) (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 +2490,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 +2514,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 +2527,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 +2540,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 +2577,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))) @@ -2754,16 +2756,12 @@ FUN should be either a `lambda' value or a `closure' value." (dolist (binding env) (cond ((consp binding) - ;; We check shadowing by the args, so that the `let' can be moved - ;; within the lambda, which can then be unfolded. FIXME: Some of those - ;; bindings might be unused in `body'. - (unless (memq (car binding) args) ;Shadowed. - (push `(,(car binding) ',(cdr binding)) renv))) + (push `(,(car binding) ',(cdr binding)) renv)) ((eq binding t)) (t (push `(defvar ,binding) body)))) (if (null renv) `(lambda ,args ,@preamble ,@body) - `(lambda ,args ,@preamble (let ,(nreverse renv) ,@body))))) + `(let ,renv (lambda ,args ,@preamble ,@body))))) ;;;###autoload (defun byte-compile (form) @@ -2788,23 +2786,27 @@ If FORM is a lambda or a macro, byte-compile it as a function." (if (symbolp form) form "provided")) fun) (t - (when (or (symbolp form) (eq (car-safe fun) 'closure)) - ;; `fun' is a function *value*, so try to recover its corresponding - ;; source code. - (setq lexical-binding (eq (car fun) 'closure)) - (setq fun (byte-compile--reify-function fun))) - ;; Expand macros. - (setq fun (byte-compile-preprocess fun)) - (setq fun (byte-compile-top-level fun nil 'eval)) - (if (symbolp form) - ;; byte-compile-top-level returns an *expression* equivalent to the - ;; `fun' expression, so we need to evaluate it, tho normally - ;; this is not needed because the expression is just a constant - ;; byte-code object, which is self-evaluating. - (setq fun (eval fun t))) - (if macro (push 'macro fun)) - (if (symbolp form) (fset form fun)) - fun)))))) + (let (final-eval) + (when (or (symbolp form) (eq (car-safe fun) 'closure)) + ;; `fun' is a function *value*, so try to recover its corresponding + ;; source code. + (setq lexical-binding (eq (car fun) 'closure)) + (setq fun (byte-compile--reify-function fun)) + (setq final-eval t)) + ;; Expand macros. + (setq fun (byte-compile-preprocess fun)) + (setq fun (byte-compile-top-level fun nil 'eval)) + (if (symbolp form) + ;; byte-compile-top-level returns an *expression* equivalent to the + ;; `fun' expression, so we need to evaluate it, tho normally + ;; this is not needed because the expression is just a constant + ;; byte-code object, which is self-evaluating. + (setq fun (eval fun t))) + (if final-eval + (setq fun (eval fun t))) + (if macro (push 'macro fun)) + (if (symbolp form) (fset form fun)) + fun))))))) (defun byte-compile-sexp (sexp) "Compile and return SEXP." @@ -2830,7 +2832,9 @@ If FORM is a lambda or a macro, byte-compile it as a function." ((eq arg '&optional) (when (memq '&optional (cdr list)) (error "Duplicate &optional"))) - ((memq arg vars) + ((and (memq arg vars) + ;; Allow repetitions for unused args. + (not (string-match "\\`_" (symbol-name arg)))) (byte-compile-warn "repeated variable %s in lambda-list" arg)) (t (push arg vars)))) @@ -2872,6 +2876,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 +2900,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)) @@ -2899,17 +2914,25 @@ for symbols generated by the byte compiler itself." ;; unless it is the last element of the body. (if (cdr body) (setq body (cdr body)))))) - (int (assq 'interactive body))) + (int (assq 'interactive body)) + command-modes) + (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) ;; Skip (interactive) if it is in front (the most usual location). (if (eq int (car body)) (setq body (cdr body))) - (cond ((consp (cdr int)) - (if (cdr (cdr int)) - (byte-compile-warn "malformed interactive spec: %s" - (prin1-to-string int))) + (cond ((consp (cdr int)) ; There is an `interactive' spec. + ;; Check that the bit after the `interactive' spec is + ;; just a list of symbols (i.e., modes). + (unless (seq-every-p #'symbolp (cdr (cdr int))) + (byte-compile-warn "malformed interactive specc: %s" + (prin1-to-string int))) + (setq command-modes (cdr (cdr int))) ;; If the interactive spec is a call to `list', don't ;; compile it, because `call-interactively' looks at the ;; args of `list'. Actually, compile it to get warnings, @@ -2920,15 +2943,14 @@ for symbols generated by the byte compiler itself." (while (consp (cdr form)) (setq form (cdr form))) (setq form (car form))) - (if (and (eq (car-safe form) 'list) - ;; For code using lexical-binding, form is not - ;; valid lisp, but rather an intermediate form - ;; which may include "calls" to - ;; internal-make-closure (Bug#29988). - (not lexical-binding)) - nil - (setq int `(interactive ,newform))))) - ((cdr int) + (when (or (not (eq (car-safe form) 'list)) + ;; For code using lexical-binding, form is not + ;; valid lisp, but rather an intermediate form + ;; which may include "calls" to + ;; internal-make-closure (Bug#29988). + lexical-binding) + (setq int `(interactive ,newform))))) + ((cdr int) ; Invalid (interactive . something). (byte-compile-warn "malformed interactive spec: %s" (prin1-to-string int))))) ;; Process the body. @@ -2958,9 +2980,16 @@ for symbols generated by the byte compiler itself." (list (help-add-fundoc-usage doc arglist))) ((or doc int) (list doc))) - ;; optionally, the interactive spec. - (if int - (list (nth 1 int)))))))) + ;; optionally, the interactive spec (and the modes the + ;; command applies to). + (cond + ;; We have some command modes, so use the vector form. + (command-modes + (list (vector (nth 1 int) command-modes))) + ;; No command modes, use the simple form with just the + ;; interactive spec. + (int + (list (nth 1 int))))))))) (defvar byte-compile-reserved-constants 0) @@ -3189,7 +3218,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 +3244,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,16 +3254,14 @@ 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)) ((and (eq (car-safe (car form)) 'lambda) ;; if the form comes out the same way it went in, that's ;; because it was malformed, and we couldn't unfold it. - (not (eq form (setq form (byte-compile-unfold-lambda form))))) + (not (eq form (setq form (macroexp--unfold-lambda form))))) (byte-compile-form form byte-compile--for-effect) (setq byte-compile--for-effect nil)) ((byte-compile-normal-call form))) @@ -3398,10 +3426,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 +3446,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 +3475,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 +3486,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 +3497,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 +3525,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 +3544,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 +3655,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 +3729,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)) @@ -3748,45 +3790,74 @@ discarding." (cl-assert (or (> (length env) 0) docstring-exp)) ;Otherwise, we don't need a closure. (cl-assert (byte-code-function-p fun)) - (byte-compile-form `(make-byte-code - ',(aref fun 0) ',(aref fun 1) - (vconcat (vector . ,env) ',(aref fun 2)) - ,@(let ((rest (nthcdr 3 (mapcar (lambda (x) `',x) fun)))) - (if docstring-exp - `(,(car rest) - ,docstring-exp - ,@(cddr rest)) - rest))))))) + (byte-compile-form + (if (or (not docstring-exp) (stringp docstring-exp)) + ;; Use symbols V0, V1 ... as placeholders for closure variables: + ;; they should be short (to save space in the .elc file), yet + ;; distinct when disassembled. + (let* ((dummy-vars (mapcar (lambda (i) (intern (format "V%d" i))) + (number-sequence 0 (1- (length env))))) + (opt-args (mapcar (lambda (i) (aref fun i)) + (number-sequence 4 (1- (length fun))))) + (proto-fun + (apply #'make-byte-code + (aref fun 0) (aref fun 1) + ;; Prepend dummy cells to the constant vector, + ;; to get the indices right when disassembling. + (vconcat dummy-vars (aref fun 2)) + (aref fun 3) + (if docstring-exp + (cons docstring-exp (cdr opt-args)) + opt-args)))) + `(make-closure ,proto-fun ,@env)) + ;; Nontrivial doc string expression: create a bytecode object + ;; from small pieces at run time. + `(make-byte-code + ',(aref fun 0) ',(aref fun 1) + (vconcat (vector . ,env) ',(aref fun 2)) + ,@(let ((rest (nthcdr 3 (mapcar (lambda (x) `',x) fun)))) + (if docstring-exp + `(,(car rest) + ,docstring-exp + ,@(cddr rest)) + rest)))) + )))) (defun byte-compile-get-closed-var (form) "Byte-compile the special `internal-get-closed-var' form." (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 +3872,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 +3939,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))) @@ -4097,9 +4155,15 @@ that suppresses all warnings during execution of BODY." byte-compile-unresolved-functions)) (bound-list (byte-compile-find-bound-condition ,condition '(boundp default-boundp local-variable-p))) + (new-bound-list + ;; (seq-difference byte-compile-bound-variables)) + (delq nil (mapcar (lambda (s) + (if (memq s byte-compile-bound-variables) nil s)) + bound-list))) ;; Maybe add to the bound list. (byte-compile-bound-variables - (append bound-list byte-compile-bound-variables))) + (append new-bound-list byte-compile-bound-variables))) + (mapc #'byte-compile--check-prefixed-var new-bound-list) (unwind-protect ;; If things not being bound at all is ok, so must them being ;; obsolete. Note that we add to the existing lists since Tramp @@ -4418,6 +4482,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,102 +4600,36 @@ 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)) + (handlers (nthcdr 3 form)) (depth byte-compile-depth) + (success-handler (assq :success handlers)) + (failure-handlers (if success-handler + (remq success-handler handlers) + handlers)) (clauses (mapcar (lambda (clause) (cons (byte-compile-make-tag) clause)) - (nthcdr 3 form))) + failure-handlers)) (endtag (byte-compile-make-tag))) (byte-compile-set-symbol-position 'condition-case) (unless (symbolp var) @@ -4655,30 +4655,40 @@ binding slots have been popped." (byte-compile-form body) ;; byte-compile--for-effect (dolist (_ clauses) (byte-compile-out 'byte-pophandler)) - (byte-compile-goto 'byte-goto endtag) - (while clauses - (let ((clause (pop clauses)) - (byte-compile-bound-variables byte-compile-bound-variables) - (byte-compile--lexical-environment - byte-compile--lexical-environment)) - (setq byte-compile-depth (1+ depth)) - (byte-compile-out-tag (pop clause)) - (dolist (_ clauses) (byte-compile-out 'byte-pophandler)) - (cond - ((null var) (byte-compile-discard)) - (lexical-binding - (push (cons var (1- byte-compile-depth)) - byte-compile--lexical-environment)) - (t (byte-compile-dynamic-variable-bind var))) - (byte-compile-body (cdr clause)) ;; byte-compile--for-effect - (cond - ((null var) nil) - (lexical-binding (byte-compile-discard 1 'preserve-tos)) - (t (byte-compile-out 'byte-unbind 1))) - (byte-compile-goto 'byte-goto endtag))) + (let ((compile-handler-body + (lambda (body) + (let ((byte-compile-bound-variables byte-compile-bound-variables) + (byte-compile--lexical-environment + byte-compile--lexical-environment)) + (cond + ((null var) (byte-compile-discard)) + (lexical-binding + (push (cons var (1- byte-compile-depth)) + byte-compile--lexical-environment)) + (t (byte-compile-dynamic-variable-bind var))) - (byte-compile-out-tag endtag))) + (byte-compile-body body) ;; byte-compile--for-effect + + (cond + ((null var)) + (lexical-binding (byte-compile-discard 1 'preserve-tos)) + (t (byte-compile-out 'byte-unbind 1))))))) + + (when success-handler + (funcall compile-handler-body (cdr success-handler))) + + (byte-compile-goto 'byte-goto endtag) + + (while clauses + (let ((clause (pop clauses))) + (setq byte-compile-depth (1+ depth)) + (byte-compile-out-tag (pop clause)) + (dolist (_ clauses) (byte-compile-out 'byte-pophandler)) + (funcall compile-handler-body (cdr clause)) + (byte-compile-goto 'byte-goto endtag))) + + (byte-compile-out-tag endtag)))) (defun byte-compile-save-excursion (form) (if (and (eq 'set-buffer (car-safe (car-safe (cdr form)))) @@ -4726,6 +4736,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 +4811,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 +4873,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) @@ -4876,10 +4896,10 @@ binding slots have been popped." (byte-compile-push-constant op) (byte-compile-form fun) (byte-compile-form prop) - (let* ((fun (eval fun)) - (prop (eval prop)) + (let* ((fun (eval fun t)) + (prop (eval prop t)) (val (if (macroexp-const-p val) - (eval val) + (eval val t) (byte-compile-lambda (cadr val))))) (push `(,fun . (,prop ,val ,@(alist-get fun overriding-plist-environment))) @@ -5197,8 +5217,9 @@ already up-to-date." "Reload any Lisp file that was changed since Emacs was dumped. Use with caution." (let* ((argv0 (car command-line-args)) - (emacs-file (executable-find argv0))) - (if (not (and emacs-file (file-executable-p emacs-file))) + (emacs-file (or (cdr (nth 2 (pdumper-stats))) + (executable-find argv0)))) + (if (not (and emacs-file (file-exists-p emacs-file))) (message "Can't find %s to refresh preloaded Lisp files" argv0) (dolist (f (reverse load-history)) (setq f (car f)) @@ -5309,6 +5330,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..f6637109028 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -1,4 +1,4 @@ -;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t -*- +;;; cconv.el --- Closure conversion for statically scoped Emacs Lisp. -*- lexical-binding: t -*- ;; Copyright (C) 2011-2021 Free Software Foundation, Inc. @@ -121,19 +121,22 @@ (defconst cconv-liftwhen 6 "Try to do lambda lifting if the number of arguments + free variables is less than this number.") -;; List of all the variables that are both captured by a closure -;; and mutated. Each entry in the list takes the form -;; (BINDER . PARENTFORM) where BINDER is the (VAR VAL) that introduces the -;; variable (or is just (VAR) for variables not introduced by let). -(defvar cconv-captured+mutated) - -;; List of candidates for lambda lifting. -;; Each candidate has the form (BINDER . PARENTFORM). A candidate -;; is a variable that is only passed to `funcall' or `apply'. -(defvar cconv-lambda-candidates) - -;; Alist associating to each function body the list of its free variables. -(defvar cconv-freevars-alist) +(defvar cconv-var-classification + ;; Alist mapping variables to a given class. + ;; The keys are of the form (BINDER . PARENTFORM) where BINDER + ;; is the (VAR VAL) that introduces it (or is just (VAR) for variables + ;; not introduced by let). + ;; The class can be one of: + ;; - :unused + ;; - :lambda-candidate + ;; - :captured+mutated + ;; - nil for "normal" variables, which would then just not appear + ;; in the alist at all. + ) + +(defvar cconv-freevars-alist + ;; Alist associating to each function body the list of its free variables. + ) ;;;###autoload (defun cconv-closure-convert (form) @@ -144,25 +147,13 @@ is less than this number.") Returns a form where all lambdas don't have any free variables." ;; (message "Entering cconv-closure-convert...") (let ((cconv-freevars-alist '()) - (cconv-lambda-candidates '()) - (cconv-captured+mutated '())) + (cconv-var-classification '())) ;; Analyze form - fill these variables with new information. (cconv-analyze-form form '()) (setq cconv-freevars-alist (nreverse cconv-freevars-alist)) (prog1 (cconv-convert form nil nil) ; Env initially empty. (cl-assert (null cconv-freevars-alist))))) -;;;###autoload -(defun cconv-warnings-only (form) - "Add the warnings that closure conversion would encounter." - (let ((cconv-freevars-alist '()) - (cconv-lambda-candidates '()) - (cconv-captured+mutated '())) - ;; Analyze form - fill these variables with new information. - (cconv-analyze-form form '()) - ;; But don't perform the closure conversion. - form)) - (defconst cconv--dummy-var (make-symbol "ignored")) (defun cconv--set-diff (s1 s2) @@ -261,28 +252,56 @@ Returns a form where all lambdas don't have any free variables." (nthcdr 3 mapping))))) new-env)) +(defun cconv--warn-unused-msg (var varkind) + (unless (or ;; Uninterned symbols typically come from macro-expansion, so + ;; it is often non-trivial for the programmer to avoid such + ;; unused vars. + (not (intern-soft var)) + (eq ?_ (aref (symbol-name var) 0)) + ;; As a special exception, ignore "ignore". + (eq var 'ignored)) + (let ((suggestions (help-uni-confusable-suggestions (symbol-name var)))) + (format "Unused lexical %s `%S'%s" + varkind var + (if suggestions (concat "\n " suggestions) ""))))) + +(define-inline cconv--var-classification (binder form) + (inline-quote + (alist-get (cons ,binder ,form) cconv-var-classification + nil nil #'equal))) + (defun cconv--convert-funcbody (funargs funcbody env parentform) "Run `cconv-convert' on FUNCBODY, the forms of a lambda expression. PARENTFORM is the form containing the lambda expression. ENV is a lexical environment (same format as for `cconv-convert'), not including FUNARGS, the function's argument list. Return a list of converted forms." - (let ((letbind ())) + (let ((wrappers ())) (dolist (arg funargs) - (if (not (member (cons (list arg) parentform) cconv-captured+mutated)) - (if (assq arg env) (push `(,arg . nil) env)) - (push `(,arg . (car-safe ,arg)) env) - (push `(,arg (list ,arg)) letbind))) + (pcase (cconv--var-classification (list arg) parentform) + (:captured+mutated + (push `(,arg . (car-safe ,arg)) env) + (push (lambda (body) `(let ((,arg (list ,arg))) ,body)) wrappers)) + ((and :unused + (let (and (pred stringp) msg) + (cconv--warn-unused-msg arg "argument"))) + (if (assq arg env) (push `(,arg . nil) env)) ;FIXME: Is it needed? + (push (lambda (body) (macroexp--warn-wrap msg body)) wrappers)) + (_ + (if (assq arg env) (push `(,arg . nil) env))))) (setq funcbody (mapcar (lambda (form) (cconv-convert form env nil)) funcbody)) - (if letbind + (if wrappers (let ((special-forms '())) ;; Keep special forms at the beginning of the body. - (while (or (stringp (car funcbody)) ;docstring. - (memq (car-safe (car funcbody)) '(interactive declare))) + (while (or (and (cdr funcbody) (stringp (car funcbody))) ;docstring. + (memq (car-safe (car funcbody)) + '(interactive declare :documentation))) (push (pop funcbody) special-forms)) - `(,@(nreverse special-forms) (let ,letbind . ,funcbody))) + (let ((body (macroexp-progn funcbody))) + (dolist (wrapper wrappers) (setq body (funcall wrapper body))) + `(,@(nreverse special-forms) ,@(macroexp-unprogn body)))) funcbody))) (defun cconv-convert (form env extend) @@ -340,46 +359,58 @@ places where they originally did not directly appear." (setq value (cadr binder)) (car binder))) (new-val - (cond - ;; Check if var is a candidate for lambda lifting. - ((and (member (cons binder form) cconv-lambda-candidates) - (progn - (cl-assert (and (eq (car value) 'function) - (eq (car (cadr value)) 'lambda))) - (cl-assert (equal (cddr (cadr value)) - (caar cconv-freevars-alist))) - ;; Peek at the freevars to decide whether to λ-lift. - (let* ((fvs (cdr (car cconv-freevars-alist))) - (fun (cadr value)) - (funargs (cadr fun)) - (funcvars (append fvs funargs))) + (pcase (cconv--var-classification binder form) + ;; Check if var is a candidate for lambda lifting. + ((and :lambda-candidate + (guard + (progn + (cl-assert (and (eq (car value) 'function) + (eq (car (cadr value)) 'lambda))) + (cl-assert (equal (cddr (cadr value)) + (caar cconv-freevars-alist))) + ;; Peek at the freevars to decide whether to λ-lift. + (let* ((fvs (cdr (car cconv-freevars-alist))) + (fun (cadr value)) + (funargs (cadr fun)) + (funcvars (append fvs funargs))) ; lambda lifting condition - (and fvs (>= cconv-liftwhen (length funcvars)))))) + (and fvs (>= cconv-liftwhen + (length funcvars))))))) ; Lift. - (let* ((fvs (cdr (pop cconv-freevars-alist))) - (fun (cadr value)) - (funargs (cadr fun)) - (funcvars (append fvs funargs)) - (funcbody (cddr fun)) - (funcbody-env ())) - (push `(,var . (apply-partially ,var . ,fvs)) new-env) - (dolist (fv fvs) - (cl-pushnew fv new-extend) - (if (and (eq 'car-safe (car-safe (cdr (assq fv env)))) - (not (memq fv funargs))) - (push `(,fv . (car-safe ,fv)) funcbody-env))) - `(function (lambda ,funcvars . - ,(cconv--convert-funcbody - funargs funcbody funcbody-env value))))) + (let* ((fvs (cdr (pop cconv-freevars-alist))) + (fun (cadr value)) + (funargs (cadr fun)) + (funcvars (append fvs funargs)) + (funcbody (cddr fun)) + (funcbody-env ())) + (push `(,var . (apply-partially ,var . ,fvs)) new-env) + (dolist (fv fvs) + (cl-pushnew fv new-extend) + (if (and (eq 'car-safe (car-safe (cdr (assq fv env)))) + (not (memq fv funargs))) + (push `(,fv . (car-safe ,fv)) funcbody-env))) + `(function (lambda ,funcvars . + ,(cconv--convert-funcbody + funargs funcbody funcbody-env value))))) ;; Check if it needs to be turned into a "ref-cell". - ((member (cons binder form) cconv-captured+mutated) + (:captured+mutated ;; Declared variable is mutated and captured. (push `(,var . (car-safe ,var)) new-env) `(list ,(cconv-convert value env extend))) + ;; Check if it needs to be turned into a "ref-cell". + (:unused + ;; Declared variable is unused. + (if (assq var new-env) (push `(,var) new-env)) ;FIXME:Needed? + (let ((newval + `(ignore ,(cconv-convert value env extend))) + (msg (cconv--warn-unused-msg var "variable"))) + (if (null msg) newval + (macroexp--warn-wrap msg newval)))) + ;; Normal default case. - (t + (_ (if (assq var new-env) (push `(,var) new-env)) (cconv-convert value env extend))))) @@ -462,44 +493,35 @@ 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) - ,@(let* ((cm (and var (member (cons (list var) form) - cconv-captured+mutated))) - (newenv - (cond (cm (cons `(,var . (car-save ,var)) env)) - ((assq var env) (cons `(,var) env)) - (t env)))) - (mapcar + (let* ((class (and var (cconv--var-classification (list var) form))) + (newenv + (cond ((eq class :captured+mutated) + (cons `(,var . (car-safe ,var)) env)) + ((assq var env) (cons `(,var) env)) + (t env))) + (msg (when (eq class :unused) + (cconv--warn-unused-msg var "variable"))) + (newprotform (cconv-convert protected-form env extend))) + `(condition-case ,var + ,(if msg + (macroexp--warn-wrap msg newprotform) + newprotform) + ,@(mapcar (lambda (handler) `(,(car handler) ,@(let ((body (mapcar (lambda (form) (cconv-convert form newenv extend)) (cdr handler)))) - (if (not cm) body + (if (not (eq class :captured+mutated)) + body `((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 @@ -563,9 +585,6 @@ places where they originally did not directly appear." (_ (or (cdr (assq form env)) form)))) -(unless (fboundp 'byte-compile-not-lexical-var-p) - ;; Only used to test the code in non-lexbind Emacs. - (defalias 'byte-compile-not-lexical-var-p 'boundp)) (defvar byte-compile-lexical-variables) (defun cconv--analyze-use (vardata form varkind) @@ -578,29 +597,28 @@ FORM is the parent form that binds this var." (`(,_ nil nil nil nil) nil) (`((,(and var (guard (eq ?_ (aref (symbol-name var) 0)))) . ,_) ,_ ,_ ,_ ,_) + ;; FIXME: Convert this warning to use `macroexp--warn-wrap' + ;; so as to give better position information. (byte-compile-warn - "%s `%S' not left unused" varkind var))) + "%s `%S' not left unused" varkind var)) + ((and (let (or 'let* 'let) (car form)) + `((,var) ;; (or `(,var nil) : Too many false positives: bug#47080 + t nil ,_ ,_)) + ;; FIXME: Convert this warning to use `macroexp--warn-wrap' + ;; so as to give better position information. + (unless (not (intern-soft var)) + (byte-compile-warn "Variable `%S' left uninitialized" var)))) (pcase vardata - (`((,var . ,_) nil ,_ ,_ nil) - ;; FIXME: This gives warnings in the wrong order, with imprecise line - ;; numbers and without function name info. - (unless (or ;; Uninterned symbols typically come from macro-expansion, so - ;; it is often non-trivial for the programmer to avoid such - ;; unused vars. - (not (intern-soft var)) - (eq ?_ (aref (symbol-name var) 0)) - ;; As a special exception, ignore "ignore". - (eq var 'ignored)) - (let ((suggestions (help-uni-confusable-suggestions (symbol-name var)))) - (byte-compile-warn "Unused lexical %s `%S'%s" - varkind var - (if suggestions (concat "\n " suggestions) ""))))) + (`(,binder nil ,_ ,_ nil) + (push (cons (cons binder form) :unused) cconv-var-classification)) ;; If it's unused, there's no point converting it into a cons-cell, even if ;; it's captured and mutated. (`(,binder ,_ t t ,_) - (push (cons binder form) cconv-captured+mutated)) + (push (cons (cons binder form) :captured+mutated) + cconv-var-classification)) (`(,(and binder `(,_ (function (lambda . ,_)))) nil nil nil t) - (push (cons binder form) cconv-lambda-candidates)))) + (push (cons (cons binder form) :lambda-candidate) + cconv-var-classification)))) (defun cconv--analyze-function (args body env parentform) (let* ((newvars nil) @@ -653,8 +671,7 @@ Analyze lambdas if they are suitable for lambda lifting. - ENV is an alist mapping each enclosing lexical variable to its info. I.e. each element has the form (VAR . (READ MUTATED CAPTURED CALLED)). This function does not return anything but instead fills the -`cconv-captured+mutated' and `cconv-lambda-candidates' variables -and updates the data stored in ENV." +`cconv-var-classification' variable and updates the data stored in ENV." (pcase form ; let special form (`(,(and (or 'let* 'let) letsym) ,binders . ,body-forms) @@ -718,15 +735,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 +749,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)) @@ -782,7 +788,7 @@ and updates the data stored in ENV." (let ((dv (assq form env))) ; dv = declared and visible (when dv (setf (nth 1 dv) t)))))) -(define-obsolete-function-alias 'cconv-analyse-form 'cconv-analyze-form "25.1") +(define-obsolete-function-alias 'cconv-analyse-form #'cconv-analyze-form "25.1") (provide 'cconv) ;;; cconv.el ends here diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el index d2d9807c0a0..5afc6d3bde3 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") @@ -90,39 +89,43 @@ Useful if new Emacs is used on B&W display.") (declare-function x-display-color-cells "xfns.c" (&optional terminal)) -(defvar chart-face-list - (if (display-color-p) - (let ((cl chart-face-color-list) - (pl chart-face-pixmap-list) - (faces ()) - nf) - (while cl - (setq nf (make-face - (intern (concat "chart-" (car cl) "-" (car pl))))) - (set-face-background nf (if (condition-case nil - (> (x-display-color-cells) 4) - (error t)) - (car cl) - "white")) - (set-face-foreground nf "black") - (if (and chart-face-use-pixmaps - pl - (fboundp 'set-face-background-pixmap)) - (condition-case nil - (set-face-background-pixmap nf (car pl)) - (error (message "Cannot set background pixmap %s" (car pl))))) - (push nf faces) - (setq cl (cdr cl) - pl (cdr pl))) - faces)) +(defvar chart-face-list #'chart--face-list "Faces used to colorize charts. +This should either be a list of faces, or a function that returns +a list of faces. + List is limited currently, which is ok since you really can't display too much in text characters anyways.") +(defun chart--face-list () + (and + (display-color-p) + (let ((cl chart-face-color-list) + (pl chart-face-pixmap-list) + (faces ()) + nf) + (while cl + (setq nf (make-face + (intern (concat "chart-" (car cl) "-" (car pl))))) + (set-face-background nf (if (condition-case nil + (> (x-display-color-cells) 4) + (error t)) + (car cl) + "white")) + (set-face-foreground nf "black") + (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))))) + (push nf faces) + (setq cl (cdr cl) + pl (cdr pl))) + faces))) + (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 ) @@ -190,7 +193,7 @@ Make sure the width/height is correct." ) "Class used to display an axis which represents different named items.") -(defclass chart-sequece () +(defclass chart-sequence () ((data :initarg :data :initform nil) (name :initarg :name @@ -335,7 +338,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) @@ -376,7 +380,10 @@ Optional arguments MARGIN, ZONE, START and END specify boundaries of the drawing (let* ((data (oref c sequences)) (dir (oref c direction)) (odir (if (eq dir 'vertical) 'horizontal 'vertical)) - ) + (faces + (if (functionp chart-face-list) + (funcall chart-face-list) + chart-face-list))) (while data (if (stringp (car (oref (car data) data))) ;; skip string lists... @@ -392,10 +399,9 @@ Optional arguments MARGIN, ZONE, START and END specify boundaries of the drawing (zp (if (eq dir 'vertical) (chart-translate-ypos c 0) (chart-translate-xpos c 0))) - (fc (if chart-face-list - (nth (% i (length chart-face-list)) chart-face-list) - 'default)) - ) + (fc (if faces + (nth (% i (length faces)) faces) + 'default))) (if (< dp zp) (progn (chart-draw-line dir (car rng) dp zp) @@ -585,12 +591,12 @@ SORT-PRED if desired." )) (iv (eq dir 'vertical))) (chart-add-sequence nc - (make-instance 'chart-sequece + (make-instance 'chart-sequence :data namelst :name nametitle) (if iv 'x-axis 'y-axis)) (chart-add-sequence nc - (make-instance 'chart-sequece + (make-instance 'chart-sequence :data numlst :name numtitle) (if iv 'y-axis 'x-axis)) 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..00cc7777e1a 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': @@ -148,13 +147,6 @@ ;; ;; See the above section "Checking Parameters" for details about ;; parameter checking. -;; -;; Dependencies: -;; -;; This file requires lisp-mnt (Lisp maintenance routines) for the -;; comment checkers. -;; -;; Requires custom for Emacs v20. ;;; TO DO: ;; Hook into the byte compiler on a defun/defvar level to generate @@ -168,8 +160,6 @@ ;; not specifically docstring related. Would this even be useful? ;;; Code: -(defvar checkdoc-version "0.6.2" - "Release version of checkdoc you are currently running.") (require 'cl-lib) (require 'help-mode) ;; for help-xref-info-regexp @@ -241,7 +231,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) @@ -933,16 +928,20 @@ don't move point." ;; Don't bug out if the file is empty (or a ;; definition ends prematurely. (end-of-file))) - (`(,(or 'defun 'defvar 'defcustom 'defmacro 'defconst 'defsubst 'defadvice - 'cl-defun 'cl-defgeneric 'cl-defmethod 'cl-defmacro) + (`(,(and (pred symbolp) def + (let (and doc (guard doc)) (function-get def 'doc-string-elt))) ,(pred symbolp) ;; Require an initializer, i.e. ignore single-argument `defvar' ;; forms, which never have a doc string. ,_ . ,_) (down-list) - ;; Skip over function or macro name, symbol to be defined, and - ;; initializer or argument list. - (forward-sexp 3) + ;; Skip over function or macro name. + (forward-sexp 1) + ;; And now skip until the docstring. + (forward-sexp (1- ; We already skipped the function or macro name. + (cond + ((numberp doc) doc) + ((functionp doc) (funcall doc))))) (skip-chars-forward " \n\t") t))) @@ -1243,18 +1242,13 @@ bound to \\<checkdoc-minor-mode-map>\\[checkdoc-eval-defun] and `checkdoc-eval-c checking of documentation strings. \\{checkdoc-minor-mode-map}" - nil checkdoc-minor-mode-string nil + :lighter checkdoc-minor-mode-string :group 'checkdoc) ;;; 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 +1571,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 +1867,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! ))) @@ -2136,8 +2131,8 @@ buffer, otherwise stop after the first error." (user-error "No spellchecker installed: check the variable `ispell-program-name'")) (save-excursion (skip-chars-forward "^a-zA-Z") - (let (word sym case-fold-search err word-beginning word-end) - (while (and (not err) (< (point) end)) + (let (word sym case-fold-search word-beginning word-end) ;; err + (while (and (< (point) end)) ;; (not err) (if (save-excursion (forward-char -1) (looking-at "[('`]")) ;; Skip lists describing meta-syntax, or bound variables (forward-sexp 1) @@ -2169,7 +2164,7 @@ buffer, otherwise stop after the first error." (sit-for 0) (message "Continuing...")))))))) (skip-chars-forward "^a-zA-Z")) - err)))) + nil)))) ;; err ;;; Rogue space checking engine ;; @@ -2361,7 +2356,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 +2380,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 +2589,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 +2639,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." @@ -2709,6 +2706,12 @@ function called to create the messages." (custom-add-option 'emacs-lisp-mode-hook 'checkdoc-minor-mode) +;; Obsolete + +(defvar checkdoc-version "0.6.2" + "Release version of checkdoc you are currently running.") +(make-obsolete-variable 'checkdoc-version 'emacs-version "28.1") + (provide 'checkdoc) ;;; checkdoc.el ends here diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 9c9da4a0f90..eabba27d229 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) @@ -95,7 +94,7 @@ strings case-insensitively." (defun cl--mapcar-many (cl-func cl-seqs &optional acc) (if (cdr (cdr cl-seqs)) (let* ((cl-res nil) - (cl-n (apply 'min (mapcar 'length cl-seqs))) + (cl-n (apply #'min (mapcar #'length cl-seqs))) (cl-i 0) (cl-args (copy-sequence cl-seqs)) cl-p1 cl-p2) @@ -132,7 +131,7 @@ strings case-insensitively." "Map a FUNCTION across one or more SEQUENCEs, returning a sequence. TYPE is the sequence type to return. \n(fn TYPE FUNCTION SEQUENCE...)" - (let ((cl-res (apply 'cl-mapcar cl-func cl-seq cl-rest))) + (let ((cl-res (apply #'cl-mapcar cl-func cl-seq cl-rest))) (and cl-type (cl-coerce cl-res cl-type)))) ;;;###autoload @@ -191,26 +190,29 @@ the elements themselves. "Like `cl-mapcar', but nconc's together the values returned by the function. \n(fn FUNCTION SEQUENCE...)" (if cl-rest - (apply 'nconc (apply 'cl-mapcar cl-func cl-seq cl-rest)) + (apply #'nconc (apply #'cl-mapcar cl-func cl-seq cl-rest)) (mapcan cl-func cl-seq))) ;;;###autoload (defun cl-mapcon (cl-func cl-list &rest cl-rest) "Like `cl-maplist', but nconc's together the values returned by the function. \n(fn FUNCTION LIST...)" - (apply 'nconc (apply 'cl-maplist cl-func cl-list cl-rest))) + (apply #'nconc (apply #'cl-maplist cl-func cl-list cl-rest))) ;;;###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))) @@ -234,27 +236,26 @@ If so, return the true (non-nil) value returned by PREDICATE. (defun cl-notany (cl-pred cl-seq &rest cl-rest) "Return true if PREDICATE is false of every element of SEQ or SEQs. \n(fn PREDICATE SEQ...)" - (not (apply 'cl-some cl-pred cl-seq cl-rest))) + (not (apply #'cl-some cl-pred cl-seq cl-rest))) ;;;###autoload (defun cl-notevery (cl-pred cl-seq &rest cl-rest) "Return true if PREDICATE is false of some element of SEQ or SEQs. \n(fn PREDICATE SEQ...)" - (not (apply 'cl-every cl-pred cl-seq cl-rest))) + (not (apply #'cl-every cl-pred cl-seq cl-rest))) ;;;###autoload (defun cl--map-keymap-recursively (cl-func-rec cl-map &optional cl-base) (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. @@ -693,12 +693,11 @@ PROPLIST is a list of the sort returned by `symbol-plist'. "Expand macros in FORM and insert the pretty-printed result." (declare (advertised-calling-convention (form) "27.1")) (message "Expanding...") - (let ((byte-compile-macro-environment nil)) - (setq form (macroexpand-all form)) - (message "Formatting...") - (prog1 - (cl-prettyprint form) - (message "")))) + (setq form (macroexpand-all form)) + (message "Formatting...") + (prog1 + (cl-prettyprint form) + (message ""))) ;;; Integration into the online help system. @@ -898,8 +897,8 @@ Outputs to the current buffer." (list (cl-prin1-to-string (cl--slot-descriptor-name slot)) (cl-prin1-to-string (cl--slot-descriptor-type slot)) (cl-prin1-to-string (cl--slot-descriptor-initform slot)) - (let ((doc (alist-get :documentation - (cl--slot-descriptor-props slot)))) + (let ((doc (plist-get (cl--slot-descriptor-props slot) + :documentation))) (if (not doc) "" (setq has-doc t) (substitute-command-keys doc))))) @@ -912,6 +911,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..f5b8c7b662f 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -189,6 +189,32 @@ SPECIALIZERS-FUNCTION takes as first argument a tag value TAG (setf (cl--generic name) (setq generic (cl--generic-make name)))) generic)) +(defvar cl--generic-edebug-name nil) + +(defun cl--generic-edebug-remember-name (name pf &rest specs) + ;; Remember the name in `cl-defgeneric' so we can use it when building + ;; the names of its `:methods'. + (let ((cl--generic-edebug-name (car name))) + (funcall pf specs))) + +(defun cl--generic-edebug-make-name (in:method _oldname &rest quals-and-args) + ;; The name to use in Edebug for a method: use the generic + ;; function's name plus all its qualifiers and finish with + ;; its specializers. + (pcase-let* + ((basename (if in:method cl--generic-edebug-name (pop quals-and-args))) + (args (car (last quals-and-args))) + (`(,spec-args . ,_) (cl--generic-split-args args)) + (specializers (mapcar (lambda (spec-arg) + (if (eq '&context (car-safe (car spec-arg))) + spec-arg (cdr spec-arg))) + spec-args))) + (format "%s %s" + (mapconcat (lambda (sexp) (format "%s" sexp)) + (cons basename (butlast quals-and-args)) + " ") + specializers))) + ;;;###autoload (defmacro cl-defgeneric (name args &rest options-and-methods) "Create a generic function NAME. @@ -206,15 +232,22 @@ DEFAULT-BODY, if present, is used as the body of a default method. \(fn NAME ARGS [DOC-STRING] [OPTIONS-AND-METHODS...] &rest DEFAULT-BODY)" (declare (indent 2) (doc-string 3) (debug - (&define [&or name ("setf" name :name setf)] listp - lambda-doc - [&rest [&or - ("declare" &rest sexp) - (":argument-precedence-order" &rest sexp) - (&define ":method" [&rest atom] - cl-generic-method-args lambda-doc - def-body)]] - def-body))) + (&define + &interpose + [&name sexp] ;Allow (setf ...) additionally to symbols. + cl--generic-edebug-remember-name + listp lambda-doc + [&rest [&or + ("declare" &rest sexp) + (":argument-precedence-order" &rest sexp) + (&define ":method" + [&name + [[&rest cl-generic--method-qualifier-p] + listp] ;Formal args + cl--generic-edebug-make-name in:method] + lambda-doc + def-body)]] + def-body))) (let* ((doc (if (stringp (car-safe options-and-methods)) (pop options-and-methods))) (declarations nil) @@ -295,15 +328,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 +390,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)))) @@ -398,18 +422,45 @@ the specializer used will be the one returned by BODY." (let ((combined-doc (buffer-string))) (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc))))) +(defun cl-generic--method-qualifier-p (x) + (not (listp x))) + +(defun cl--defmethod-doc-pos () + "Return the index of the docstring for a `cl-defmethod'. +Presumes point is at the end of the `cl-defmethod' symbol." + (save-excursion + (let ((n 2)) + (while (and (ignore-errors (forward-sexp 1) t) + (not (eq (char-before) ?\)))) + (cl-incf n)) + n))) + ;;;###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 formal argument appears as (VAR TYPE) rather than just VAR. -The optional second argument QUALIFIER is a specifier that -modifies how the method is combined with other methods, including: +The optional EXTRA element, on the form `:extra STRING', allows +you to add more methods for the same specializers and qualifiers. +These are distinguished by STRING. + +The optional argument QUALIFIER is a specifier that modifies how +the method is combined with other methods, including: :before - Method will be called before the primary :after - Method will be called after the primary :around - Method will be called around everything else @@ -426,20 +477,18 @@ method to be applicable. The set of acceptable TYPEs (also called \"specializers\") is defined \(and can be extended) by the various methods of `cl-generic-generalizers'. -\(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)" - (declare (doc-string 3) (indent defun) +\(fn NAME [EXTRA] [QUALIFIER] ARGS &rest [DOCSTRING] BODY)" + (declare (doc-string cl--defmethod-doc-pos) (indent defun) (debug (&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. - cl-generic-method-args ; arguments + [&name [sexp ;Allow (setf ...) additionally to symbols. + [&rest cl-generic--method-qualifier-p] ;qualifiers + listp] ; arguments + cl--generic-edebug-make-name nil] lambda-doc ; documentation string def-body))) ; part to be debugged (let ((qualifiers nil)) - (while (not (listp args)) + (while (cl-generic--method-qualifier-p args) (push args qualifiers) (setq args (pop body))) (when (eq 'setf (car-safe name)) @@ -452,7 +501,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (or (not (fboundp 'byte-compile-warning-enabled-p)) (byte-compile-warning-enabled-p 'obsolete name)) (let* ((obsolete (get name 'byte-obsolete-info))) - (macroexp--warn-and-return + (macroexp-warn-and-return (macroexp--obsolete-warning name obsolete "generic function") nil))) ;; You could argue that `defmethod' modifies rather than defines the @@ -599,11 +648,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 +842,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 +1141,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..c88e15d5a8b 100644 --- a/lisp/emacs-lisp/cl-indent.el +++ b/lisp/emacs-lisp/cl-indent.el @@ -27,7 +27,7 @@ ;; This package supplies a single entry point, common-lisp-indent-function, ;; which performs indentation in the preferred style for Common Lisp code. -;; It is also a suitable function for indenting Emacs lisp code. +;; It is also a suitable function for indenting Emacs Lisp code. ;; ;; To enable it: ;; @@ -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..7f7eb963423 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -140,7 +140,7 @@ to an element already in the list stored in PLACE. \n(fn X PLACE [KEYWORD VALUE]...)" (declare (debug (form place &rest - &or [[&or ":test" ":test-not" ":key"] function-form] + &or [[&or ":test" ":test-not" ":key"] form] [keywordp form]))) (if (symbolp place) (if (null keys) @@ -232,13 +232,8 @@ one value. ;;; Declarations. -(defvar cl--compiling-file nil) -(defun cl--compiling-file () - (or cl--compiling-file - (and (boundp 'byte-compile--outbuffer) - (bufferp (symbol-value 'byte-compile--outbuffer)) - (equal (buffer-name (symbol-value 'byte-compile--outbuffer)) - " *Compiler Output*")))) +(define-obsolete-function-alias 'cl--compiling-file + #'macroexp-compiling-p "28.1") (defvar cl--proclaims-deferred nil) @@ -253,7 +248,7 @@ one value. Puts `(cl-eval-when (compile load eval) ...)' around the declarations so that they are registered at compile-time as well as run-time." (let ((body (mapcar (lambda (x) `(cl-proclaim ',x)) specs))) - (if (cl--compiling-file) `(cl-eval-when (compile load eval) ,@body) + (if (macroexp-compiling-p) `(cl-eval-when (compile load eval) ,@body) `(progn ,@body)))) ; Avoid loading cl-macs.el for cl-eval-when. @@ -619,8 +614,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 +658,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..b7e5be95bc3 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 @@ -186,43 +186,43 @@ The name is made by appending a number to PREFIX, default \"T\"." ;;; Program structure. -(def-edebug-spec cl-declarations - (&rest ("cl-declare" &rest sexp))) +(def-edebug-elem-spec 'cl-declarations + '(&rest ("cl-declare" &rest sexp))) -(def-edebug-spec cl-declarations-or-string - (&or lambda-doc cl-declarations)) +(def-edebug-elem-spec 'cl-declarations-or-string + '(lambda-doc &or ("declare" def-declarations) cl-declarations)) -(def-edebug-spec cl-lambda-list - (([&rest cl-lambda-arg] +(def-edebug-elem-spec 'cl-lambda-list + '(([&rest cl-lambda-arg] [&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]] [&optional ["&rest" cl-lambda-arg]] [&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 - (&or (cl-lambda-arg &optional def-form arg) arg)) +(def-edebug-elem-spec 'cl-&optional-arg + '(&or (cl-lambda-arg &optional def-form arg) arg)) -(def-edebug-spec cl-&key-arg - (&or ([&or (symbolp cl-lambda-arg) arg] &optional def-form arg) arg)) +(def-edebug-elem-spec 'cl-&key-arg + '(&or ([&or (symbolp cl-lambda-arg) arg] &optional def-form arg) arg)) -(def-edebug-spec cl-lambda-arg - (&or arg cl-lambda-list1)) +(def-edebug-elem-spec 'cl-lambda-arg + '(&or arg cl-lambda-list1)) -(def-edebug-spec cl-lambda-list1 - (([&optional ["&whole" arg]] ;; only allowed at lower levels - [&rest cl-lambda-arg] - [&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]] - [&optional ["&rest" cl-lambda-arg]] - [&optional ["&key" cl-&key-arg &rest cl-&key-arg - &optional "&allow-other-keys"]] - [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] - . [&or arg nil]))) +(def-edebug-elem-spec 'cl-lambda-list1 + '(([&optional ["&whole" arg]] ;; only allowed at lower levels + [&rest cl-lambda-arg] + [&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]] + [&optional ["&rest" cl-lambda-arg]] + [&optional ["&key" cl-&key-arg &rest cl-&key-arg + &optional "&allow-other-keys"]] + [&optional ["&aux" &rest + &or (cl-lambda-arg &optional def-form) arg]] + . [&or arg nil]))) -(def-edebug-spec cl-type-spec sexp) +(def-edebug-elem-spec 'cl-type-spec '(sexp)) (defconst cl--lambda-list-keywords '(&optional &rest &key &allow-other-keys &aux &whole &body &environment)) @@ -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 @@ -359,16 +358,14 @@ more details. \(fn NAME ARGLIST [DOCSTRING] BODY...)" (declare (debug ;; Same as defun but use cl-lambda-list. - (&define [&or name ("setf" :name setf name)] + (&define [&name sexp] ;Allow (setf ...) additionally to symbols. cl-lambda-list cl-declarations-or-string [&optional ("interactive" interactive)] 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) @@ -379,7 +376,7 @@ and BODY is implicitly surrounded by (cl-block NAME ...). \(fn NAME ARGLIST [DOCSTRING] BODY...)" (declare (debug ;; Same as iter-defun but use cl-lambda-list. - (&define [&or name ("setf" :name setf name)] + (&define [&name sexp] ;Allow (setf ...) additionally to symbols. cl-lambda-list cl-declarations-or-string [&optional ("interactive" interactive)] @@ -387,47 +384,45 @@ 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 ;; top level list. -(def-edebug-spec cl-macro-list - (([&optional "&environment" arg] - [&rest cl-macro-arg] - [&optional ["&optional" &rest - &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] - [&optional [[&or "&rest" "&body"] cl-macro-arg]] - [&optional ["&key" [&rest - [&or ([&or (symbolp cl-macro-arg) arg] - &optional def-form cl-macro-arg) - arg]] - &optional "&allow-other-keys"]] - [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] - [&optional "&environment" arg] - ))) - -(def-edebug-spec cl-macro-arg - (&or arg cl-macro-list1)) - -(def-edebug-spec cl-macro-list1 - (([&optional "&whole" arg] ;; only allowed at lower levels - [&rest cl-macro-arg] - [&optional ["&optional" &rest - &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] - [&optional [[&or "&rest" "&body"] cl-macro-arg]] - [&optional ["&key" [&rest - [&or ([&or (symbolp cl-macro-arg) arg] - &optional def-form cl-macro-arg) - arg]] - &optional "&allow-other-keys"]] - [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] - . [&or arg nil]))) +(def-edebug-elem-spec 'cl-macro-list + '(([&optional "&environment" arg] + [&rest cl-macro-arg] + [&optional ["&optional" &rest + &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] + [&optional [[&or "&rest" "&body"] cl-macro-arg]] + [&optional ["&key" [&rest + [&or ([&or (symbolp cl-macro-arg) arg] + &optional def-form cl-macro-arg) + arg]] + &optional "&allow-other-keys"]] + [&optional ["&aux" &rest + &or (cl-macro-arg &optional def-form) arg]] + [&optional "&environment" arg] + ))) + +(def-edebug-elem-spec 'cl-macro-arg + '(&or arg cl-macro-list1)) + +(def-edebug-elem-spec 'cl-macro-list1 + '(([&optional "&whole" arg] ;; only allowed at lower levels + [&rest cl-macro-arg] + [&optional ["&optional" &rest + &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] + [&optional [[&or "&rest" "&body"] cl-macro-arg]] + [&optional ["&key" [&rest + [&or ([&or (symbolp cl-macro-arg) arg] + &optional def-form cl-macro-arg) + arg]] + &optional "&allow-other-keys"]] + [&optional ["&aux" &rest + &or (cl-macro-arg &optional def-form) arg]] + . [&or arg nil]))) ;;;###autoload (defmacro cl-defmacro (name args &rest body) @@ -455,23 +450,21 @@ 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 - cl-declarations-or-string - [&optional ("interactive" interactive)] - def-body))) +(def-edebug-elem-spec 'cl-lambda-expr + '(&define ("lambda" cl-lambda-list + cl-declarations-or-string + [&optional ("interactive" interactive)] + def-body))) ;; Redefine function-form to also match cl-function -(def-edebug-spec function-form +(def-edebug-elem-spec 'function-form ;; form at the end could also handle "function", ;; but recognize it specially to avoid wrapping function forms. - (&or ([&or "quote" "function"] &or symbolp lambda-expr) - ("cl-function" cl-function) - form)) + '(&or ([&or "quote" "function"] &or symbolp lambda-expr) + ("cl-function" cl-function) + form)) ;;;###autoload (defmacro cl-function (func) @@ -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) @@ -554,7 +545,7 @@ its argument list allows full Common Lisp conventions." (let ((p (memq '&body args))) (if p (setcar p '&rest))) (if (memq '&environment args) (error "&environment used incorrectly")) (let ((restarg (memq '&rest args)) - (safety (if (cl--compiling-file) cl--optimize-safety 3)) + (safety (if (macroexp-compiling-p) cl--optimize-safety 3)) (keys t) (laterarg nil) (exactarg nil) minarg) (or num (setq num 0)) @@ -574,7 +565,7 @@ its argument list allows full Common Lisp conventions." ,(length (cl-ldiff args p))) exactarg (not (eq args p))))) (while (and args (not (memq (car args) cl--lambda-list-keywords))) - (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car) + (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car-safe) restarg))) (cl--do-arglist (pop args) @@ -718,36 +709,36 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level. \(fn (WHEN...) BODY...)" (declare (indent 1) (debug (sexp body))) - (if (and (fboundp 'cl--compiling-file) (cl--compiling-file) + (if (and (macroexp-compiling-p) (not cl--not-toplevel) (not (boundp 'for-effect))) ;Horrible kludge. (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)))) (defun cl--compile-time-too (form) (or (and (symbolp (car-safe form)) (get (car-safe form) 'byte-hunk-handler)) (setq form (macroexpand - form (cons '(cl-eval-when) byte-compile-macro-environment)))) + form (cons '(cl-eval-when) macroexpand-all-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) "Like `progn', but evaluates the body at load time. The result of the body appears to the compiler as a quoted constant." (declare (debug (form &optional sexp))) - (if (cl--compiling-file) + (if (macroexp-compiling-p) (let* ((temp (cl-gentemp "--cl-load-time--")) (set `(setq ,temp ,form))) (if (and (fboundp 'byte-compile-file-form-defmumble) @@ -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 @@ -1052,20 +1051,20 @@ For more details, see Info node `(cl)Loop Facility'. ;; [&rest loop-clause] ;; )) -;; (def-edebug-spec loop-with -;; ("with" loop-var +;; (def-edebug-elem-spec 'loop-with +;; '("with" loop-var ;; loop-type-spec ;; [&optional ["=" form]] ;; &rest ["and" loop-var ;; loop-type-spec ;; [&optional ["=" form]]])) -;; (def-edebug-spec loop-for-as -;; ([&or "for" "as"] loop-for-as-subclause +;; (def-edebug-elem-spec 'loop-for-as +;; '([&or "for" "as"] loop-for-as-subclause ;; &rest ["and" loop-for-as-subclause])) -;; (def-edebug-spec loop-for-as-subclause -;; (loop-var +;; (def-edebug-elem-spec 'loop-for-as-subclause +;; '(loop-var ;; loop-type-spec ;; &or ;; [[&or "in" "on" "in-ref" "across-ref"] @@ -1125,19 +1124,19 @@ For more details, see Info node `(cl)Loop Facility'. ;; [&optional ["by" form]] ;; ])) -;; (def-edebug-spec loop-initial-final -;; (&or ["initially" +;; (def-edebug-elem-spec 'loop-initial-final +;; '(&or ["initially" ;; ;; [&optional &or "do" "doing"] ;; CLtL2 doesn't allow this. ;; &rest loop-non-atomic-expr] ;; ["finally" &or ;; [[&optional &or "do" "doing"] &rest loop-non-atomic-expr] ;; ["return" form]])) -;; (def-edebug-spec loop-and-clause -;; (loop-clause &rest ["and" loop-clause])) +;; (def-edebug-elem-spec 'loop-and-clause +;; '(loop-clause &rest ["and" loop-clause])) -;; (def-edebug-spec loop-clause -;; (&or +;; (def-edebug-elem-spec 'loop-clause +;; '(&or ;; [[&or "while" "until" "always" "never" "thereis"] form] ;; [[&or "collect" "collecting" @@ -1164,10 +1163,10 @@ For more details, see Info node `(cl)Loop Facility'. ;; loop-initial-final ;; )) -;; (def-edebug-spec loop-non-atomic-expr -;; ([¬ atom] form)) +;; (def-edebug-elem-spec 'loop-non-atomic-expr +;; '([¬ atom] form)) -;; (def-edebug-spec loop-var +;; (def-edebug-elem-spec 'loop-var ;; ;; The symbolp must be last alternative to recognize e.g. (a b . c) ;; ;; loop-var => ;; ;; (loop-var . [&or nil loop-var]) @@ -1176,15 +1175,13 @@ For more details, see Info node `(cl)Loop Facility'. ;; ;; (symbolp . (symbolp . [&or nil loop-var])) ;; ;; (symbolp . (symbolp . loop-var)) ;; ;; (symbolp . (symbolp . symbolp)) == (symbolp symbolp . symbolp) -;; (&or (loop-var . [&or nil loop-var]) [gate symbolp])) - -;; (def-edebug-spec loop-type-spec -;; (&optional ["of-type" loop-d-type-spec])) - -;; (def-edebug-spec loop-d-type-spec -;; (&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec)) +;; '(&or (loop-var . [&or nil loop-var]) [gate symbolp])) +;; (def-edebug-elem-spec 'loop-type-spec +;; '(&optional ["of-type" loop-d-type-spec])) +;; (def-edebug-elem-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)) @@ -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 @@ -1984,7 +1976,8 @@ a `let' form, except that the list of symbols can be computed at run-time." (,binds ())) (while ,syms (push (list (pop ,syms) (list 'quote (pop ,vals))) ,binds)) - (eval (list 'let ,binds (list 'funcall (list 'quote ,bodyfun)))))))) + (eval (list 'let (nreverse ,binds) + (list 'funcall (list 'quote ,bodyfun)))))))) (defconst cl--labels-magic (make-symbol "cl--labels-magic")) @@ -2024,7 +2017,13 @@ 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 (symbolp form) + (&define [&name symbolp "@cl-flet@"] + [&name [] gensym] ;Make it unique! + 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 +2062,120 @@ 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. + ;; This var always holds the value `nil' until (just before) we + ;; exit the loop. + (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))) + (`(and . ,exps) `(and . ,(funcall opt-exps exps))) + (`(or ,arg) (funcall opt arg)) + (`(or ,arg . ,args) + (let ((val (make-symbol "val"))) + `(let ((,val ,arg)) + (if ,val ,(funcall opt val) ,(funcall opt `(or . ,args)))))) + (`(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. + ;; Note: This may set the var before we + ;; actually exit the loop, but luckily it's + ;; only the case if we set the var to nil, + ;; so it does preserve the invariant that + ;; the var is nil until we exit the loop. + `((setq ,retvar ,exp) nil) + `(,(funcall opt exp))) + cs)) + (exps + (push (funcall opt-exps exps) cs)))) + ;; No need to set `retvar' to return nil. + `(cond . ,(nreverse cs)))) + ((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))) + ((and `(condition-case ,err-var ,bodyform . ,handlers) + (guard (not (eq err-var var)))) + `(condition-case ,err-var + ,(if (assq :success handlers) + bodyform + `(progn (setq ,retvar ,bodyform) nil)) + . ,(mapcar (lambda (h) + (cons (car h) (funcall opt-exps (cdr h)))) + handlers))) + ('nil nil) ;No need to set `retvar' to return nil. + (_ `(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 +2187,47 @@ 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))))) + +(defvar edebug-lexical-macro-ctx) + +(defun cl--edebug-macrolet-interposer (bindings pf &rest specs) + ;; (cl-assert (null (cdr bindings))) + (setq bindings (car bindings)) + (let ((edebug-lexical-macro-ctx + (nconc (mapcar (lambda (binding) + (cons (car binding) + (when (eq 'declare (car-safe (nth 2 binding))) + (nth 1 (assq 'debug (cdr (nth 2 binding))))))) + bindings) + edebug-lexical-macro-ctx))) + (funcall pf specs))) ;; The following ought to have a better definition for use with newer ;; byte compilers. @@ -2099,16 +2238,21 @@ This is like `cl-flet', but for macros instead of functions. \(fn ((NAME ARGLIST BODY...) ...) FORM...)" (declare (indent 1) - (debug (cl-macrolet-expr))) + (debug (&interpose (&rest (&define [&name symbolp "@cl-macrolet@"] + [&name [] gensym] ;Make it unique! + cl-macro-list + cl-declarations-or-string + def-body)) + cl--edebug-macrolet-interposer + cl-declarations body))) (if (cdr bindings) `(cl-macrolet (,(car bindings)) (cl-macrolet ,(cdr bindings) ,@body)) (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) @@ -2153,7 +2297,7 @@ of `cl-symbol-macrolet' to additionally expand symbol macros." ;; on this behavior (haven't found any yet). ;; Such code should explicitly use `cl-letf' instead, I think. ;; - ;; (`(,(or `let `let*) . ,(or `(,bindings . ,body) dontcare)) + ;; (`(,(or `let `let*) . ,(or `(,bindings . ,body) pcase--dontcare)) ;; (let ((letf nil) (found nil) (nbs ())) ;; (dolist (binding bindings) ;; (let* ((var (if (symbolp binding) binding (car binding))) @@ -2176,7 +2320,7 @@ of `cl-symbol-macrolet' to additionally expand symbol macros." ;; The behavior of CL made sense in a dynamically scoped ;; language, but nowadays, lexical scoping semantics is more often ;; expected. - (`(,(or 'let 'let*) . ,(or `(,bindings . ,body) dontcare)) + (`(,(or 'let 'let*) . ,(or `(,bindings . ,body) pcase--dontcare)) (let ((nbs ()) (found nil)) (dolist (binding bindings) (let* ((var (if (symbolp binding) binding (car binding))) @@ -2271,7 +2415,7 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). (append bindings venv)) macroexpand-all-environment)))) (if malformed-bindings - (macroexp--warn-and-return + (macroexp-warn-and-return (format-message "Malformed `cl-symbol-macrolet' binding(s): %S" (nreverse malformed-bindings)) expansion) @@ -2333,7 +2477,7 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). (defmacro cl-the (type form) "Return FORM. If type-checking is enabled, assert that it is of TYPE." (declare (indent 1) (debug (cl-type-spec form))) - (if (not (or (not (cl--compiling-file)) + (if (not (or (not (macroexp-compiling-p)) (< cl--optimize-speed 3) (= cl--optimize-safety 3))) form @@ -2359,12 +2503,12 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). '(nil byte-compile-inline-expand)) (error "%s already has a byte-optimizer, can't make it inline" (car spec))) - (put (car spec) 'byte-optimizer 'byte-compile-inline-expand))) + (put (car spec) 'byte-optimizer #'byte-compile-inline-expand))) ((eq (car-safe spec) 'notinline) (while (setq spec (cdr spec)) (if (eq (get (car spec) 'byte-optimizer) - 'byte-compile-inline-expand) + #'byte-compile-inline-expand) (put (car spec) 'byte-optimizer nil)))) ((eq (car-safe spec) 'optimize) @@ -2400,7 +2544,7 @@ For instance will turn off byte-compile warnings in the function. See Info node `(cl)Declarations' for details." - (if (cl--compiling-file) + (if (macroexp-compiling-p) (while specs (if (listp cl--declare-stack) (push (car specs) cl--declare-stack)) (cl--do-proclaim (pop specs) nil))) @@ -2472,7 +2616,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 +2847,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. @@ -2737,7 +2881,7 @@ Supported keywords for slots are: (copier (intern (format "copy-%s" name))) (predicate (intern (format "%s-p" name))) (print-func nil) (print-auto nil) - (safety (if (cl--compiling-file) cl--optimize-safety 3)) + (safety (if (macroexp-compiling-p) cl--optimize-safety 3)) (include nil) ;; There are 4 types of structs: ;; - `vector' type: means we should use a vector, which can come @@ -2767,7 +2911,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 +2938,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 +3015,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)) @@ -2909,7 +3054,7 @@ Supported keywords for slots are: forms) (when (cl-oddp (length desc)) (push - (macroexp--warn-and-return + (macroexp-warn-and-return (format "Missing value for option `%S' of slot `%s' in struct %s!" (car (last desc)) slot name) 'nil) @@ -2918,7 +3063,7 @@ Supported keywords for slots are: (not (keywordp (car desc)))) (let ((kw (car defaults))) (push - (macroexp--warn-and-return + (macroexp-warn-and-return (format " I'll take `%s' to be an option rather than a default value." kw) 'nil) @@ -2971,15 +3116,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 @@ -3122,23 +3279,44 @@ does not contain SLOT-NAME." (signal 'cl-struct-unknown-slot (list struct-type slot-name)))) (defvar byte-compile-function-environment) -(defvar byte-compile-macro-environment) (defun cl--macroexp-fboundp (sym) "Return non-nil if SYM will be bound when we run the code. Of course, we really can't know that for sure, so it's just a heuristic." (or (fboundp sym) - (and (cl--compiling-file) + (and (macroexp-compiling-p) (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) - + (cdr (assq sym macroexpand-all-environment)))))) + +(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) @@ -3202,12 +3380,15 @@ Of course, we really can't know that for sure, so it's just a heuristic." "Verify that FORM is of type TYPE; signal an error if not. STRING is an optional description of the desired type." (declare (debug (place cl-type-spec &optional stringp))) - (and (or (not (cl--compiling-file)) + (and (or (not (macroexp-compiling-p)) (< cl--optimize-speed 3) (= cl--optimize-safety 3)) (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 @@ -3219,7 +3400,7 @@ Other args STRING and ARGS... are arguments to be passed to `error'. They are not evaluated unless the assertion fails. If STRING is omitted, a default message listing FORM itself is used." (declare (debug (form &rest form))) - (and (or (not (cl--compiling-file)) + (and (or (not (macroexp-compiling-p)) (< cl--optimize-speed 3) (= cl--optimize-safety 3)) (let ((sargs (and show-args (delq nil (mapcar (lambda (x) @@ -3349,8 +3530,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 +3576,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..b2d54c77feb 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." @@ -322,7 +321,7 @@ the debugger will not be entered." (make-obsolete 'debugger-insert-backtrace "use a `backtrace-mode' buffer or `backtrace-to-string'." - "Emacs 27.1") + "27.1") (defun debugger-insert-backtrace (frames do-xrefs) "Format and insert the backtrace FRAMES at point. @@ -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..43d6dfd3c81 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, @@ -141,6 +141,9 @@ KEYWORD-ARGS: :after-hook FORM A single lisp form which is evaluated after the mode hooks have been run. It should not be quoted. + :interactive BOOLEAN + Whether the derived mode should be `interactive' or not. + The default is t. BODY: forms to execute just before running the hooks for the new mode. Do not use `interactive' here. @@ -194,6 +197,7 @@ See Info node `(elisp)Derived Modes' for more details. (declare-syntax t) (hook (derived-mode-hook-name child)) (group nil) + (interactive t) (after-hook nil)) ;; Process the keyword args. @@ -203,6 +207,7 @@ See Info node `(elisp)Derived Modes' for more details. (:abbrev-table (setq abbrev (pop body)) (setq declare-abbrev nil)) (:syntax-table (setq syntax (pop body)) (setq declare-syntax nil)) (:after-hook (setq after-hook (pop body))) + (:interactive (setq interactive (pop body))) (_ (pop body)))) (setq docstring (derived-mode-make-docstring @@ -246,7 +251,7 @@ No problems result if this variable is not bound. (defun ,child () ,docstring - (interactive) + ,(and interactive '(interactive)) ; Run the parent. (delay-mode-hooks @@ -306,11 +311,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 +343,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 +373,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..e23ff5ae513 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. @@ -133,42 +139,35 @@ documenting what its argument does. If the word \"ARG\" does not appear in DOC, a paragraph is added to DOC explaining usage of the mode argument. -Optional INIT-VALUE is the initial value of the mode's variable. - Note that the minor mode function won't be called by setting - this option, so the value *reflects* the minor mode's natural - initial state, rather than *setting* it. - In the vast majority of cases it should be nil. -Optional LIGHTER is displayed in the mode line when the mode is on. -Optional KEYMAP is the default keymap bound to the mode keymap. - If non-nil, it should be a variable name (whose value is a keymap), - or an expression that returns either a keymap or a list of - (KEY . BINDING) pairs where KEY and BINDING are suitable for - `define-key'. If you supply a KEYMAP argument that is not a - symbol, this macro defines the variable MODE-map and gives it - the value that KEYMAP specifies. - BODY contains code to execute each time the mode is enabled or disabled. It is executed after toggling the mode, and before running MODE-hook. Before the actual body code, you can write keyword arguments, i.e. alternating keywords and values. If you provide BODY, then you must - provide (even if just nil) INIT-VALUE, LIGHTER, and KEYMAP, or provide - at least one keyword argument, or both; otherwise, BODY would be - misinterpreted as the first omitted argument. The following special + provide at least one keyword argument. The following special keywords are supported (other keywords are passed to `defcustom' if 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. -:init-value VAL Same as the INIT-VALUE argument. +:init-value VAL the initial value of the mode's variable. + Note that the minor mode function won't be called by setting + this option, so the value *reflects* the minor mode's natural + initial state, rather than *setting* it. + In the vast majority of cases it should be nil. Not used if you also specify :variable. -:lighter SPEC Same as the LIGHTER argument. -:keymap MAP Same as the KEYMAP argument. -:require SYM Same as in `defcustom'. +:lighter SPEC Text displayed in the mode line when the mode is on. +:keymap MAP Keymap bound to the mode keymap. Defaults to `MODE-map'. + If non-nil, it should be a variable name (whose value is + a keymap), or an expression that returns either a keymap or + a list of (KEY . BINDING) pairs where KEY and BINDING are + suitable for `define-key'. If you supply a KEYMAP argument + that is not a symbol, this macro defines the variable MODE-map + and gives it the value that KEYMAP specifies. +:interactive VAL Whether this mode should be a command or not. The default + is to make it one; use nil to avoid that. If VAL is a list, + it's interpreted as a list of major modes this minor mode + is useful in. :variable PLACE The location to use instead of the variable MODE to store the state of the mode. This can be simply a different named variable, or a generalized variable. @@ -178,15 +177,18 @@ BODY contains code to execute each time the mode is enabled or disabled. sets it. If you specify a :variable, this function does not define a MODE variable (nor any of the terms used in :variable). - :after-hook A single lisp form which is evaluated after the mode hooks have been run. It should not be quoted. For example, you could write (define-minor-mode foo-mode \"If enabled, foo on you!\" :lighter \" Foo\" :require \\='foo :global t :group \\='hassle :version \"27.5\" - ...BODY CODE...)" + ...BODY CODE...) + +For backward compatibility with the Emacs<21 calling convention, +BODY can also start with the triplet INIT-VALUE LIGHTER KEYMAP." (declare (doc-string 2) + (advertised-calling-convention (mode doc &rest body) "28.1") (debug (&define name string-or-null-p [&optional [¬ keywordp] sexp &optional [¬ keywordp] sexp @@ -194,23 +196,12 @@ For example, you could write [&rest [keywordp sexp]] def-body))) - ;; Allow skipping the first three args. - (cond - ((keywordp init-value) - (setq body (if keymap `(,init-value ,lighter ,keymap ,@body) - `(,init-value ,lighter)) - init-value nil lighter nil keymap nil)) - ((keywordp lighter) - (setq body `(,lighter ,keymap ,@body) lighter nil keymap nil)) - ((keywordp keymap) (push keymap body) (setq keymap nil))) - (let* ((last-message (make-symbol "last-message")) (mode-name (symbol-name mode)) - (pretty-name (easy-mmode-pretty-mode-name mode lighter)) + (pretty-name nil) (globalp nil) (set nil) (initialize nil) - (group nil) (type nil) (extra-args nil) (extra-keywords nil) @@ -218,13 +209,28 @@ For example, you could write (setter `(setq ,mode)) ;The beginning of the exp to set the mode var. (getter mode) ;The exp to get the mode value. (modefun mode) ;The minor mode function name we're defining. - (require t) (after-hook nil) (hook (intern (concat mode-name "-hook"))) (hook-on (intern (concat mode-name "-on-hook"))) (hook-off (intern (concat mode-name "-off-hook"))) + (interactive t) + (warnwrap (if (keywordp init-value) #'identity + (lambda (exp) + (macroexp-warn-and-return + "Use keywords rather than deprecated positional arguments to `define-minor-mode'" + exp)))) keyw keymap-sym tmp) + ;; Allow skipping the first three args. + (cond + ((keywordp init-value) + (setq body (if keymap `(,init-value ,lighter ,keymap ,@body) + `(,init-value ,lighter)) + init-value nil lighter nil keymap nil)) + ((keywordp lighter) + (setq body `(,lighter ,keymap ,@body) lighter nil keymap nil)) + ((keywordp keymap) (push keymap body) (setq keymap nil))) + ;; Check keys. (while (keywordp (setq keyw (car body))) (setq body (cdr body)) @@ -238,10 +244,9 @@ For example, you could write (:extra-args (setq extra-args (pop body))) (:set (setq set (list :set (pop body)))) (:initialize (setq initialize (list :initialize (pop body)))) - (:group (setq group (nconc group (list :group (pop body))))) (:type (setq type (list :type (pop body)))) - (:require (setq require (pop body))) (:keymap (setq keymap (pop body))) + (:interactive (setq interactive (pop body))) (:variable (setq variable (pop body)) (if (not (and (setq tmp (cdr-safe variable)) (or (symbolp tmp) @@ -255,6 +260,7 @@ For example, you could write (:after-hook (setq after-hook (pop body))) (_ (push keyw extra-keywords) (push (pop body) extra-keywords)))) + (setq pretty-name (easy-mmode-pretty-mode-name mode lighter)) (setq keymap-sym (if (and keymap (symbolp keymap)) keymap (intern (concat mode-name "-map")))) @@ -263,12 +269,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 +281,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. @@ -297,42 +298,72 @@ or call the function `%s'.")))) ,(format base-doc-string pretty-name mode mode) ,@set ,@initialize - ,@group ,@type - ,@(unless (eq require t) `(:require ,require)) ,@(nreverse extra-keywords))))) ;; The actual function. - (defun ,modefun (&optional arg ,@extra-args) - ,(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))) - (let ((,last-message (current-message))) - (,@setter - (if (eq arg 'toggle) - (not ,getter) - ;; A nil argument also means ON now. - (> (prefix-numeric-value arg) 0))) - ,@body - ;; The on/off hooks are here for backward compatibility only. - (run-hooks ',hook (if ,getter ',hook-on ',hook-off)) - (if (called-interactively-p 'any) - (progn - ,(if (and globalp (not variable)) - `(customize-mark-as-set ',mode)) - ;; Avoid overwriting a message shown by the body, - ;; but do overwrite previous messages. - (unless (and (current-message) - (not (equal ,last-message - (current-message)))) - (let ((local ,(if globalp "" " in current buffer"))) - (message ,(format "%s %%sabled%%s" pretty-name) - (if ,getter "en" "dis") local))))) - ,@(when after-hook `(,after-hook))) - (force-mode-line-update) - ;; Return the new setting. - ,getter) + ,(funcall + warnwrap + `(defun ,modefun (&optional arg ,@extra-args) + ,(easy-mmode--mode-docstring doc pretty-name keymap-sym) + ,(when interactive + ;; Use `toggle' rather than (if ,mode 0 1) so that using + ;; repeat-command still does the toggling correctly. + (if (consp interactive) + `(interactive + (list (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + 'toggle)) + ,@interactive) + '(interactive + (list (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + 'toggle))))) + (let ((,last-message (current-message))) + (,@setter + (cond ((eq arg 'toggle) + (not ,getter)) + ((and (numberp arg) + (< arg 1)) + nil) + (t + t))) + ;; Keep minor modes list up to date. + ,@(if globalp + ;; When running this byte-compiled code in earlier + ;; Emacs versions, these variables may not be defined + ;; there. So check defensively, even if they're + ;; always defined in Emacs 28 and up. + `((when (boundp 'global-minor-modes) + (setq global-minor-modes + (delq ',modefun global-minor-modes)) + (when ,getter + (push ',modefun global-minor-modes)))) + ;; Ditto check. + `((when (boundp 'local-minor-modes) + (setq local-minor-modes + (delq ',modefun local-minor-modes)) + (when ,getter + (push ',modefun local-minor-modes))))) + ,@body + ;; The on/off hooks are here for backward compatibility only. + (run-hooks ',hook (if ,getter ',hook-on ',hook-off)) + (if (called-interactively-p 'any) + (progn + ,(if (and globalp (not variable)) + `(customize-mark-as-set ',mode)) + ;; Avoid overwriting a message shown by the body, + ;; but do overwrite previous messages. + (unless (and (current-message) + (not (equal ,last-message + (current-message)))) + (let ((local ,(if globalp "" " in current buffer"))) + (message ,(format "%s %%sabled%%s" pretty-name) + (if ,getter "en" "dis") local))))) + ,@(when after-hook `(,after-hook))) + (force-mode-line-update) + ;; Return the new setting. + ,getter)) ;; Autoloading a define-minor-mode autoloads everything ;; up-to-here. @@ -345,6 +376,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 +412,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 @@ -409,6 +446,7 @@ on if the hook has explicitly disabled it. (pretty-global-name (easy-mmode-pretty-mode-name global-mode)) (group nil) (extra-keywords nil) + (MODE-variable mode) (MODE-buffers (intern (concat global-mode-name "-buffers"))) (MODE-enable-in-buffers (intern (concat global-mode-name "-enable-in-buffers"))) @@ -418,7 +456,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 +468,42 @@ on if the hook has explicitly disabled it. (pcase keyw (:group (setq group (nconc group (list :group (pop body))))) (:global (pop body)) + (:variable (setq MODE-variable (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 +519,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 @@ -497,11 +571,11 @@ See `%s' for more information on %s." (with-current-buffer buf (unless ,MODE-set-explicitly (unless (eq ,MODE-major-mode major-mode) - (if ,mode + (if ,MODE-variable (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 +590,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..f6661541a16 100644 --- a/lisp/emacs-lisp/easymenu.el +++ b/lisp/emacs-lisp/easymenu.el @@ -23,26 +23,18 @@ ;;; Commentary: +;; The `easy-menu-define' macro provides a convenient way to define +;; pop-up menus and/or menu bar menus. +;; ;; This is compatible with easymenu.el by Per Abrahamsen ;; but it is much simpler as it doesn't try to support other Emacs versions. ;; The code was mostly derived from lmenu.el. ;;; 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)) -;;;###autoload (defmacro easy-menu-define (symbol maps doc menu) "Define a pop-up menu and/or menu bar menu specified by MENU. If SYMBOL is non-nil, define SYMBOL as a function to pop up the @@ -150,7 +142,7 @@ solely of dashes is displayed as a menu separator. Alternatively, a menu item can be a list with the same format as MENU. This is a submenu." - (declare (indent defun) (debug (symbolp body))) + (declare (indent defun) (debug (symbolp body)) (doc-string 3)) `(progn ,(if symbol `(defvar ,symbol nil ,doc)) (easy-menu-do-define (quote ,symbol) ,maps ,doc ,menu))) @@ -173,7 +165,6 @@ This is expected to be bound to a mouse event." "")) (cons menu props))))) -;;;###autoload (defun easy-menu-do-define (symbol maps doc menu) ;; We can't do anything that might differ between Emacs dialects in ;; `easy-menu-define' in order to make byte compiled files @@ -191,12 +182,19 @@ This is expected to be bound to a mouse event." (funcall (or (plist-get (get symbol 'menu-prop) :filter) - 'identity) + #'identity) (symbol-function symbol))) - symbol))))) + symbol)))) + ;; These symbols are commands, but not interesting for users + ;; to `M-x TAB'. + (function-put symbol 'completion-predicate #'ignore)) (dolist (map (if (keymapp maps) (list maps) maps)) (define-key map - (vector 'menu-bar (easy-menu-intern (car menu))) + (vector 'menu-bar (if (symbolp (car menu)) + (car menu) + ;; If a string, then use the downcased + ;; version for greater backwards compatibility. + (intern (downcase (car menu))))) (easy-menu-binding keymap (car menu)))))) (defun easy-menu-filter-return (menu &optional name) @@ -222,7 +220,6 @@ If NAME is provided, it is used for the keymap." If it holds a list, this is expected to be a list of keys already seen in the menu we're processing. Else it means we're not processing a menu.") -;;;###autoload (defun easy-menu-create-menu (menu-name menu-items) "Create a menu called MENU-NAME with items described in MENU-ITEMS. MENU-NAME is a string, the name of the menu. MENU-ITEMS is a list of items @@ -478,7 +475,6 @@ When non-nil, NOEXP indicates that CALLBACK cannot be an expression (eval `(lambda () (interactive) ,callback) t))) command)) -;;;###autoload (defun easy-menu-change (path name items &optional before map) "Change menu found at PATH as item NAME to contain ITEMS. PATH is a list of strings for locating the menu that @@ -498,15 +494,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 +(defalias 'easy-menu-remove #'ignore "Remove MENU from the current menu bar. Contrary to XEmacs, this is a nop on Emacs since menus are automatically \(de)activated when the corresponding keymap is (de)activated. \(fn MENU)") +(make-obsolete 'easy-menu-remove "this was always a no-op in Emacs \ +and can be safely removed." "28.1") (defalias 'easy-menu-add #'ignore "Add the menu to the menubar. @@ -518,12 +513,15 @@ You should call this once the menu and keybindings are set up completely and menu filter functions can be expected to work. \(fn MENU &optional MAP)") +(make-obsolete 'easy-menu-add "this was always a no-op in Emacs \ +and can be safely removed." "28.1") (defun add-submenu (menu-path submenu &optional before in-menu) "Add submenu SUBMENU in the menu at MENU-PATH. 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..cbc40193125 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -55,6 +55,7 @@ (require 'backtrace) (require 'macroexp) (require 'cl-lib) +(require 'seq) (eval-when-compile (require 'pcase)) ;;; Options @@ -87,7 +88,6 @@ using, but only when you also use Edebug." ;; because the byte compiler binds them; as a result, if edebug ;; is first loaded for a require in a compilation, they will be left unbound. -;;;###autoload (defcustom edebug-all-defs nil "If non-nil, evaluating defining forms instruments for Edebug. This applies to `eval-defun', `eval-region', `eval-buffer', and @@ -100,11 +100,6 @@ variable. You may wish to make it local to each buffer with `emacs-lisp-mode-hook'." :type 'boolean) -;; edebug-all-defs and edebug-all-forms need to be autoloaded -;; because the byte compiler binds them; as a result, if edebug -;; is first loaded for a require in a compilation, they will be left unbound. - -;;;###autoload (defcustom edebug-all-forms nil "Non-nil means evaluation of all forms will instrument for Edebug. This doesn't apply to loading or evaluations in the minibuffer. @@ -244,19 +239,30 @@ If the result is non-nil, then break. Errors are ignored." ;;; Form spec utilities. -(defun get-edebug-spec (symbol) +(defun edebug-get-spec (symbol) + "Return the Edebug spec of a given Lisp expression's head SYMBOL. +The argument is usually a symbol, but it doesn't have to be." ;; Get the spec of symbol resolving all indirection. (let ((spec nil) (indirect symbol)) (while - (progn - (and (symbolp indirect) - (setq indirect - (function-get indirect 'edebug-form-spec 'macro)))) + (and (symbolp indirect) + (setq indirect + (function-get indirect 'edebug-form-spec 'macro))) ;; (edebug-trace "indirection: %s" edebug-form-spec) (setq spec indirect)) spec)) +(define-obsolete-function-alias 'get-edebug-spec #'edebug-get-spec "28.1") + +(defun edebug--get-elem-spec (elem) + "Return the specs of the Edebug element ELEM, if any. +ELEM has to be a symbol." + (or (get elem 'edebug-elem-spec) + ;; For backward compatibility, we also allow the use of + ;; a form's name as a shorthand to refer to its spec. + (edebug-get-spec elem))) + ;;;###autoload (defun edebug-basic-spec (spec) "Return t if SPEC uses only extant spec symbols. @@ -309,9 +315,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) @@ -342,7 +347,7 @@ Return the result of the last expression in BODY." ;; FIXME: We should probably just be using `pop-to-buffer'. (setq window (cond - ((and (edebug-window-live-p window) + ((and (window-live-p window) (eq (window-buffer window) buffer)) window) ((eq (window-buffer) buffer) @@ -393,7 +398,7 @@ Return the result of the last expression in BODY." ;; Get either a full window configuration or some window information. (if (listp which-windows) (mapcar (lambda (window) - (if (edebug-window-live-p window) + (if (window-live-p window) (list window (window-buffer window) (window-point window) @@ -407,14 +412,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 (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))) @@ -447,66 +451,24 @@ the option `edebug-all-forms'." ;; We should somehow arrange to be able to do this ;; without actually replacing the eval-defun command. -(defun edebug-eval-defun (edebug-it) - "Evaluate the top-level form containing point, or after point. - -If the current defun is actually a call to `defvar', then reset the -variable using its initial value expression even if the variable -already has some other value. (Normally `defvar' does not change the -variable's value if it already has a value.) Treat `defcustom' -similarly. Reinitialize the face according to `defface' specification. - -With a prefix argument, instrument the code for Edebug. - -Setting option `edebug-all-defs' to a non-nil value reverses the meaning +(defun edebug--eval-defun (orig-fun edebug-it) + "Setting option `edebug-all-defs' to a non-nil value reverses the meaning of the prefix argument. Code is then instrumented when this function is invoked without a prefix argument. If acting on a `defun' for FUNCTION, and the function was instrumented, `Edebug: FUNCTION' is printed in the minibuffer. If not instrumented, -just FUNCTION is printed. +just FUNCTION is printed." + (let* ((edebug-all-forms (not (eq (not edebug-it) (not edebug-all-defs)))) + (edebug-all-defs edebug-all-forms)) + (funcall orig-fun nil))) -If not acting on a `defun', the result of evaluation is displayed in -the minibuffer." +(defun edebug-eval-defun (edebug-it) + (declare (obsolete "use eval-defun or edebug--eval-defun instead" "28.1")) (interactive "P") - (let* ((edebugging (not (eq (not edebug-it) (not edebug-all-defs)))) - (edebug-result) - (form - (let ((edebug-all-forms edebugging) - (edebug-all-defs (eq edebug-all-defs (not edebug-it)))) - (edebug-read-top-level-form)))) - ;; This should be consistent with `eval-defun-1', but not the - ;; same, since that gets a macroexpanded form. - (cond ((and (eq (car form) 'defvar) - (cdr-safe (cdr-safe form))) - ;; Force variable to be bound. - (makunbound (nth 1 form))) - ((and (eq (car form) 'defcustom) - (default-boundp (nth 1 form))) - ;; Force variable to be bound. - ;; FIXME: Shouldn't this use the :setter or :initializer? - (set-default (nth 1 form) (eval (nth 2 form) lexical-binding))) - ((eq (car form) 'defface) - ;; Reset the face. - (setq face-new-frame-defaults - (assq-delete-all (nth 1 form) face-new-frame-defaults)) - (put (nth 1 form) 'face-defface-spec nil) - (put (nth 1 form) 'face-documentation (nth 3 form)) - ;; See comments in `eval-defun-1' for purpose of code below - (setq form (prog1 `(prog1 ,form - (put ',(nth 1 form) 'saved-face - ',(get (nth 1 form) 'saved-face)) - (put ',(nth 1 form) 'customized-face - ,(nth 2 form))) - (put (nth 1 form) 'saved-face nil))))) - (setq edebug-result (eval (eval-sexp-add-defvars form) lexical-binding)) - (if (not edebugging) - (prog1 - (prin1 edebug-result) - (let ((str (eval-expression-print-format edebug-result))) - (if str (princ str)))) - edebug-result))) - + (if (advice-member-p #'edebug--eval-defun 'eval-defun) + (eval-defun edebug-it) + (edebug--eval-defun #'eval-defun edebug-it))) ;;;###autoload (defalias 'edebug-defun 'edebug-eval-top-level-form) @@ -555,7 +517,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 () @@ -578,12 +540,12 @@ already is one.)" (defun edebug-install-read-eval-functions () (interactive) (add-function :around load-read-function #'edebug--read) - (advice-add 'eval-defun :override #'edebug-eval-defun)) + (advice-add 'eval-defun :around #'edebug--eval-defun)) (defun edebug-uninstall-read-eval-functions () (interactive) (remove-function load-read-function #'edebug--read) - (advice-remove 'eval-defun #'edebug-eval-defun)) + (advice-remove 'eval-defun #'edebug--eval-defun)) ;;; Edebug internal data @@ -594,7 +556,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 +703,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) @@ -948,6 +925,18 @@ circular objects. Let `read' read everything else." ;;; Cursors for traversal of list and vector elements with offsets. +;; Edebug's instrumentation is based on parsing the sexps, which come with +;; auxiliary position information. Instead of keeping the position +;; information together with the sexps, it is kept in a "parallel +;; tree" of offsets. +;; +;; An "edebug cursor" is a pair of a *list of sexps* (called the +;; "expressions") together with a matching list of offsets. +;; When we're parsing the content of a list, the +;; `edebug-cursor-expressions' is simply the list but when parsing +;; a vector, the `edebug-cursor-expressions' is a list formed of the +;; elements of the vector. + (defvar edebug-dotted-spec nil "Set to t when matching after the dot in a dotted spec list.") @@ -1002,8 +991,8 @@ circular objects. Let `read' read everything else." ;; The following test should always fail. (if (edebug-empty-cursor cursor) (edebug-no-match cursor "Not enough arguments.")) - (setcar cursor (cdr (car cursor))) - (setcdr cursor (cdr (cdr cursor))) + (cl-callf cdr (car cursor)) + (cl-callf cdr (cdr cursor)) cursor) @@ -1054,8 +1043,6 @@ circular objects. Let `read' read everything else." ;; This data is shared by all embedded definitions. (defvar edebug-top-window-data) -(defvar edebug-&optional) -(defvar edebug-&rest) (defvar edebug-gate nil) ;; whether no-match forces an error. (defvar edebug-def-name nil) ; name of definition, used by interactive-form @@ -1106,8 +1093,6 @@ purpose by adding an entry to this alist, and setting edebug-top-window-data edebug-def-name;; make sure it is locally nil ;; I don't like these here!! - edebug-&optional - edebug-&rest edebug-gate edebug-best-error edebug-error-point @@ -1140,7 +1125,7 @@ purpose by adding an entry to this alist, and setting (eq 'symbol (progn (forward-char 1) (edebug-next-token-class)))) ;; Find out if this is a defining form from first symbol (setq def-kind (read (current-buffer)) - spec (and (symbolp def-kind) (get-edebug-spec def-kind)) + spec (and (symbolp def-kind) (edebug-get-spec def-kind)) defining-form-p (and (listp spec) (eq '&define (car spec))) ;; This is incorrect in general!! But OK most of the time. @@ -1151,6 +1136,9 @@ purpose by adding an entry to this alist, and setting ;;;(message "all defs: %s all forms: %s" edebug-all-defs edebug-all-forms) (let ((result (cond + ;; IIUC, `&define' is treated specially here so as to avoid + ;; entering Edebug during the actual function's definition: + ;; we only want to enter Edebug later when the thing is called. (defining-form-p (if (or edebug-all-defs edebug-all-forms) ;; If it is a defining form and we are edebugging defs, @@ -1168,6 +1156,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 @@ -1192,26 +1186,12 @@ purpose by adding an entry to this alist, and setting (funcall edebug-after-instrumentation-function result)))) (defvar edebug-def-args) ; args of defining form. -(defvar edebug-def-interactive) ; is it an emacs interactive function? (defvar edebug-inside-func) ;; whether code is inside function context. ;; Currently def-form sets this to nil; def-body sets it to t. -(defvar edebug--cl-macrolet-defs) ;; Fully defined below. - -(defun edebug-interactive-p-name () - ;; Return a unique symbol for the variable used to store the - ;; status of interactive-p for this function. - (intern (format "edebug-%s-interactive-p" edebug-def-name))) - - -(defun edebug-wrap-def-body (forms) - "Wrap the FORMS of a definition body." - (if edebug-def-interactive - `(let ((,(edebug-interactive-p-name) - (interactive-p))) - ,(edebug-make-enter-wrapper forms)) - (edebug-make-enter-wrapper forms))) +(defvar edebug-lexical-macro-ctx nil + "Alist mapping lexically scoped macro names to their debug spec.") (defun edebug-make-enter-wrapper (forms) ;; Generate the enter wrapper for some forms of a definition. @@ -1219,6 +1199,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 @@ -1354,7 +1341,6 @@ contains a circular object." (edebug-old-def-name (edebug--form-data-name form-data-entry)) edebug-def-name edebug-def-args - edebug-def-interactive edebug-inside-func;; whether wrapped code executes inside a function. ) @@ -1411,6 +1397,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 +1411,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)) @@ -1472,9 +1460,12 @@ contains a circular object." ((consp form) ;; The first offset for a list form is for the list form itself. (if (eq 'quote (car form)) + ;; This makes sure we don't instrument 'foo + ;; which would cause the debugger to single-step + ;; the trivial evaluation of a constant. form (let* ((head (car form)) - (spec (and (symbolp head) (get-edebug-spec head))) + (spec (and (symbolp head) (edebug-get-spec head))) (new-cursor (edebug-new-cursor form offset))) ;; Find out if this is a defining form from first symbol. ;; An indirect spec would not work here, yet. @@ -1514,13 +1505,10 @@ contains a circular object." (defsubst edebug-list-form-args (head cursor) ;; Process the arguments of a list form given that head of form is a symbol. ;; Helper for edebug-list-form - (let ((spec (get-edebug-spec head))) + (let* ((lex-spec (assq head edebug-lexical-macro-ctx)) + (spec (if lex-spec (cdr lex-spec) + (edebug-get-spec head)))) (cond - ;; Treat cl-macrolet bindings like macros with no spec. - ((member head edebug--cl-macrolet-defs) - (if edebug-eval-macro-args - (edebug-forms cursor) - (edebug-sexps cursor))) (spec (cond ((consp spec) @@ -1534,7 +1522,7 @@ contains a circular object." ; but leave it in for compatibility. )) ;; No edebug-form-spec provided. - ((macrop head) + ((or lex-spec (macrop head)) (if edebug-eval-macro-args (edebug-forms cursor) (edebug-sexps cursor))) @@ -1547,10 +1535,7 @@ contains a circular object." ;; The after offset will be left in the cursor after processing the form. (let ((head (edebug-top-element-required cursor "Expected elements")) ;; Prevent backtracking whenever instrumenting. - (edebug-gate t) - ;; A list form is never optional because it matches anything. - (edebug-&optional nil) - (edebug-&rest nil)) + (edebug-gate t)) ;; Skip the first offset. (edebug-set-cursor cursor (edebug-cursor-expressions cursor) (cdr (edebug-cursor-offsets cursor))) @@ -1558,11 +1543,6 @@ contains a circular object." ((symbolp head) (cond ((null head) nil) ; () is valid. - ((eq head 'interactive-p) - ;; Special case: replace (interactive-p) with variable - (setq edebug-def-interactive 'check-it) - (edebug-move-cursor cursor) - (edebug-interactive-p-name)) (t (cons head (edebug-list-form-args head (edebug-move-cursor cursor)))))) @@ -1600,7 +1580,7 @@ contains a circular object." (setq edebug-error-point (or edebug-error-point (edebug-before-offset cursor)) edebug-best-error (or edebug-best-error args)) - (if (and edebug-gate (not edebug-&optional)) + (if edebug-gate (progn (if edebug-error-point (goto-char edebug-error-point)) @@ -1611,13 +1591,11 @@ contains a circular object." (defun edebug-match (cursor specs) ;; Top level spec matching function. ;; Used also at each lower level of specs. - (let (edebug-&optional - edebug-&rest - edebug-best-error + (let (edebug-best-error edebug-error-point (edebug-gate edebug-gate) ;; locally bound to limit effect ) - (edebug-match-specs cursor specs 'edebug-match-specs))) + (edebug-match-specs cursor specs #'edebug-match-specs))) (defun edebug-match-one-spec (cursor spec) @@ -1659,10 +1637,10 @@ contains a circular object." (first-char (and (symbolp spec) (aref (symbol-name spec) 0))) (match (cond ((eq ?& first-char);; "&" symbols take all following specs. - (funcall (get-edebug-spec spec) cursor (cdr specs))) + (edebug--match-&-spec-op spec cursor (cdr specs))) ((eq ?: first-char);; ":" symbols take one following spec. (setq rest (cdr (cdr specs))) - (funcall (get-edebug-spec spec) cursor (car (cdr specs)))) + (edebug--handle-:-spec-op spec cursor (car (cdr specs)))) (t;; Any other normal spec. (setq rest (cdr specs)) (edebug-match-one-spec cursor spec))))) @@ -1693,36 +1671,23 @@ contains a circular object." ;; user may want to define macros or functions with the same names. ;; We could use an internal obarray for these primitive specs. -(dolist (pair '((&optional . edebug-match-&optional) - (&rest . edebug-match-&rest) - (&or . edebug-match-&or) - (form . edebug-match-form) +(dolist (pair '((form . edebug-match-form) (sexp . edebug-match-sexp) (body . edebug-match-body) - (&define . edebug-match-&define) - (name . edebug-match-name) - (:name . edebug-match-colon-name) (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-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) (place . edebug-match-place) (gate . edebug-match-gate) ;; (nil . edebug-match-nil) not this one - special case it. )) - (put (car pair) 'edebug-form-spec (cdr pair))) + (put (car pair) 'edebug-elem-spec (cdr pair))) (defun edebug-match-symbol (cursor symbol) ;; Match a symbol spec. - (let* ((spec (get-edebug-spec symbol))) + (let* ((spec (edebug--get-elem-spec symbol))) (cond (spec (if (consp spec) @@ -1761,13 +1726,12 @@ contains a circular object." (defsubst edebug-match-body (cursor) (edebug-forms cursor)) -(defun edebug-match-&optional (cursor specs) +(cl-defmethod edebug--match-&-spec-op ((_ (eql &optional)) cursor specs) ;; Keep matching until one spec fails. - (edebug-&optional-wrapper cursor specs 'edebug-&optional-wrapper)) + (edebug-&optional-wrapper cursor specs #'edebug-&optional-wrapper)) (defun edebug-&optional-wrapper (cursor specs remainder-handler) (let (result - (edebug-&optional specs) (edebug-gate nil) (this-form (edebug-cursor-expressions cursor)) (this-offset (edebug-cursor-offsets cursor))) @@ -1782,20 +1746,24 @@ contains a circular object." nil))) -(defun edebug-&rest-wrapper (cursor specs remainder-handler) - (if (null specs) (setq specs edebug-&rest)) - ;; Reuse the &optional handler with this as the remainder handler. - (edebug-&optional-wrapper cursor specs remainder-handler)) +(cl-defgeneric edebug--match-&-spec-op (op cursor specs) + "Handle &foo spec operators. +&foo spec operators operate on all the subsequent SPECS.") -(defun edebug-match-&rest (cursor specs) +(cl-defmethod edebug--match-&-spec-op ((_ (eql &rest)) cursor specs) ;; Repeatedly use specs until failure. - (let ((edebug-&rest specs) ;; remember these - edebug-best-error + (let (edebug-best-error edebug-error-point) - (edebug-&rest-wrapper cursor specs 'edebug-&rest-wrapper))) + ;; Reuse the &optional handler with this as the remainder handler. + (edebug-&optional-wrapper + cursor specs + (lambda (c s rh) + ;; `s' is the remaining spec to match. + ;; When it's nil, start over matching `specs'. + (edebug-&optional-wrapper c (or s specs) rh))))) -(defun edebug-match-&or (cursor specs) +(cl-defmethod edebug--match-&-spec-op ((_ (eql &or)) cursor specs) ;; Keep matching until one spec succeeds, and return its results. ;; If none match, fail. ;; This needs to be optimized since most specs spend time here. @@ -1819,27 +1787,49 @@ contains a circular object." (apply #'edebug-no-match cursor "Expected one of" original-specs)) )) - -(defun edebug-match-¬ (cursor specs) +(cl-defmethod edebug--match-&-spec-op ((_ (eql &interpose)) cursor specs) + "Compute the specs for `&interpose SPEC FUN ARGS...'. +Extracts the head of the data by matching it against SPEC, +and then matches the rest by calling (FUN HEAD PF ARGS...) +where PF is the parsing function which FUN can call exactly once, +passing it the specs that it needs to match. +Note that HEAD will always be a list, since specs are defined to match +a sequence of elements." + (pcase-let* + ((`(,spec ,fun . ,args) specs) + (exps (edebug-cursor-expressions cursor)) + (instrumented-head (edebug-match-one-spec cursor spec)) + (consumed (- (length exps) + (length (edebug-cursor-expressions cursor)))) + (head (seq-subseq exps 0 consumed))) + (cl-assert (eq (edebug-cursor-expressions cursor) (nthcdr consumed exps))) + (apply fun `(,head + ,(lambda (newspecs) + ;; FIXME: What'd be the difference if we used + ;; `edebug-match-sublist', which is what + ;; `edebug-list-form-args' uses for the similar purpose + ;; when matching "normal" forms? + (append instrumented-head (edebug-match cursor newspecs))) + ,@args)))) + +(cl-defmethod edebug--match-&-spec-op ((_ (eql ¬)) cursor specs) ;; If any specs match, then fail (if (null (catch 'no-match (let ((edebug-gate nil)) (save-excursion - (edebug-match-&or cursor specs))) + (edebug--match-&-spec-op '&or cursor specs))) nil)) ;; This means something matched, so it is a no match. (edebug-no-match cursor "Unexpected")) ;; 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) +(cl-defmethod edebug--match-&-spec-op ((_ (eql &key)) cursor specs) ;; Following specs must look like (<name> <spec>) ... ;; where <name> is the name of a keyword, and spec is its spec. ;; This really doesn't save much over the expanded form and takes time. - (edebug-match-&rest + (edebug--match-&-spec-op + '&rest cursor (cons '&or (mapcar (lambda (pair) @@ -1847,6 +1837,15 @@ contains a circular object." (car (cdr pair)))) specs)))) +(cl-defmethod edebug--match-&-spec-op ((_ (eql &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. @@ -1907,19 +1906,15 @@ contains a circular object." (defun edebug-match-sublist (cursor specs) ;; Match a sublist of specs. - (let (edebug-&optional - ;;edebug-best-error - ;;edebug-error-point - ) - (prog1 - ;; match with edebug-match-specs so edebug-best-error is not bound. - (edebug-match-specs cursor specs 'edebug-match-specs) - (if (not (edebug-empty-cursor cursor)) - (if edebug-best-error - (apply #'edebug-no-match cursor edebug-best-error) - ;; A failed &rest or &optional spec may leave some args. - (edebug-no-match cursor "Failed matching" specs) - ))))) + (prog1 + ;; match with edebug-match-specs so edebug-best-error is not bound. + (edebug-match-specs cursor specs 'edebug-match-specs) + (if (not (edebug-empty-cursor cursor)) + (if edebug-best-error + (apply #'edebug-no-match cursor edebug-best-error) + ;; A failed &rest or &optional spec may leave some args. + (edebug-no-match cursor "Failed matching" specs) + )))) (defun edebug-match-string (cursor spec) @@ -1942,61 +1937,83 @@ contains a circular object." (defun edebug-match-function (_cursor) (error "Use function-form instead of function in edebug spec")) -(defun edebug-match-&define (cursor specs) +(cl-defmethod edebug--match-&-spec-op ((_ (eql &define)) cursor specs) ;; Match a defining form. ;; Normally, &define is interpreted specially other places. ;; This should only be called inside of a spec list to match the remainder ;; of the current list. e.g. ("lambda" &define args def-body) - (edebug-make-form-wrapper - cursor - (edebug-before-offset cursor) - ;; Find the last offset in the list. - (let ((offsets (edebug-cursor-offsets cursor))) - (while (consp offsets) (setq offsets (cdr offsets))) - offsets) - specs)) - -(defun edebug-match-lambda-expr (cursor) - ;; The expression must be a function. - ;; This will match any list form that begins with a symbol - ;; that has an edebug-form-spec beginning with &define. In - ;; practice, only lambda expressions should be used. - ;; I could add a &lambda specification to avoid confusion. - (let* ((sexp (edebug-top-element-required - cursor "Expected lambda expression")) - (offset (edebug-top-offset cursor)) - (head (and (consp sexp) (car sexp))) - (spec (and (symbolp head) (get-edebug-spec head))) - (edebug-inside-func nil)) - ;; Find out if this is a defining form from first symbol. - (if (and (consp spec) (eq '&define (car spec))) - (prog1 - (list - (edebug-defining-form - (edebug-new-cursor sexp offset) - (car offset);; before the sexp - (edebug-after-offset cursor) - (cons (symbol-name head) (cdr spec)))) - (edebug-move-cursor cursor)) - (edebug-no-match cursor "Expected lambda expression") - ))) - - -(defun edebug-match-name (cursor) - ;; Set the edebug-def-name bound in edebug-defining-form. - (let ((name (edebug-top-element-required cursor "Expected name"))) - ;; Maybe strings and numbers could be used. - (if (not (symbolp name)) - (edebug-no-match cursor "Symbol expected for name of definition")) - (setq edebug-def-name - (if edebug-def-name - ;; Construct a new name by appending to previous name. - (intern (format "%s@%s" edebug-def-name name)) - name)) - (edebug-move-cursor cursor) - (list name))) - -(defun edebug-match-colon-name (_cursor spec) + (prog1 (edebug-make-form-wrapper + cursor + (edebug-before-offset cursor) + ;; Find the last offset in the list. + (let ((offsets (edebug-cursor-offsets cursor))) + (while (consp offsets) (setq offsets (cdr offsets))) + offsets) + specs) + ;; Stop backtracking here (Bug#41988). + (setq edebug-gate t))) + +(cl-defmethod edebug--match-&-spec-op ((_ (eql &name)) cursor specs) + "Compute the name for `&name SPEC FUN` spec operator. + +The full syntax of that operator is: + &name [PRESTRING] SPEC [POSTSTRING] FUN ARGS... + +Extracts the head of the data by matching it against SPEC, +and then get the new name to use by calling + (FUN ARGS... OLDNAME [PRESTRING] HEAD [POSTSTRING]) +FUN should return either a string or a symbol. +FUN can be missing in which case it defaults to concatenating +the new name to the end of the old with an \"@\" char between the two. +PRESTRING and POSTSTRING are optional strings that get prepended +or appended to the actual name." + (pcase-let* + ((`(,spec ,fun . ,args) specs) + (prestrings (when (stringp spec) + (prog1 (list spec) (setq spec fun fun (pop args))))) + (poststrings (when (stringp fun) + (prog1 (list fun) (setq fun (pop args))))) + (exps (edebug-cursor-expressions cursor)) + (instrumented (edebug-match-one-spec cursor spec)) + (consumed (- (length exps) + (length (edebug-cursor-expressions cursor)))) + (newname (apply (or fun #'edebug--concat-name) + `(,@args ,edebug-def-name + ,@prestrings + ,@(seq-subseq exps 0 consumed) + ,@poststrings)))) + (cl-assert (eq (edebug-cursor-expressions cursor) (nthcdr consumed exps))) + (setq edebug-def-name (if (stringp newname) (intern newname) newname)) + instrumented)) + +(defun edebug--concat-name (oldname &rest newnames) + (let ((newname (if (null (cdr newnames)) + (car newnames) + ;; Put spaces between each name, but not for the + ;; leading and trailing strings, if any. + (let (beg mid end) + (dolist (name newnames) + (if (stringp name) + (push name (if mid end beg)) + (when end (setq mid (nconc end mid) end nil)) + (push name mid))) + (apply #'concat `(,@(nreverse beg) + ,(mapconcat (lambda (x) (format "%s" x)) + (nreverse mid) " ") + ,@(nreverse end))))))) + (if (null oldname) + (if (or (stringp newname) (symbolp newname)) + newname + (format "%s" newname)) + (format "%s@%s" edebug-def-name newname)))) + +(def-edebug-elem-spec 'name '(&name symbolp)) + +(cl-defgeneric edebug--handle-:-spec-op (op cursor spec) + "Handle :foo spec operators. +:foo spec operators operate on just the one subsequent SPEC element.") + +(cl-defmethod edebug--handle-:-spec-op ((_ (eql :name)) _cursor spec) ;; Set the edebug-def-name to the spec. (setq edebug-def-name (if edebug-def-name @@ -2005,52 +2022,16 @@ contains a circular object." spec)) nil) -(defun edebug-match-cl-generic-method-args (cursor) - (let ((args (edebug-top-element-required cursor "Expected arguments"))) - (if (not (consp args)) - (edebug-no-match cursor "List expected")) - ;; Append the arguments to edebug-def-name. +(cl-defmethod edebug--handle-:-spec-op ((_ (eql :unique)) _cursor spec) + "Match a `:unique PREFIX' specifier. +SPEC is the symbol name prefix for `gensym'." + (let ((suffix (gensym spec))) (setq edebug-def-name - (intern (format "%s %s" edebug-def-name args))) - (edebug-move-cursor cursor) - (list args))) - -(defvar edebug--cl-macrolet-defs nil - "List of symbols found within the bindings of enclosing `cl-macrolet' forms.") -(defvar edebug--current-cl-macrolet-defs nil - "List of symbols found within the bindings of the current `cl-macrolet' form.") - -(defun edebug-match-cl-macrolet-expr (cursor) - "Match a `cl-macrolet' form at CURSOR." - (let (edebug--current-cl-macrolet-defs) - (edebug-match cursor - '((&rest (&define cl-macrolet-name cl-macro-list - cl-declarations-or-string - def-body)) - cl-declarations cl-macrolet-body)))) - -(defun edebug-match-cl-macrolet-name (cursor) - "Match the name in a `cl-macrolet' binding at CURSOR. -Collect the names in `edebug--cl-macrolet-defs' where they -will be checked by `edebug-list-form-args' and treated as -macros without a spec." - (let ((name (edebug-top-element-required cursor "Expected name"))) - (when (not (symbolp name)) - (edebug-no-match cursor "Bad name:" name)) - ;; Change edebug-def-name to avoid conflicts with - ;; names at global scope. - (setq edebug-def-name (gensym "edebug-anon")) - (edebug-move-cursor cursor) - (push name edebug--current-cl-macrolet-defs) - (list name))) - -(defun edebug-match-cl-macrolet-body (cursor) - "Match the body of a `cl-macrolet' expression at CURSOR. -Put the definitions collected in `edebug--current-cl-macrolet-defs' -into `edebug--cl-macrolet-defs' which is checked in `edebug-list-form-args'." - (let ((edebug--cl-macrolet-defs (nconc edebug--current-cl-macrolet-defs - edebug--cl-macrolet-defs))) - (edebug-match-body cursor))) + (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-arg (cursor) ;; set the def-args bound in edebug-defining-form @@ -2080,149 +2061,135 @@ into `edebug--cl-macrolet-defs' which is checked in `edebug-list-form-args'." ;; This happens to handle bug#20281, tho maybe a better fix would be to ;; improve the `defun' spec. (when forms - (list (edebug-wrap-def-body forms))))) + (list (edebug-make-enter-wrapper forms))))) ;;;; Edebug Form Specs ;;; ========================================================== -;;;;* Spec for def-edebug-spec -;;; Out of date. - -(defun edebug-spec-p (object) - "Return non-nil if OBJECT is a symbol with an edebug-form-spec property." - (and (symbolp object) - (get object 'edebug-form-spec))) - -(def-edebug-spec def-edebug-spec - ;; Top level is different from lower levels. - (&define :name edebug-spec name - &or "nil" edebug-spec-p "t" "0" (&rest edebug-spec))) - -(def-edebug-spec edebug-spec-list - ;; A list must have something in it, or it is nil, a symbolp - ((edebug-spec . [&or nil edebug-spec]))) - -(def-edebug-spec edebug-spec - (&or - (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] - edebug-spec-p ;; Including all the special ones e.g. form. - symbolp;; a predicate - )) - - ;;;* Emacs special forms and some functions. -;; quote expects only one argument, although it allows any number. -(def-edebug-spec quote sexp) +(pcase-dolist + (`(,name ,spec) + + '((quote (sexp)) ;quote expects only one arg, tho it allows any number. + + ;; The standard defining forms. + (defvar (symbolp &optional form stringp)) + (defconst defvar) + + ;; Contrary to macros, special forms default to assuming that all args + ;; are normal forms, so we don't need to do anything about those + ;; special forms: + ;;(save-current-buffer t) + ;;(save-excursion t) + ;;... + ;;(progn t) + + ;; `defun' and `defmacro' are not special forms (any more), but it's + ;; more convenient to define their Edebug spec here. + (defun ( &define name lambda-list lambda-doc + [&optional ("declare" def-declarations)] + [&optional ("interactive" &optional [&or stringp def-form] + &rest symbolp)] + def-body)) + + (defmacro ( &define name lambda-list lambda-doc + [&optional ("declare" def-declarations)] + def-body)) + + ;; function expects a symbol or a lambda or macro expression + ;; A macro is allowed by Emacs. + (function (&or symbolp lambda-expr)) + + ;; FIXME? The manual uses this form (maybe that's just + ;; for illustration purposes?): + ;; (let ((&rest &or symbolp (gate symbolp &optional form)) body)) + (let ((&rest &or (symbolp &optional form) symbolp) body)) + (let* let) + + (setq (&rest symbolp form)) + (cond (&rest (&rest form))) + + (condition-case ( symbolp form + &rest ([&or symbolp (&rest symbolp)] body))) + + (\` (backquote-form)) + + ;; Assume immediate quote in unquotes mean backquote at next + ;; higher level. + (\, (&or ("quote" edebug-\`) def-form)) + (\,@ (&define ;; so (,@ form) is never wrapped. + &or ("quote" edebug-\`) def-form)) + )) + (put name 'edebug-form-spec spec)) -;; The standard defining forms. -(def-edebug-spec defconst defvar) -(def-edebug-spec defvar (symbolp &optional form stringp)) +(defun edebug--match-declare-arg (head pf) + (funcall pf (get (car head) 'edebug-declaration-spec))) -(def-edebug-spec defun - (&define name lambda-list lambda-doc - [&optional ("declare" &rest sexp)] - [&optional ("interactive" interactive)] - def-body)) -(def-edebug-spec defmacro - ;; FIXME: Improve `declare' so we can Edebug gv-expander and - ;; gv-setter declarations. - (&define name lambda-list lambda-doc - [&optional ("declare" &rest sexp)] def-body)) +(def-edebug-elem-spec 'def-declarations + '(&rest &or (&interpose symbolp edebug--match-declare-arg) sexp)) + +(def-edebug-elem-spec 'lambda-list + '(([&rest arg] + [&optional ["&optional" arg &rest arg]] + &optional ["&rest" arg] + ))) -(def-edebug-spec arglist lambda-list) ;; deprecated - use lambda-list. +(def-edebug-elem-spec 'lambda-expr + '(("lambda" &define lambda-list lambda-doc + [&optional ("interactive" interactive)] + def-body))) -(def-edebug-spec lambda-list - (([&rest arg] - [&optional ["&optional" arg &rest arg]] - &optional ["&rest" arg] - ))) +(def-edebug-elem-spec 'arglist '(lambda-list)) ;; deprecated - use lambda-list. -(def-edebug-spec lambda-doc - (&optional [&or stringp - (&define ":documentation" def-form)])) +(def-edebug-elem-spec 'lambda-doc + '(&optional [&or stringp + (&define ":documentation" def-form)])) -(def-edebug-spec interactive - (&optional &or stringp def-form)) +(def-edebug-elem-spec 'interactive '(&optional [&or stringp def-form] + &rest symbolp)) ;; A function-form is for an argument that may be a function or a form. ;; This specially recognizes anonymous functions quoted with quote. -(def-edebug-spec function-form +(def-edebug-elem-spec 'function-form ;Deprecated, use `form'! ;; form at the end could also handle "function", ;; but recognize it specially to avoid wrapping function forms. - (&or ([&or "quote" "function"] &or symbolp lambda-expr) form)) - -;; function expects a symbol or a lambda or macro expression -;; A macro is allowed by Emacs. -(def-edebug-spec function (&or symbolp lambda-expr)) - -;; A macro expression is a lambda expression with "macro" prepended. -(def-edebug-spec macro (&define "lambda" lambda-list def-body)) - -;; (def-edebug-spec anonymous-form ((&or ["lambda" lambda] ["macro" macro]))) - -;; Standard functions that take function-forms arguments. - -;; FIXME? The manual uses this form (maybe that's just for illustration?): -;; (def-edebug-spec let -;; ((&rest &or symbolp (gate symbolp &optional form)) -;; body)) -(def-edebug-spec let - ((&rest &or (symbolp &optional form) symbolp) - body)) - -(def-edebug-spec let* let) - -(def-edebug-spec setq (&rest symbolp form)) - -(def-edebug-spec cond (&rest (&rest form))) - -(def-edebug-spec condition-case - (symbolp - form - &rest ([&or symbolp (&rest symbolp)] body))) - - -(def-edebug-spec \` (backquote-form)) + '(&or ([&or "quote" "function"] &or symbolp lambda-expr) form)) ;; Supports quotes inside backquotes, ;; but only at the top level inside unquotes. -(def-edebug-spec backquote-form - (&or - ;; Disallow instrumentation of , and ,@ inside a nested backquote, since - ;; these are likely to be forms generated by a macro being debugged. - ("`" nested-backquote-form) - ([&or "," ",@"] &or ("quote" backquote-form) form) - ;; The simple version: - ;; (backquote-form &rest backquote-form) - ;; doesn't handle (a . ,b). The straightforward fix: - ;; (backquote-form . [&or nil backquote-form]) - ;; uses up too much stack space. - ;; Note that `(foo . ,@bar) is not valid, so we don't need to handle it. - (backquote-form [&rest [¬ ","] backquote-form] - . [&or nil backquote-form]) - ;; If you use dotted forms in backquotes, replace the previous line - ;; with the following. This takes quite a bit more stack space, however. - ;; (backquote-form . [&or nil backquote-form]) - (vector &rest backquote-form) - sexp)) - -(def-edebug-spec nested-backquote-form - (&or - ;; Allow instrumentation of any , or ,@ contained within the (\, ...) or - ;; (\,@ ...) matched on the next line. - ([&or "," ",@"] backquote-form) - (nested-backquote-form [&rest [¬ "," ",@"] nested-backquote-form] - . [&or nil nested-backquote-form]) - (vector &rest nested-backquote-form) - sexp)) +(def-edebug-elem-spec 'backquote-form + '(&or + ;; Disallow instrumentation of , and ,@ inside a nested backquote, since + ;; these are likely to be forms generated by a macro being debugged. + ("`" nested-backquote-form) + ([&or "," ",@"] &or ("quote" backquote-form) form) + ;; The simple version: + ;; (backquote-form &rest backquote-form) + ;; doesn't handle (a . ,b). The straightforward fix: + ;; (backquote-form . [&or nil backquote-form]) + ;; uses up too much stack space. + ;; Note that `(foo . ,@bar) is not valid, so we don't need to handle it. + (backquote-form [&rest [¬ ","] backquote-form] + . [&or nil backquote-form]) + ;; If you use dotted forms in backquotes, replace the previous line + ;; with the following. This takes quite a bit more stack space, however. + ;; (backquote-form . [&or nil backquote-form]) + (vector &rest backquote-form) + sexp)) + +(def-edebug-elem-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) + (nested-backquote-form [&rest [¬ "," ",@"] nested-backquote-form] + . [&or nil nested-backquote-form]) + (vector &rest nested-backquote-form) + sexp)) ;; Special version of backquote that instruments backquoted forms ;; destined to be evaluated, usually as the result of a @@ -2237,20 +2204,9 @@ into `edebug--cl-macrolet-defs' which is checked in `edebug-list-form-args'." ;; ,@ might have some problems. -(defalias 'edebug-\` '\`) ;; same macro as regular backquote. -(def-edebug-spec edebug-\` (def-form)) - -;; Assume immediate quote in unquotes mean backquote at next higher level. -(def-edebug-spec \, (&or ("quote" edebug-\`) def-form)) -(def-edebug-spec \,@ (&define ;; so (,@ form) is never wrapped. - &or ("quote" edebug-\`) def-form)) - -;; New byte compiler. - -(def-edebug-spec save-selected-window t) -(def-edebug-spec save-current-buffer t) - -;; Anything else? +(defmacro edebug-\` (exp) + (declare (debug (def-form))) + (list '\` exp)) ;;; The debugger itself @@ -2424,11 +2380,10 @@ STATUS should be a list returned by `edebug-var-status'." (edebug-print-trace-after (format "%s result: %s" function edebug-result))))) -(def-edebug-spec edebug-tracing (form body)) - (defmacro edebug-tracing (msg &rest body) "Print MSG in *edebug-trace* before and after evaluating BODY. The result of BODY is also printed." + (declare (debug (form body))) `(let ((edebug-stack-depth (1+ edebug-stack-depth)) edebug-result) (edebug-print-trace-before ,msg) @@ -2580,12 +2535,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 +2556,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 @@ -2631,7 +2582,7 @@ See `edebug-behavior-alist' for implementations.") (edebug-outside-window (selected-window)) (edebug-outside-buffer (current-buffer)) (edebug-outside-point (point)) - (edebug-outside-mark (edebug-mark)) + (edebug-outside-mark (mark t)) edebug-outside-windows ; Window or screen configuration. edebug-buffer-points @@ -2755,6 +2706,7 @@ See `edebug-behavior-alist' for implementations.") (edebug-stop)) (edebug-overlay-arrow) + (edebug--overlay-breakpoints edebug-function) (unwind-protect (if (or edebug-stop @@ -2799,7 +2751,7 @@ See `edebug-behavior-alist' for implementations.") ;; Unrestore edebug-buffer's window-start, if displayed. (let ((window (car edebug-window-data))) - (if (and (edebug-window-live-p window) + (if (and (window-live-p window) (eq (window-buffer) edebug-buffer)) (progn (set-window-start window (cdr edebug-window-data) @@ -2818,7 +2770,7 @@ See `edebug-behavior-alist' for implementations.") ;; Since we may be in a save-excursion, in case of quit, ;; reselect the outside window only. ;; Only needed if we are not recovering windows?? - (if (edebug-window-live-p edebug-outside-window) + (if (window-live-p edebug-outside-window) (select-window edebug-outside-window)) ) ; if edebug-save-windows @@ -2831,9 +2783,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 +2795,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) @@ -2863,7 +2815,6 @@ See `edebug-behavior-alist' for implementations.") (defvar edebug-outside-match-data) ; match data outside of edebug (defvar edebug-backtrace-buffer) ; each recursive edit gets its own (defvar edebug-inside-windows) -(defvar edebug-interactive-p) (defvar edebug-mode-map) ; will be defined fully later. @@ -2879,7 +2830,6 @@ See `edebug-behavior-alist' for implementations.") ;;(edebug-number-of-recursions (1+ edebug-number-of-recursions)) (edebug-recursion-depth (recursion-depth)) edebug-entered ; bind locally to nil - (edebug-interactive-p nil) ; again non-interactive edebug-backtrace-buffer ; each recursive edit gets its own ;; The window configuration may be saved and restored ;; during a recursive-edit @@ -3089,8 +3039,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 +3068,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 +3105,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 +3146,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 +3178,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 +3224,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 +3240,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 +3256,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 +3437,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 @@ -3504,7 +3493,10 @@ canceled the first time the function is entered." ;; Could store this in the edebug data instead. (put function 'edebug-on-entry (if flag 'temp t))) -(defalias 'edebug-cancel-edebug-on-entry #'cancel-edebug-on-entry) +(define-obsolete-function-alias 'edebug-cancel-edebug-on-entry + #'edebug-cancel-on-entry "28.1") +(define-obsolete-function-alias 'cancel-edebug-on-entry + #'edebug-cancel-on-entry "28.1") (defun edebug--edebug-on-entry-functions () (let ((functions nil)) @@ -3516,9 +3508,9 @@ canceled the first time the function is entered." obarray) functions)) -(defun cancel-edebug-on-entry (function) +(defun edebug-cancel-on-entry (function) "Cause Edebug to not stop when FUNCTION is called. -The removes the effect of `edebug-on-entry'. If FUNCTION is is +The removes the effect of `edebug-on-entry'. If FUNCTION is nil, remove `edebug-on-entry' on all functions." (interactive (list (let ((name (completing-read @@ -3622,8 +3614,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 +3659,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 +3666,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) @@ -3706,9 +3696,10 @@ Print result in minibuffer." (interactive (list (read--expression "Eval: "))) (princ (edebug-outside-excursion - (setq values (cons (edebug-eval expr) values)) - (concat (edebug-safe-prin1-to-string (car values)) - (eval-expression-print-format (car values)))))) + (let ((result (edebug-eval expr))) + (values--store-value result) + (concat (edebug-safe-prin1-to-string result) + (eval-expression-print-format result)))))) (defun edebug-eval-last-sexp (&optional no-truncate) "Evaluate sexp before point in the outside environment. @@ -3841,10 +3832,14 @@ be installed in `emacs-lisp-mode-map'.") ;; Autoloading these global bindings doesn't make sense because ;; they cannot be used anyway unless Edebug is already loaded and active. -(defvar global-edebug-prefix "\^XX" +(define-obsolete-variable-alias 'global-edebug-prefix + 'edebug-global-prefix "28.1") +(defvar edebug-global-prefix "\^XX" "Prefix key for global edebug commands, available from any buffer.") -(defvar global-edebug-map +(define-obsolete-variable-alias 'global-edebug-map + 'edebug-global-map "28.1") +(defvar edebug-global-map (let ((map (make-sparse-keymap))) (define-key map " " 'edebug-step-mode) @@ -3877,9 +3872,9 @@ be installed in `emacs-lisp-mode-map'.") map) "Global map of edebug commands, available from any buffer.") -(when global-edebug-prefix - (global-unset-key global-edebug-prefix) - (global-set-key global-edebug-prefix global-edebug-map)) +(when edebug-global-prefix + (global-unset-key edebug-global-prefix) + (global-set-key edebug-global-prefix edebug-global-map)) (defun edebug-help () @@ -3920,7 +3915,6 @@ Options: `edebug-print-circle' `edebug-on-error' `edebug-on-quit' -`edebug-on-signal' `edebug-unwrap-results' `edebug-global-break-condition'" :lighter " *Debugging*" @@ -4122,12 +4116,12 @@ This should be a list of `edebug---frame' objects.") "Stack frames of the current Edebug Backtrace buffer with instrumentation. This should be a list of `edebug---frame' objects.") -;; Data structure for backtrace frames with information -;; from Edebug instrumentation found in the backtrace. (cl-defstruct (edebug--frame (:constructor edebug--make-frame) (:include backtrace-frame)) + "Data structure for backtrace frames with information +from Edebug instrumentation found in the backtrace." def-name before-index after-index) (defun edebug-pop-to-backtrace () @@ -4142,7 +4136,8 @@ This should be a list of `edebug---frame' objects.") (pop-to-buffer edebug-backtrace-buffer) (unless (derived-mode-p 'backtrace-mode) (backtrace-mode) - (add-hook 'backtrace-goto-source-functions #'edebug--backtrace-goto-source)) + (add-hook 'backtrace-goto-source-functions + #'edebug--backtrace-goto-source nil t)) (setq edebug-instrumented-backtrace-frames (backtrace-get-frames 'edebug-debugger :constructor #'edebug--make-frame) @@ -4223,7 +4218,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 +4302,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 +4355,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) @@ -4377,10 +4371,6 @@ It is removed when you hit any char." (set variable (not (symbol-value variable))) (message "%s: %s" variable (symbol-value variable))) -;; We have to require easymenu (even for Emacs 18) just so -;; the easy-menu-define macro call is compiled correctly. -(require 'easymenu) - (defconst edebug-mode-menus '("Edebug" ["Stop" edebug-stop t] @@ -4447,11 +4437,6 @@ It is removed when you hit any char." ;;; Emacs version specific code -(defalias 'edebug-window-live-p 'window-live-p) - -(defun edebug-mark () - (mark t)) - (defun edebug-set-conditional-breakpoint (arg condition) "Set a conditional breakpoint at nearest sexp. The condition is evaluated in the outside context. @@ -4465,7 +4450,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 +4464,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 @@ -4501,13 +4475,18 @@ With prefix argument, make it a temporary breakpoint." (add-hook 'called-interactively-p-functions #'edebug--called-interactively-skip) (defun edebug--called-interactively-skip (i frame1 frame2) - (when (and (eq (car-safe (nth 1 frame1)) 'lambda) - (eq (nth 1 (nth 1 frame1)) '()) - (eq (nth 1 frame2) 'edebug-enter)) + (when (and (memq (car-safe (nth 1 frame1)) '(lambda closure)) + ;; Lambda value with no arguments. + (null (nth (if (eq (car-safe (nth 1 frame1)) 'lambda) 1 2) + (nth 1 frame1))) + (memq (nth 1 frame2) '(edebug-enter edebug-default-enter))) ;; `edebug-enter' calls itself on its first invocation. - (if (eq (nth 1 (backtrace-frame i 'called-interactively-p)) - 'edebug-enter) - 2 1))) + (let ((s 1)) + (while (memq (nth 1 (backtrace-frame i 'called-interactively-p)) + '(edebug-enter edebug-default-enter)) + (cl-incf s) + (cl-incf i)) + s))) ;; Finally, hook edebug into the rest of Emacs. ;; There are probably some other things that could go here. @@ -4525,7 +4504,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 +4557,15 @@ instrumentation for, defaulting to all functions." (message "Removed edebug instrumentation from %s" (mapconcat #'symbol-name functions ", "))) + +;;; Obsolete. + +(defun edebug-mark () + (declare (obsolete mark "28.1")) + (mark t)) + +(define-obsolete-function-alias 'edebug-mark-marker #'mark-marker "28.1") +(define-obsolete-function-alias 'edebug-window-live-p #'window-live-p "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..641882c9026 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -1,7 +1,6 @@ ;;; eieio-base.el --- Base classes for EIEIO. -*- lexical-binding:t -*- -;;; Copyright (C) 2000-2002, 2004-2005, 2007-2021 Free Software -;;; Foundation, Inc. +;; Copyright (C) 2000-2021 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Keywords: OO, lisp @@ -162,6 +161,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 +304,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 +410,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 +421,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 +475,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-compat.el b/lisp/emacs-lisp/eieio-compat.el index db97d4ca4e8..6d84839c341 100644 --- a/lisp/emacs-lisp/eieio-compat.el +++ b/lisp/emacs-lisp/eieio-compat.el @@ -105,7 +105,7 @@ Summary: (declare (doc-string 3) (obsolete cl-defmethod "25.1") (debug (&define ; this means we are defining something - [&or name ("setf" name :name setf)] + [&name sexp] ;Allow (setf ...) additionally to symbols. ;; ^^ This is the methods symbol [ &optional symbolp ] ; this is key :before etc cl-generic-method-args ; arguments diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index e73afabf9a0..2923dffd951 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -169,7 +169,7 @@ Return nil if that option doesn't exist." (and (recordp obj) (eieio--class-p (eieio--object-class obj)))) -(define-obsolete-function-alias 'object-p 'eieio-object-p "25.1") +(define-obsolete-function-alias 'object-p #'eieio-object-p "25.1") (defun class-abstract-p (class) "Return non-nil if CLASS is abstract. @@ -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) @@ -241,9 +242,9 @@ It creates an autoload function for CNAME's constructor." (cl-deftype list-of (elem-type) `(and list - (satisfies (lambda (list) - (cl-every (lambda (elem) (cl-typep elem ',elem-type)) - list))))) + (satisfies ,(lambda (list) + (cl-every (lambda (elem) (cl-typep elem elem-type)) + list))))) (defun eieio-make-class-predicate (class) @@ -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. @@ -728,9 +729,10 @@ Argument FN is the function calling this verifier." (pcase slot ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-slot-names)))) - (macroexp--warn-and-return + (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)) @@ -784,7 +787,7 @@ Fills in OBJ's SLOT with its default value." (cond ;; Is it a function call? If so, evaluate it. ((eieio-eval-default-p val) - (eval val)) + (eval val t)) ;;;; check for quoted things, and unquote them ;;((and (consp val) (eq (car val) 'quote)) ;; (car (cdr val))) @@ -1026,7 +1029,7 @@ method invocation orders of the involved classes." (eieio--class-precedence-c3 class)))))) (define-obsolete-function-alias - 'class-precedence-list 'eieio--class-precedence-list "24.4") + 'class-precedence-list #'eieio--class-precedence-list "24.4") ;;; Here are some special types of errors 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..910023b841b 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -233,7 +233,7 @@ This method is obsolete." ,@(when eieio-backward-compatibility (let ((f (intern (format "%s-child-p" name)))) - `((defalias ',f ',testsym2) + `((defalias ',f #',testsym2) (make-obsolete ',f ,(format "use (cl-typep ... \\='%s) instead" name) "25.1")))) @@ -269,7 +269,7 @@ This method is obsolete." (lambda (whole) (if (not (stringp (car slots))) whole - (macroexp--warn-and-return + (macroexp-warn-and-return (format "Obsolete name arg %S to constructor %S" (car slots) (car whole)) ;; Keep the name arg, for backward compatibility, @@ -288,8 +288,8 @@ created by the :initarg tag." (declare (debug (form symbolp))) `(eieio-oref ,obj (quote ,slot))) -(defalias 'slot-value 'eieio-oref) -(defalias 'set-slot-value 'eieio-oset) +(defalias 'slot-value #'eieio-oref) +(defalias 'set-slot-value #'eieio-oset) (make-obsolete 'set-slot-value "use (setf (slot-value ..) ..) instead" "25.1") (defmacro oref-default (obj slot) @@ -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. @@ -422,7 +418,7 @@ If EXTRA, include that in the string returned to represent the symbol." (cl-check-type obj eieio-object) (eieio-class-name (eieio--object-class obj))) (define-obsolete-function-alias - 'object-class-name 'eieio-object-class-name "24.4") + 'object-class-name #'eieio-object-class-name "24.4") (defun eieio-class-parents (class) ;; FIXME: What does "(overload of variable)" mean here? @@ -450,7 +446,7 @@ The CLOS function `class-direct-subclasses' is aliased to this function." (defmacro eieio-class-parent (class) "Return first parent class to CLASS. (overload of variable)." `(car (eieio-class-parents ,class))) -(define-obsolete-function-alias 'class-parent 'eieio-class-parent "24.4") +(define-obsolete-function-alias 'class-parent #'eieio-class-parent "24.4") (defun same-class-p (obj class) "Return t if OBJ is of class-type CLASS." @@ -465,7 +461,7 @@ The CLOS function `class-direct-subclasses' is aliased to this function." ;; class will be checked one layer down (child-of-class-p (eieio--object-class obj) class)) ;; Backwards compatibility -(defalias 'obj-of-class-p 'object-of-class-p) +(defalias 'obj-of-class-p #'object-of-class-p) (defun child-of-class-p (child class) "Return non-nil if CHILD class is a subclass of CLASS." @@ -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 @@ -677,7 +665,7 @@ This class is not stored in the `parent' slot of a class vector." (setq eieio-default-superclass (cl--find-class 'eieio-default-superclass)) (define-obsolete-function-alias 'standard-class - 'eieio-default-superclass "26.1") + #'eieio-default-superclass "26.1") (cl-defgeneric make-instance (class &rest initargs) "Make a new instance of CLASS based on INITARGS. @@ -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 "(") @@ -984,12 +972,12 @@ this object." This may create or delete slots, but does not affect the return value of `eq'." (error "EIEIO: `change-class' is unimplemented")) -(define-obsolete-function-alias 'change-class 'eieio-change-class "26.1") +(define-obsolete-function-alias 'change-class #'eieio-change-class "26.1") ;; Hook ourselves into help system for describing classes and methods. ;; FIXME: This is not actually needed any more since we can click on the ;; hyperlink from the constructor's docstring to see the type definition. -(add-hook 'help-fns-describe-function-functions 'eieio-help-constructor) +(add-hook 'help-fns-describe-function-functions #'eieio-help-constructor) (provide 'eieio) diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 7cf5796db09..a02406a7b73 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 +proportion 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,26 @@ 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-local 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 +274,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 +301,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 +336,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 +383,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 possible. 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 +905,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..411ea2af69c 100644 --- a/lisp/emacs-lisp/elp.el +++ b/lisp/emacs-lisp/elp.el @@ -110,8 +110,7 @@ ;; Boy Jim's profiler.el. Both were written for Emacs 18 and both were ;; pretty good first shots at profiling, but I found that they didn't ;; provide the functionality or interface that I wanted, so I wrote -;; this. I've tested elp in XEmacs 19 and Emacs 19. There's no point -;; in even trying to make this work with Emacs 18. +;; this. ;; Unlike previous profilers, elp uses Emacs 19's built-in function ;; current-time to return interval times. This obviates the need for @@ -342,9 +341,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) @@ -584,7 +583,7 @@ displayed." ;; continue standard unloading nil) -(cl-defmethod loadhist-unload-element :before :extra "elp" ((x (head defun))) +(cl-defmethod loadhist-unload-element :extra "elp" :before ((x (head defun))) "Un-instrument before unloading a function." (elp-restore-function (cdr x))) diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index a67f42bc386..1191fb8f8de 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. @@ -101,15 +102,6 @@ the name of the test and the result of NAME-FORM." (indent 1)) `(ert--call-with-test-buffer ,name-form (lambda () ,@body))) -;; We use these `put' forms in addition to the (declare (indent)) in -;; the defmacro form since the `declare' alone does not lead to -;; correct indentation before the .el/.elc file is loaded. -;; Autoloading these `put' forms solves this. -;;;###autoload -(progn - ;; TODO(ohler): Figure out what these mean and make sure they are correct. - (put 'ert-with-test-buffer 'lisp-indent-function 1)) - ;;;###autoload (defun ert-kill-all-test-buffers () "Kill all test buffers that are still live." @@ -177,6 +169,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 +345,45 @@ 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 (macroexp-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..e91ec0af443 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -58,13 +58,10 @@ ;;; Code: (require 'cl-lib) -(require 'button) (require 'debug) (require 'backtrace) -(require 'easymenu) (require 'ewoc) (require 'find-func) -(require 'help) (require 'pp) ;;; UI customization options. @@ -83,15 +80,13 @@ Use nil for no limit (caution: backtrace lines can be very long)." :background "green1") (((class color) (background dark)) :background "green3")) - "Face used for expected results in the ERT results buffer." - :group 'ert) + "Face used for expected results in the ERT results buffer.") (defface ert-test-result-unexpected '((((class color) (background light)) :background "red1") (((class color) (background dark)) :background "red3")) - "Face used for unexpected results in the ERT results buffer." - :group 'ert) + "Face used for unexpected results in the ERT results buffer.") ;;; Copies/reimplementations of cl functions. @@ -198,8 +193,8 @@ it has to be wrapped in `(eval (quote ...))'. \(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ [:tags \\='(TAG...)] BODY...)" - (declare (debug (&define :name test - name sexp [&optional stringp] + (declare (debug (&define [&name "test@" symbolp] + sexp [&optional stringp] [&rest keywordp sexp] def-body)) (doc-string 3) (indent 2)) @@ -226,16 +221,6 @@ it has to be wrapped in `(eval (quote ...))'. :body (lambda () ,@body))) ',name)))) -;; We use these `put' forms in addition to the (declare (indent)) in -;; the defmacro form since the `declare' alone does not lead to -;; correct indentation before the .el/.elc file is loaded. -;; Autoloading these `put' forms solves this. -;;;###autoload -(progn - ;; TODO(ohler): Figure out what these mean and make sure they are correct. - (put 'ert-deftest 'lisp-indent-function 2) - (put 'ert-info 'lisp-indent-function 1)) - (defvar ert--find-test-regexp (concat "^\\s-*(ert-deftest" find-function-space-re @@ -276,7 +261,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 (cons error-symbol data)))) (defun ert--special-operator-p (thing) "Return non-nil if THING is a symbol naming a special operator." @@ -292,14 +277,7 @@ It should only be stopped when ran from inside ert--run-test-internal." (let ((form ;; catch macroexpansion errors (condition-case err - (macroexpand-all form - (append (bound-and-true-p - byte-compile-macro-environment) - (cond - ((boundp 'macroexpand-all-environment) - macroexpand-all-environment) - ((boundp 'cl-macro-environment) - cl-macro-environment)))) + (macroexpand-all form macroexpand-all-environment) (error `(signal ',(car err) ',(cdr err)))))) (cond ((or (atom form) (ert--special-operator-p (car form))) @@ -489,7 +467,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 +493,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 +518,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 +1283,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 @@ -1557,7 +1543,7 @@ Ran \\([0-9]+\\) tests, \\([0-9]+\\) results as expected\ (message "------------------") (setq tests (sort tests (lambda (x y) (> (car x) (car y))))) (when (< high (length tests)) (setcdr (nthcdr (1- high) tests) nil)) - (message "%s" (mapconcat 'cdr tests "\n"))) + (message "%s" (mapconcat #'cdr tests "\n"))) ;; More details on hydra, where the logs are harder to get to. (when (and (getenv "EMACS_HYDRA_CI") (not (zerop (+ nunexpected nskipped)))) @@ -1628,9 +1614,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 @@ -1649,7 +1633,7 @@ default (if any)." (defun ert-find-test-other-window (test-name) "Find, in another window, the definition of TEST-NAME." - (interactive (list (ert-read-test-name-at-point "Find test definition: "))) + (interactive (list (ert-read-test-name-at-point "Find test definition"))) (find-function-do-it test-name 'ert--test 'switch-to-buffer-other-window)) (defun ert-delete-test (test-name) @@ -1798,8 +1782,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 +1959,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 +2000,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)) @@ -2088,7 +2070,7 @@ and how to display message." (ert-run-tests selector listener t))) ;;;###autoload -(defalias 'ert 'ert-run-tests-interactively) +(defalias 'ert #'ert-run-tests-interactively) ;;; Simple view mode for auxiliary information like stack traces or @@ -2101,6 +2083,7 @@ and how to display message." (define-derived-mode ert-results-mode special-mode "ERT-Results" "Major mode for viewing results of ERT test runs." + :interactive nil (setq-local revert-buffer-function (lambda (&rest _) (ert-results-rerun-all-tests)))) @@ -2196,7 +2179,7 @@ To be used in the ERT results buffer." "Move point to the next test. To be used in the ERT results buffer." - (interactive) + (interactive nil ert-results-mode) (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-next "No tests below")) @@ -2204,7 +2187,7 @@ To be used in the ERT results buffer." "Move point to the previous test. To be used in the ERT results buffer." - (interactive) + (interactive nil ert-results-mode) (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-prev "No tests above")) @@ -2237,7 +2220,7 @@ user-error is signaled with the message ERROR-MESSAGE." "Find the definition of the test at point in another window. To be used in the ERT results buffer." - (interactive) + (interactive nil ert-results-mode) (let ((name (ert-test-at-point))) (unless name (user-error "No test at point")) @@ -2271,7 +2254,7 @@ To be used in the ERT results buffer." ;; the summary apparently needs to be easily accessible from the ;; error log, and perhaps it would be better to have it in a ;; separate buffer to keep it visible. - (interactive) + (interactive nil ert-results-mode) (let ((ewoc ert--results-ewoc) (progress-bar-begin ert--results-progress-bar-button-begin)) (cond ((ert--results-test-node-or-null-at-point) @@ -2388,7 +2371,7 @@ definition." "Re-run all tests, using the same selector. To be used in the ERT results buffer." - (interactive) + (interactive nil ert-results-mode) (cl-assert (eql major-mode 'ert-results-mode)) (let ((selector (ert--stats-selector ert--results-stats))) (ert-run-tests-interactively selector (buffer-name)))) @@ -2397,7 +2380,7 @@ To be used in the ERT results buffer." "Re-run the test at point. To be used in the ERT results buffer." - (interactive) + (interactive nil ert-results-mode) (cl-destructuring-bind (test redefinition-state) (ert--results-test-at-point-allow-redefinition) (when (null test) @@ -2432,7 +2415,7 @@ To be used in the ERT results buffer." "Re-run the test at point with `ert-debug-on-error' bound to t. To be used in the ERT results buffer." - (interactive) + (interactive nil ert-results-mode) (let ((ert-debug-on-error t)) (ert-results-rerun-test-at-point))) @@ -2440,7 +2423,7 @@ To be used in the ERT results buffer." "Display the backtrace for the test at point. To be used in the ERT results buffer." - (interactive) + (interactive nil ert-results-mode) (let* ((test (ert--results-test-at-point-no-redefinition t)) (stats ert--results-stats) (pos (ert--stats-test-pos stats test)) @@ -2467,7 +2450,7 @@ To be used in the ERT results buffer." "Display the part of the *Messages* buffer generated during the test at point. To be used in the ERT results buffer." - (interactive) + (interactive nil ert-results-mode) (let* ((test (ert--results-test-at-point-no-redefinition t)) (stats ert--results-stats) (pos (ert--stats-test-pos stats test)) @@ -2488,7 +2471,7 @@ To be used in the ERT results buffer." "Display the list of `should' forms executed during the test at point. To be used in the ERT results buffer." - (interactive) + (interactive nil ert-results-mode) (let* ((test (ert--results-test-at-point-no-redefinition t)) (stats ert--results-stats) (pos (ert--stats-test-pos stats test)) @@ -2524,7 +2507,7 @@ To be used in the ERT results buffer." "Toggle how much of the condition to print for the test at point. To be used in the ERT results buffer." - (interactive) + (interactive nil ert-results-mode) (let* ((ewoc ert--results-ewoc) (node (ert--results-test-node-at-point)) (entry (ewoc-data node))) @@ -2536,7 +2519,7 @@ To be used in the ERT results buffer." "Display test timings for the last run. To be used in the ERT results buffer." - (interactive) + (interactive nil ert-results-mode) (let* ((stats ert--results-stats) (buffer (get-buffer-create "*ERT timings*")) (data (cl-loop for test across (ert--stats-tests stats) @@ -2615,7 +2598,7 @@ To be used in the ERT results buffer." "Display the documentation of the test at point. To be used in the ERT results buffer." - (interactive) + (interactive nil ert-results-mode) (ert-describe-test (ert--results-test-at-point-no-redefinition t))) 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/faceup.el b/lisp/emacs-lisp/faceup.el index 6c3931f9829..162c39634ed 100644 --- a/lisp/emacs-lisp/faceup.el +++ b/lisp/emacs-lisp/faceup.el @@ -1170,11 +1170,6 @@ Intended to be called when a file is loaded." ;; File is being evaluated using, for example, `eval-buffer'. default-directory))) - -;; ---------------------------------------------------------------------- -;; The end -;; - (provide 'faceup) ;;; faceup.el ends here 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..0e86b923c4a 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. @@ -31,6 +31,7 @@ (with-suppressed-warnings ((lexical pi)) (defconst pi float-pi "Obsolete since Emacs-23.3. Use `float-pi' instead.")) +(make-obsolete-variable 'pi 'float-pi "23.3") (internal-make-var-non-special 'pi) (defconst float-e (exp 1) "The value of e (2.7182818...).") diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el index 13aec1e6785..4ae20ba4205 100644 --- a/lisp/emacs-lisp/generator.el +++ b/lisp/emacs-lisp/generator.el @@ -1,6 +1,6 @@ ;;; generator.el --- generators -*- lexical-binding: t -*- -;;; Copyright (C) 2015-2021 Free Software Foundation, Inc. +;; Copyright (C) 2015-2021 Free Software Foundation, Inc. ;; Author: Daniel Colascione <dancol@dancol.org> ;; Keywords: extensions, elisp @@ -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,22 +720,25 @@ 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")) (result-symbol (cps--gensym "iter-do-result"))) - `(let (,var - ,result-symbol + `(let (,result-symbol (,done-symbol nil) (,it-symbol ,iterator)) - (while (not ,done-symbol) - (condition-case ,condition-symbol - (setf ,var (iter-next ,it-symbol)) - (iter-end-of-sequence - (setf ,result-symbol (cdr ,condition-symbol)) - (setf ,done-symbol t))) - (unless ,done-symbol ,@body)) + (while + (let ((,var + (condition-case ,condition-symbol + (iter-next ,it-symbol) + (iter-end-of-sequence + (setf ,result-symbol (cdr ,condition-symbol)) + (setf ,done-symbol t))))) + (unless ,done-symbol + ,@body + ;; Loop until done-symbol is set. + t))) ,result-symbol))) (defvar cl--loop-args) 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 c9eac70d8f3..ce48e578e0b 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -166,17 +166,34 @@ 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)) +;;;###autoload +(let ((spec (get 'compiler-macro 'edebug-declaration-spec))) + ;; It so happens that it's the same spec for gv-* as for compiler-macros. + ;; '(&or symbolp ("lambda" &define lambda-list lambda-doc def-body)) + (put 'gv-expander 'edebug-declaration-spec spec) + (put 'gv-setter 'edebug-declaration-spec spec)) + ;; (defmacro gv-define-expand (name expander) ;; "Use EXPANDER to handle NAME as a generalized var. ;; NAME is a symbol: the name of a function, macro, or special form. @@ -214,7 +231,8 @@ 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 symbolp "@gv-setter"] sexp def-body))) `(gv-define-expander ,name (lambda (do &rest args) (declare-function @@ -297,7 +315,7 @@ The return value is the last VAL in the list. ;; Autoload this `put' since a user might use C-u C-M-x on an expression ;; containing a non-trivial `push' even before gv.el was loaded. ;;;###autoload -(put 'gv-place 'edebug-form-spec 'edebug-match-form) +(def-edebug-elem-spec 'gv-place '(form)) ;; CL did the equivalent of: ;;(gv-define-macroexpand edebug-after (lambda (before index place) place)) @@ -406,6 +424,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. @@ -482,6 +511,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 @@ -516,9 +550,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) @@ -528,9 +565,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 @@ -552,7 +592,7 @@ binding mode." ;; dynamic binding mode as well. (eq (car-safe code) 'cons)) code - (macroexp--warn-and-return + (macroexp-warn-and-return "Use of gv-ref probably requires lexical-binding" code)))) 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/inline.el b/lisp/emacs-lisp/inline.el index d6106fe35d0..36d71a8c04d 100644 --- a/lisp/emacs-lisp/inline.el +++ b/lisp/emacs-lisp/inline.el @@ -262,7 +262,7 @@ See Info node `(elisp)Defining Functions' for more details." '(throw 'inline--just-use ;; FIXME: This would inf-loop by calling us right back when ;; macroexpand-all recurses to expand inline--form. - ;; (macroexp--warn-and-return (format ,@args) + ;; (macroexp-warn-and-return (format ,@args) ;; inline--form) inline--form)) diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index 9cba232e16f..73a33a553fb 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -109,11 +109,6 @@ ;; * Footer line --- marks end-of-file so it can be distinguished from ;; an expanded formfeed or the results of truncation. -;;; Change Log: - -;; Tue Jul 14 23:44:17 1992 ESR -;; * Created. - ;;; Code: ;;; Variables: @@ -208,6 +203,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 +214,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 +482,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..67b75460941 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) @@ -62,9 +62,6 @@ (modify-syntax-entry ?\t " " table) (modify-syntax-entry ?\f " " table) (modify-syntax-entry ?\n "> " table) - ;; This is probably obsolete since nowadays such features use overlays. - ;; ;; Give CR the same syntax as newline, for selective-display. - ;; (modify-syntax-entry ?\^m "> " table) (modify-syntax-entry ?\; "< " table) (modify-syntax-entry ?` "' " table) (modify-syntax-entry ?' "' " table) @@ -77,11 +74,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 +177,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 +198,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 +254,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 +463,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 +489,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,30 +513,28 @@ 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' ;; and that they get the wrong color. - ;; That user has violated the http://www.cliki.net/Naming+conventions: + ;; That user has violated the https://www.cliki.net/Naming+conventions: ;; CL (but not EL!) `with-' (context) and `do-' (iteration) (,(concat "(\\(\\(do-\\|with-\\)" lisp-mode-symbol-regexp "\\)") (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 +623,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 +641,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 +672,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)))) @@ -718,26 +740,25 @@ font-lock keywords will not be case sensitive." ;;; Generic Lisp mode. (defvar lisp-mode-map - (let ((map (make-sparse-keymap)) - (menu-map (make-sparse-keymap "Lisp"))) + (let ((map (make-sparse-keymap))) (set-keymap-parent map lisp-mode-shared-map) (define-key map "\e\C-x" 'lisp-eval-defun) (define-key map "\C-c\C-z" 'run-lisp) - (bindings--define-key map [menu-bar lisp] (cons "Lisp" menu-map)) - (bindings--define-key menu-map [run-lisp] - '(menu-item "Run inferior Lisp" run-lisp - :help "Run an inferior Lisp process, input and output via buffer `*inferior-lisp*'")) - (bindings--define-key menu-map [ev-def] - '(menu-item "Eval defun" lisp-eval-defun - :help "Send the current defun to the Lisp process made by M-x run-lisp")) - (bindings--define-key menu-map [ind-sexp] - '(menu-item "Indent sexp" indent-sexp - :help "Indent each line of the list starting just after point")) map) "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" +(easy-menu-define lisp-mode-menu lisp-mode-map + "Menu for ordinary Lisp mode." + '("Lisp" + ["Indent sexp" indent-sexp + :help "Indent each line of the list starting just after point"] + ["Eval defun" lisp-eval-defun + :help "Send the current defun to the Lisp process made by M-x run-lisp"] + ["Run inferior Lisp" run-lisp + :help "Run an inferior Lisp process, input and output via buffer `*inferior-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 +767,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 +798,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 +967,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 +997,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 +1012,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. @@ -1344,7 +1369,27 @@ and initial semicolons." (derived-mode-p 'emacs-lisp-mode)) emacs-lisp-docstring-fill-column fill-column))) - (fill-paragraph justify)) + (save-restriction + (save-excursion + (let ((ppss (syntax-ppss)) + (start (point))) + ;; If we're in a string, then narrow (roughly) to that + ;; string before filling. This avoids filling Lisp + ;; statements that follow the string. + (when (ppss-string-terminator ppss) + (goto-char (ppss-comment-or-string-start ppss)) + (beginning-of-line) + ;; The string may be unterminated -- in that case, don't + ;; narrow. + (when (ignore-errors + (progn + (forward-sexp 1) + t)) + (narrow-to-region (ppss-comment-or-string-start ppss) + (point)))) + ;; Move back to where we were. + (goto-char start) + (fill-paragraph justify))))) ;; Never return nil. t)) 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..df864464b77 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -112,7 +112,7 @@ and also to avoid outputting the warning during normal execution." (funcall (eval (cadr form))) (byte-compile-constant nil))) -(defun macroexp--compiling-p () +(defun macroexp-compiling-p () "Return non-nil if we're macroexpanding for the compiler." ;; FIXME: ¡¡Major Ugly Hack!! To determine whether the output of this ;; macro-expansion will be processed by the byte-compiler, we check @@ -120,29 +120,48 @@ and also to avoid outputting the warning during normal execution." (member '(declare-function . byte-compile-macroexpand-declare-function) macroexpand-all-environment)) +(defun macroexp-file-name () + "Return the name of the file from which the code comes. +Returns nil when we do not know. +A non-nil result is expected to be reliable when called from a macro in order +to find the file in which the macro's call was found, and it should be +reliable as well when used at the top-level of a file. +Other uses risk returning non-nil value that point to the wrong file." + ;; `eval-buffer' binds `current-load-list' but not `load-file-name', + ;; so prefer using it over using `load-file-name'. + (let ((file (car (last current-load-list)))) + (or (if (stringp file) file) + (bound-and-true-p byte-compile-current-file)))) + (defvar macroexp--warned (make-hash-table :test #'equal :weakness 'key)) -(defun macroexp--warn-and-return (msg form &optional compile-only) +(defun macroexp--warn-wrap (msg form) (let ((when-compiled (lambda () (byte-compile-warn "%s" msg)))) - (cond - ((null msg) form) - ((macroexp--compiling-p) - (if (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'. - form - (puthash form form macroexp--warned) - `(progn - (macroexp--funcall-if-compiled ',when-compiled) - ,form))) - (t - (unless compile-only - (message "%s%s" (if (stringp load-file-name) - (concat (file-relative-name load-file-name) ": ") - "") - msg)) - form)))) + `(progn + (macroexp--funcall-if-compiled ',when-compiled) + ,form))) + +(define-obsolete-function-alias 'macroexp--warn-and-return + #'macroexp-warn-and-return "28.1") +(defun macroexp-warn-and-return (msg form &optional compile-only) + (cond + ((null msg) form) + ((macroexp-compiling-p) + (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'. + form + (puthash form form macroexp--warned) + (macroexp--warn-wrap msg form))) + (t + (unless compile-only + (message "%sWarning: %s" + (if (stringp load-file-name) + (concat (file-relative-name load-file-name) ": ") + "") + msg)) + form))) (defun macroexp--obsolete-warning (fun obsolescence-data type) (let ((instead (car obsolescence-data)) @@ -180,8 +199,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)) @@ -190,7 +210,7 @@ and also to avoid outputting the warning during normal execution." (byte-compile-warning-enabled-p 'obsolete (car form)))) (let* ((fun (car form)) (obsolete (get fun 'byte-obsolete-info))) - (macroexp--warn-and-return + (macroexp-warn-and-return (macroexp--obsolete-warning fun obsolete (if (symbolp (symbol-function fun)) @@ -198,6 +218,69 @@ and also to avoid outputting the warning during normal execution." new-form)) new-form))) +(defun macroexp--unfold-lambda (form &optional name) + ;; In lexical-binding mode, let and functions don't bind vars in the same way + ;; (let obey special-variable-p, but functions don't). But luckily, this + ;; doesn't matter here, because function's behavior is underspecified so it + ;; can safely be turned into a `let', even though the reverse is not true. + (or name (setq name "anonymous lambda")) + (let* ((lambda (car form)) + (values (cdr form)) + (arglist (nth 1 lambda)) + (body (cdr (cdr lambda))) + optionalp restp + bindings) + (if (and (stringp (car body)) (cdr body)) + (setq body (cdr body))) + (if (and (consp (car body)) (eq 'interactive (car (car body)))) + (setq body (cdr body))) + ;; FIXME: The checks below do not belong in an optimization phase. + (while arglist + (cond ((eq (car arglist) '&optional) + ;; ok, I'll let this slide because funcall_lambda() does... + ;; (if optionalp (error "multiple &optional keywords in %s" name)) + (if restp (error "&optional found after &rest in %s" name)) + (if (null (cdr arglist)) + (error "nothing after &optional in %s" name)) + (setq optionalp t)) + ((eq (car arglist) '&rest) + ;; ...but it is by no stretch of the imagination a reasonable + ;; thing that funcall_lambda() allows (&rest x y) and + ;; (&rest x &optional y) in arglists. + (if (null (cdr arglist)) + (error "nothing after &rest in %s" name)) + (if (cdr (cdr arglist)) + (error "multiple vars after &rest in %s" name)) + (setq restp t)) + (restp + (setq bindings (cons (list (car arglist) + (and values (cons 'list values))) + bindings) + values nil)) + ((and (not optionalp) (null values)) + (setq arglist nil values 'too-few)) + (t + (setq bindings (cons (list (car arglist) (car values)) + bindings) + values (cdr values)))) + (setq arglist (cdr arglist))) + (if values + (macroexp-warn-and-return + (format (if (eq values 'too-few) + "attempt to open-code `%s' with too few arguments" + "attempt to open-code `%s' with too many arguments") + name) + form) + + ;; The following leads to infinite recursion when loading a + ;; file containing `(defsubst f () (f))', and then trying to + ;; byte-compile that file. + ;;(setq body (mapcar 'byte-optimize-form body))) + + (if bindings + `(let ,(nreverse bindings) . ,body) + (macroexp-progn body))))) + (defun macroexp--expand-all (form) "Expand all macros in FORM. This is an internal version of `macroexpand-all'. @@ -211,10 +294,12 @@ Assumes the caller has bound `macroexpand-all-environment'." macroexpand-all-environment) ;; Normal form; get its expansion, and then expand arguments. (setq form (macroexp-macroexpand form macroexpand-all-environment)) + ;; FIXME: It'd be nice to use `byte-optimize--pcase' here, but when + ;; I tried it, it broke the bootstrap :-( (pcase form (`(cond . ,clauses) (macroexp--cons 'cond (macroexp--all-clauses clauses) form)) - (`(condition-case . ,(or `(,err ,body . ,handlers) dontcare)) + (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare)) (macroexp--cons 'condition-case (macroexp--cons err @@ -231,46 +316,57 @@ Assumes the caller has bound `macroexpand-all-environment'." (cdr form)) form)) (`(,(or 'function 'quote) . ,_) form) - (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) dontcare)) + (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) + pcase--dontcare)) (macroexp--cons fun (macroexp--cons (macroexp--all-clauses bindings 1) - (macroexp--all-forms body) + (if (null body) + (macroexp-unprogn + (macroexp-warn-and-return + (format "Empty %s body" fun) + nil t)) + (macroexp--all-forms body)) (cdr form)) form)) (`(,(and fun `(lambda . ,_)) . ,args) ;; Embedded lambda in function position. - (macroexp--cons (macroexp--all-forms fun 2) - (macroexp--all-forms args) - form)) - ;; 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 - ;; by treating a lambda expression quoted by `quote' as if it - ;; were quoted by `function'. We make the same transformation - ;; here, so that any code that cares about the difference will - ;; see the same transformation. - ;; First arg is a function: - (`(,(and fun (or 'funcall 'apply 'mapcar 'mapatoms 'mapconcat 'mapc)) - ',(and f `(lambda . ,_)) . ,args) - (macroexp--warn-and-return - (format "%s quoted with ' rather than with #'" - (list 'lambda (nth 1 f) '...)) - (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))) + ;; 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 (macroexp--unfold-lambda form))) + (if (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)))) + + (`(funcall . ,(or `(,exp . ,args) pcase--dontcare)) + (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 - ;; use macros. - (let ((handler (function-get func 'compiler-macro))) + (let ((handler (function-get func 'compiler-macro)) + (funargs (function-get func 'funarg-positions))) + ;; Check functions quoted with ' rather than with #' + (dolist (funarg funargs) + (let ((arg (nth funarg form))) + (when (and (eq 'quote (car-safe arg)) + (eq 'lambda (car-safe (cadr arg)))) + (setcar (nthcdr funarg form) + (macroexp-warn-and-return + (format "%S quoted with ' rather than with #'" + (let ((f (cadr arg))) + (if (symbolp f) f `(lambda ,(nth 1 f) ...)))) + arg))))) + ;; Macro expand compiler macros. This cannot be delayed to + ;; byte-optimize-form because the output of the compiler-macro can + ;; use macros. (if (null handler) ;; No compiler macro. We just expand each argument (for ;; setq/setq-default this works alright because the variable names @@ -296,6 +392,19 @@ Assumes the caller has bound `macroexpand-all-environment'." (_ form)))) +;; Record which arguments expect functions, so we can warn when those +;; are accidentally quoted with ' rather than with #' +(dolist (f '( funcall apply mapcar mapatoms mapconcat mapc cl-mapcar maphash + map-char-table map-keymap map-keymap-internal)) + (put f 'funarg-positions '(1))) +(dolist (f '( add-hook remove-hook advice-remove advice--remove-function + defalias fset global-set-key run-after-idle-timeout + set-process-filter set-process-sentinel sort)) + (put f 'funarg-positions '(2))) +(dolist (f '( advice-add define-key + run-at-time run-with-idle-timer run-with-timer )) + (put f 'funarg-positions '(3))) + ;;;###autoload (defun macroexpand-all (form &optional environment) "Return result of expanding macros at all levels in FORM. @@ -358,12 +467,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 +589,50 @@ 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 '()) + ;; Cyclic code should not happen, but code can contain cyclic data :-( + (seen (make-hash-table :test #'eq)) + (sexpss (list (list sexp)))) + ;; Use a nested while loop to reduce the amount of heap allocations for + ;; pushes to `sexpss' and the `gethash' overhead. + (while (and sexpss bindings) + (let ((sexps (pop sexpss))) + (unless (gethash sexps seen) + (puthash sexps t seen) ;; Using `setf' here causes bootstrap problems. + (if (vectorp sexps) (setq sexps (mapcar #'identity sexps))) + (let ((tortoise sexps) (skip t)) + (while sexps + (let ((sexp (if (consp sexps) (pop sexps) + (prog1 sexps (setq sexps nil))))) + (if skip + (setq skip nil) + (setq tortoise (cdr tortoise)) + (if (eq tortoise sexps) + (setq sexps nil) ;; Found a cycle: we're done! + (setq skip t))) + (cond + ((or (consp sexp) (vectorp sexp)) (push sexp sexpss)) + (t + (let ((tmp (assq sexp bindings))) + (when tmp + (push tmp res) + (setq bindings (remove tmp bindings)))))))))))) + res)) + ;;; Load-time macro-expansion. ;; Because macro-expansion used to be more lazy, eager macro-expansion diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index 14112a1c147..86a0c76fd16 100644 --- a/lisp/emacs-lisp/map-ynp.el +++ b/lisp/emacs-lisp/map-ynp.el @@ -265,7 +265,8 @@ C-g to quit (cancel the whole command); "If non-nil, `read-answer' accepts single-character answers. If t, accept short (single key-press) answers to the question. If nil, require long answers. If `auto', accept short answers if -the function cell of `yes-or-no-p' is set to `y-or-n-p'." +`use-short-answers' is non-nil, or the function cell of `yes-or-no-p' +is set to `y-or-n-p'." :type '(choice (const :tag "Accept short answers" t) (const :tag "Require long answer" nil) (const :tag "Guess preference" auto)) @@ -304,7 +305,8 @@ Return a long answer even in case of accepting short ones. When `use-dialog-box' is t, pop up a dialog window to get user input." (let* ((short (if (eq read-answer-short 'auto) - (eq (symbol-function 'yes-or-no-p) 'y-or-n-p) + (or use-short-answers + (eq (symbol-function 'yes-or-no-p) 'y-or-n-p)) read-answer-short)) (answers-with-help (if (assoc "help" answers) diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index 8fa36da6e17..c0cbc7b5a18 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -3,12 +3,10 @@ ;; Copyright (C) 2015-2021 Free Software Foundation, Inc. ;; Author: Nicolas Petton <nicolas@petton.fr> -;; Keywords: convenience, map, hash-table, alist, array -;; Version: 2.0 -;; Package-Requires: ((emacs "25")) -;; Package: map - ;; Maintainer: emacs-devel@gnu.org +;; Keywords: extensions, lisp +;; Version: 3.0 +;; Package-Requires: ((emacs "26")) ;; This file is part of GNU Emacs. @@ -27,8 +25,9 @@ ;;; Commentary: -;; map.el provides map-manipulation functions that work on alists, -;; hash-table and arrays. All functions are prefixed with "map-". +;; map.el provides generic map-manipulation functions that work on +;; alists, plists, hash-tables, and arrays. All functions are +;; prefixed with "map-". ;; ;; Functions taking a predicate or iterating over a map using a ;; function take the function as their first argument. All other @@ -54,10 +53,12 @@ ARGS is a list of elements to be matched in the map. Each element of ARGS can be of the form (KEY PAT), in which case KEY is 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. +associated with 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." @@ -73,7 +74,7 @@ bound to the looked up value in MAP. KEYS can also be a list of (KEY VARNAME) pairs, in which case KEY is an unquoted form. -MAP can be a list, hash-table or array." +MAP can be an alist, plist, hash-table, or array." (declare (indent 2) (debug ((&rest &or symbolp ([form symbolp])) form body))) `(pcase-let ((,(map--make-pcase-patterns keys) ,map)) @@ -99,7 +100,7 @@ Returns the result of evaluating the form associated with MAP-VAR's type." (define-error 'map-not-inplace "Cannot modify map in-place") (defsubst map--plist-p (list) - (and (consp list) (not (listp (car list))))) + (and (consp list) (atom (car list)))) (cl-defgeneric map-elt (map key &optional default testfn) "Lookup KEY in MAP and return its associated value. @@ -107,7 +108,8 @@ If KEY is not found, return DEFAULT which defaults to nil. TESTFN is deprecated. Its default depends on the MAP argument. -In the base definition, MAP can be an alist, hash-table, or array." +In the base definition, MAP can be an alist, plist, hash-table, +or array." (declare (gv-expander (lambda (do) @@ -125,26 +127,25 @@ In the base definition, MAP can be an alist, hash-table, or array." `(map-insert ,mgetter ,key ,v)))))))))) ;; `testfn' is deprecated. (advertised-calling-convention (map key &optional default) "27.1")) + ;; Can't use `cl-defmethod' with `advertised-calling-convention'. (map--dispatch map :list (if (map--plist-p map) - (let ((res (plist-get map key))) - (if (and default (null res) (not (plist-member map key))) - default - res)) + (let ((res (plist-member map key))) + (if res (cadr res) default)) (alist-get key map default nil testfn)) :hash-table (gethash key map default) - :array (if (and (>= key 0) (< key (seq-length map))) - (seq-elt map key) + :array (if (map-contains-key map key) + (aref map key) default))) (defmacro map-put (map key value &optional testfn) "Associate KEY with VALUE in MAP and return VALUE. If KEY is already present in MAP, replace the associated value with VALUE. -When MAP is a list, test equality with TESTFN if non-nil, +When MAP is an alist, test equality with TESTFN if non-nil, otherwise use `eql'. -MAP can be a list, hash-table or array." +MAP can be an alist, plist, hash-table, or array." (declare (obsolete "use map-put! or (setf (map-elt ...) ...) instead" "27.1")) `(setf (map-elt ,map ,key nil ,testfn) ,value)) @@ -166,23 +167,30 @@ MAP can be a list, hash-table or array." (cl-defgeneric map-delete (map key) "Delete KEY in-place from MAP and return MAP. -No error is signaled if KEY is not a key of MAP. -If MAP is an array, store nil at the index KEY." - (map--dispatch map - ;; FIXME: Signal map-not-inplace i.s.o returning a different list? - :list (if (map--plist-p map) - (setq map (map--plist-delete map key)) - (setf (alist-get key map nil t) nil)) - :hash-table (remhash key map) - :array (and (>= key 0) - (<= key (seq-length map)) - (aset map key nil))) +Keys not present in MAP are ignored.") + +(cl-defmethod map-delete ((map list) key) + ;; FIXME: Signal map-not-inplace i.s.o returning a different list? + (if (map--plist-p map) + (map--plist-delete map key) + (setf (alist-get key map nil t) nil) + map)) + +(cl-defmethod map-delete ((map hash-table) key) + (remhash key map) + map) + +(cl-defmethod map-delete ((map array) key) + "Store nil at index KEY." + (when (map-contains-key map key) + (aset map key nil)) map) (defun map-nested-elt (map keys &optional default) "Traverse MAP using KEYS and return the looked up value or DEFAULT if nil. -Map can be a nested map composed of alists, hash-tables and arrays." +MAP can be a nested map composed of alists, plists, hash-tables, +and arrays." (or (seq-reduce (lambda (acc key) (when (mapp acc) (map-elt acc key))) @@ -200,30 +208,49 @@ The default implementation delegates to `map-apply'." The default implementation delegates to `map-apply'." (map-apply (lambda (_ value) value) map)) +(cl-defmethod map-values ((map array)) + "Convert MAP into a list." + (append map ())) + (cl-defgeneric map-pairs (map) - "Return the elements of MAP as key/value association lists. + "Return the key/value pairs in MAP as an alist. The default implementation delegates to `map-apply'." (map-apply #'cons map)) (cl-defgeneric map-length (map) ;; FIXME: Should we rename this to `map-size'? - "Return the number of elements in the map. -The default implementation counts `map-keys'." - (cond - ((hash-table-p map) (hash-table-count map)) - ((listp map) - ;; FIXME: What about repeated/shadowed keys? - (if (map--plist-p map) (/ (length map) 2) (length map))) - ((arrayp map) (length map)) - (t (length (map-keys map))))) + "Return the number of key/value pairs in MAP. +Note that this does not always reflect the number of unique keys. +The default implementation delegates to `map-do'." + (let ((size 0)) + (map-do (lambda (_k _v) (setq size (1+ size))) map) + size)) + +(cl-defmethod map-length ((map hash-table)) + (hash-table-count map)) + +(cl-defmethod map-length ((map list)) + (if (map--plist-p map) + (/ (length map) 2) + (length map))) + +(cl-defmethod map-length ((map array)) + (length map)) (cl-defgeneric map-copy (map) - "Return a copy of MAP." - ;; FIXME: Clarify how deep is the copy! - (map--dispatch map - :list (seq-copy map) ;FIXME: Probably not deep enough for alists! - :hash-table (copy-hash-table map) - :array (seq-copy map))) + "Return a copy of MAP.") + +(cl-defmethod map-copy ((map list)) + "Use `copy-alist' on alists and `copy-sequence' on plists." + (if (map--plist-p map) + (copy-sequence map) + (copy-alist map))) + +(cl-defmethod map-copy ((map hash-table)) + (copy-hash-table map)) + +(cl-defmethod map-copy ((map array)) + (copy-sequence map)) (cl-defgeneric map-apply (function map) "Apply FUNCTION to each element of MAP and return the result as a list. @@ -241,26 +268,28 @@ FUNCTION is called with two arguments, the key and the value.") (cl-defmethod map-do (function (map hash-table)) (maphash function map)) (cl-defgeneric map-keys-apply (function map) - "Return the result of applying FUNCTION to each key of MAP. + "Return the result of applying FUNCTION to each key in MAP. The default implementation delegates to `map-apply'." (map-apply (lambda (key _) (funcall function key)) map)) (cl-defgeneric map-values-apply (function map) - "Return the result of applying FUNCTION to each value of MAP. + "Return the result of applying FUNCTION to each value in MAP. The default implementation delegates to `map-apply'." (map-apply (lambda (_ val) (funcall function val)) map)) +(cl-defmethod map-values-apply (function (map array)) + (mapcar function map)) + (cl-defgeneric map-filter (pred map) "Return an alist of key/val pairs for which (PRED key val) is non-nil in MAP. The default implementation delegates to `map-apply'." (delq nil (map-apply (lambda (key val) - (if (funcall pred key val) - (cons key val) - nil)) + (and (funcall pred key val) + (cons key val))) map))) (cl-defgeneric map-remove (pred map) @@ -270,7 +299,7 @@ The default implementation delegates to `map-filter'." map)) (cl-defgeneric mapp (map) - "Return non-nil if MAP is a map (alist, hash-table, array, ...)." + "Return non-nil if MAP is a map (alist/plist, hash-table, array, ...)." (or (listp map) (hash-table-p map) (arrayp map))) @@ -290,56 +319,58 @@ The default implementation delegates to `map-length'." ;; test function! "Return non-nil if and only if MAP contains KEY. TESTFN is deprecated. Its default depends on MAP. -The default implementation delegates to `map-do'." +The default implementation delegates to `map-some'." (unless testfn (setq testfn #'equal)) - (catch 'map--catch - (map-do (lambda (k _v) - (if (funcall testfn key k) (throw 'map--catch t))) - map) - nil)) + (map-some (lambda (k _v) (funcall testfn key k)) map)) (cl-defmethod map-contains-key ((map list) key &optional testfn) - (let ((v '(nil))) - (not (eq v (alist-get key map v nil (or testfn #'equal)))))) + "Return non-nil if MAP contains KEY. +If MAP is an alist, TESTFN defaults to `equal'. +If MAP is a plist, `plist-member' is used instead." + (if (map--plist-p map) + (plist-member map key) + (let ((v '(nil))) + (not (eq v (alist-get key map v nil (or testfn #'equal))))))) (cl-defmethod map-contains-key ((map array) key &optional _testfn) - (and (integerp key) - (>= key 0) - (< key (length map)))) + "Return non-nil if KEY is an index of MAP, ignoring TESTFN." + (and (natnump key) (< key (length map)))) (cl-defmethod map-contains-key ((map hash-table) key &optional _testfn) + "Return non-nil if MAP contains KEY, ignoring TESTFN." (let ((v '(nil))) (not (eq v (gethash key map v))))) (cl-defgeneric map-some (pred map) "Return the first non-nil (PRED key val) in MAP. -The default implementation delegates to `map-apply'." +Return nil if no such element is found. +The default implementation delegates to `map-do'." ;; FIXME: Not sure if there's much benefit to defining it as defgeneric, ;; since as defined, I can't think of a map-type where we could provide an ;; algorithmically more efficient algorithm than the default. (catch 'map--break - (map-apply (lambda (key value) - (let ((result (funcall pred key value))) - (when result - (throw 'map--break result)))) - map) + (map-do (lambda (key value) + (let ((result (funcall pred key value))) + (when result + (throw 'map--break result)))) + map) nil)) (cl-defgeneric map-every-p (pred map) "Return non-nil if (PRED key val) is non-nil for all elements of MAP. -The default implementation delegates to `map-apply'." +The default implementation delegates to `map-do'." ;; FIXME: Not sure if there's much benefit to defining it as defgeneric, ;; since as defined, I can't think of a map-type where we could provide an ;; algorithmically more efficient algorithm than the default. (catch 'map--break - (map-apply (lambda (key value) + (map-do (lambda (key value) (or (funcall pred key value) (throw 'map--break nil))) map) t)) (defun map-merge (type &rest maps) - "Merge into a map of type TYPE all the key/value pairs in MAPS. + "Merge into a map of TYPE all the key/value pairs in MAPS. See `map-into' for all supported values of TYPE." (let ((result (map-into (pop maps) type))) (while maps @@ -347,48 +378,57 @@ See `map-into' for all supported values of TYPE." ;; For small tables, this is fine, but for large tables, we ;; should probably use a hash-table internally which we convert ;; to an alist in the end. - (map-apply (lambda (key value) - (setf (map-elt result key) value)) - (pop maps))) + (map-do (lambda (key value) + (setf (map-elt result key) value)) + (pop maps))) result)) (defun map-merge-with (type function &rest maps) - "Merge into a map of type TYPE all the key/value pairs in MAPS. -When two maps contain the same key (`eql'), call FUNCTION on the two + "Merge into a map of TYPE all the key/value pairs in MAPS. +When two maps contain the same (`eql') key, call FUNCTION on the two values and use the value returned by it. -MAP can be a list, hash-table or array. +Each of MAPS can be an alist, plist, hash-table, or array. See `map-into' for all supported values of TYPE." (let ((result (map-into (pop maps) type)) - (not-found (cons nil nil))) + (not-found (list nil))) (while maps - (map-apply (lambda (key value) - (cl-callf (lambda (old) - (if (eql old not-found) - value - (funcall function old value))) - (map-elt result key not-found))) - (pop maps))) + (map-do (lambda (key value) + (cl-callf (lambda (old) + (if (eql old not-found) + value + (funcall function old value))) + (map-elt result key not-found))) + (pop maps))) result)) (cl-defgeneric map-into (map type) - "Convert the map MAP into a map of type TYPE.") + "Convert MAP into a map of TYPE.") + ;; FIXME: I wish there was a way to avoid this η-redex! -(cl-defmethod map-into (map (_type (eql list))) (map-pairs map)) -(cl-defmethod map-into (map (_type (eql alist))) (map-pairs map)) +(cl-defmethod map-into (map (_type (eql list))) + "Convert MAP into an alist." + (map-pairs map)) + +(cl-defmethod map-into (map (_type (eql alist))) + "Convert MAP into an alist." + (map-pairs map)) + (cl-defmethod map-into (map (_type (eql plist))) - (let ((plist '())) - (map-do (lambda (k v) (setq plist `(,k ,v ,@plist))) map) - plist)) + "Convert MAP into a plist." + (let (plist) + (map-do (lambda (k v) (setq plist `(,v ,k ,@plist))) map) + (nreverse plist))) (cl-defgeneric map-put! (map key value &optional testfn) "Associate KEY with VALUE in MAP. If KEY is already present in MAP, replace the associated value with VALUE. This operates by modifying MAP in place. -If it cannot do that, it signals the `map-not-inplace' error. -If you want to insert an element without modifying MAP, use `map-insert'." +If it cannot do that, it signals a `map-not-inplace' error. +To insert an element without modifying MAP, use `map-insert'." ;; `testfn' only exists for backward compatibility with `map-put'! (declare (advertised-calling-convention (map key value) "27.1")) + ;; Can't use `cl-defmethod' with `advertised-calling-convention'. (map--dispatch map :list (if (map--plist-p map) @@ -402,18 +442,20 @@ If you want to insert an element without modifying MAP, use `map-insert'." ;; and let `map-insert' grow the array? :array (aset map key value))) -(define-error 'map-inplace "Can only modify map in place") - (cl-defgeneric map-insert (map key value) "Return a new map like MAP except that it associates KEY with VALUE. This does not modify MAP. -If you want to insert an element in place, use `map-put!'." - (if (listp map) - (if (map--plist-p map) - `(,key ,value ,@map) - (cons (cons key value) map)) - ;; FIXME: Should we signal an error or use copy+put! ? - (signal 'map-inplace (list map)))) +If you want to insert an element in place, use `map-put!'. +The default implementation defaults to `map-copy' and `map-put!'." + (let ((copy (map-copy map))) + (map-put! copy key value) + copy)) + +(cl-defmethod map-insert ((map list) key value) + "Cons KEY and VALUE to the front of MAP." + (if (map--plist-p map) + (cons key (cons value map)) + (cons (cons key value) map))) ;; There shouldn't be old source code referring to `map--put', yet we do ;; need to keep it for backward compatibility with .elc files where the @@ -423,11 +465,9 @@ If you want to insert an element in place, use `map-put!'." (cl-defmethod map-apply (function (map list)) (if (map--plist-p map) (cl-call-next-method) - (seq-map (lambda (pair) - (funcall function - (car pair) - (cdr pair))) - map))) + (mapcar (lambda (pair) + (funcall function (car pair) (cdr pair))) + map))) (cl-defmethod map-apply (function (map hash-table)) (let (result) @@ -437,46 +477,40 @@ If you want to insert an element in place, use `map-put!'." (nreverse result))) (cl-defmethod map-apply (function (map array)) - (let ((index 0)) - (seq-map (lambda (elt) - (prog1 - (funcall function index elt) - (setq index (1+ index)))) - map))) + (seq-map-indexed (lambda (elt index) + (funcall function index elt)) + map)) (cl-defmethod map-do (function (map list)) - "Private function used to iterate over ALIST using FUNCTION." (if (map--plist-p map) (while map (funcall function (pop map) (pop map))) - (seq-do (lambda (pair) - (funcall function - (car pair) - (cdr pair))) - map))) + (mapc (lambda (pair) + (funcall function (car pair) (cdr pair))) + map) + nil)) -(cl-defmethod map-do (function (array array)) - "Private function used to iterate over ARRAY using FUNCTION." +(cl-defmethod map-do (function (map array)) (seq-do-indexed (lambda (elt index) - (funcall function index elt)) - array)) + (funcall function index elt)) + map)) (defun map--into-hash (map keyword-args) "Convert MAP into a hash-table. KEYWORD-ARGS are forwarded to `make-hash-table'." (let ((ht (apply #'make-hash-table keyword-args))) - (map-apply (lambda (key value) - (setf (gethash key ht) value)) - map) + (map-do (lambda (key value) + (puthash key value ht)) + map) ht)) (cl-defmethod map-into (map (_type (eql hash-table))) - "Convert MAP into a hash-table." - (map--into-hash map (list :size (map-length map) :test 'equal))) + "Convert MAP into a hash-table with keys compared with `equal'." + (map--into-hash map (list :size (map-length map) :test #'equal))) (cl-defmethod map-into (map (type (head hash-table))) "Convert MAP into a hash-table. -TYPE is a list where the car is `hash-table' and the cdr are the +TYPE is a list whose car is `hash-table' and cdr a list of keyword-args forwarded to `make-hash-table'. Example: @@ -485,20 +519,23 @@ 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))) - args)) + (mapcar (lambda (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) "Return a list of `(map ...)' pcase patterns built from ARGS." (cons 'map - (seq-map (lambda (elt) - (if (and (consp elt) (eq 'map (car elt))) - (map--make-pcase-patterns elt) - elt)) - args))) + (mapcar (lambda (elt) + (if (eq (car-safe elt) 'map) + (map--make-pcase-patterns elt) + elt)) + args))) (provide 'map) ;;; map.el ends here diff --git a/lisp/emacs-lisp/memory-report.el b/lisp/emacs-lisp/memory-report.el new file mode 100644 index 00000000000..f4f03133b0f --- /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 + ;; heavy. + (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)))) + (let ((next (cdr value))) + (setq value (when next + (if (consp next) + (unless (gethash next counted) + (cdr value)) + (cl-incf total (memory-report--object-size + counted next)) + 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 (and (consp elem) (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..2ecd92cee9d 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 @@ -2152,10 +2206,13 @@ directory." (package-install-from-buffer))) ;;;###autoload -(defun package-install-selected-packages () +(defun package-install-selected-packages (&optional noconfirm) "Ensure packages in `package-selected-packages' are installed. -If some packages are not installed propose to install them." +If some packages are not installed, propose to install them. +If optional argument NOCONFIRM is non-nil, don't ask for +confirmation to install packages." (interactive) + (package--archives-initialize) ;; We don't need to populate `package-selected-packages' before ;; using here, because the outcome is the same either way (nothing ;; gets installed). @@ -2166,10 +2223,11 @@ If some packages are not installed propose to install them." (difference (- (length not-installed) (length available)))) (cond (available - (when (y-or-n-p - (format "Packages to install: %d (%s), proceed? " - (length available) - (mapconcat #'symbol-name available " "))) + (when (or noconfirm + (y-or-n-p + (format "Packages to install: %d (%s), proceed? " + (length available) + (mapconcat #'symbol-name available " ")))) (mapc (lambda (p) (package-install p 'dont-select)) available))) ((> difference 0) (message "Packages that are not available: %d (the rest is already installed), maybe you need to `M-x package-refresh-contents'" @@ -2319,10 +2377,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 +2433,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 +2630,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 +2670,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 +2680,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 +2734,23 @@ 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 "w" 'package-browse-url) (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.") @@ -2712,6 +2758,8 @@ either a full name or nil, and EMAIL is a valid email address." "Menu for `package-menu-mode'." '("Package" ["Describe Package" package-menu-describe-package :help "Display information about this package"] + ["Open Package Homepage" package-browse-url + :help "Open the homepage of this package"] ["Help" package-menu-quick-help :help "Show short key binding help for package-menu-mode"] "--" ["Refresh Package List" revert-buffer @@ -2730,8 +2778,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"] @@ -2754,15 +2809,16 @@ either a full name or nil, and EMAIL is a valid email address." Letters do not insert themselves; instead, they are commands. \\<package-menu-mode-map> \\{package-menu-mode-map}" + :interactive nil (setq mode-line-process '((package--downloads-in-progress ":Loading") (package-menu--transaction-status package-menu--transaction-status))) (setq tabulated-list-format - `[("Package" 18 package-menu--name-predicate) - ("Version" 13 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)) @@ -2876,7 +2932,7 @@ Installed obsolete packages are always displayed.") Also hide packages whose name matches a regexp in user option `package-hidden-regexps' (a list). To add regexps to this list, use `package-menu-hide-package'." - (interactive) + (interactive nil package-menu-mode) (package--ensure-package-menu-mode) (setq package-menu--hide-packages (not package-menu--hide-packages)) @@ -3041,8 +3097,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 +3119,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 +3268,9 @@ To unhide a package, type `\\[customize-variable] RET package-hidden-regexps'. Type \\[package-menu-toggle-hiding] to toggle package hiding." - (interactive) - (package--ensure-package-menu-mode) (declare (interactive-only "change `package-hidden-regexps' instead.")) + (interactive nil package-menu-mode) + (package--ensure-package-menu-mode) (let* ((name (when (derived-mode-p 'package-menu-mode) (concat "\\`" (regexp-quote (symbol-name (package-desc-name (tabulated-list-get-id)))) @@ -3227,7 +3293,7 @@ Type \\[package-menu-toggle-hiding] to toggle package hiding." (defun package-menu-describe-package (&optional button) "Describe the current package. If optional arg BUTTON is non-nil, describe its associated package." - (interactive) + (interactive nil package-menu-mode) (let ((pkg-desc (if button (button-get button 'package-desc) (tabulated-list-get-id)))) (if pkg-desc @@ -3237,7 +3303,7 @@ If optional arg BUTTON is non-nil, describe its associated package." ;; fixme numeric argument (defun package-menu-mark-delete (&optional _num) "Mark a package for deletion and move to the next line." - (interactive "p") + (interactive "p" package-menu-mode) (package--ensure-package-menu-mode) (if (member (package-menu-get-status) '("installed" "dependency" "obsolete" "unsigned")) @@ -3246,7 +3312,7 @@ If optional arg BUTTON is non-nil, describe its associated package." (defun package-menu-mark-install (&optional _num) "Mark a package for installation and move to the next line." - (interactive "p") + (interactive "p" package-menu-mode) (package--ensure-package-menu-mode) (if (member (package-menu-get-status) '("available" "avail-obso" "new" "dependency")) (tabulated-list-put-tag "I" t) @@ -3254,20 +3320,20 @@ If optional arg BUTTON is non-nil, describe its associated package." (defun package-menu-mark-unmark (&optional _num) "Clear any marks on a package and move to the next line." - (interactive "p") + (interactive "p" package-menu-mode) (package--ensure-package-menu-mode) (tabulated-list-put-tag " " t)) (defun package-menu-backup-unmark () "Back up one line and clear any marks on that package." - (interactive) + (interactive nil package-menu-mode) (package--ensure-package-menu-mode) (forward-line -1) (tabulated-list-put-tag " ")) (defun package-menu-mark-obsolete-for-deletion () "Mark all obsolete packages for deletion." - (interactive) + (interactive nil package-menu-mode) (package--ensure-package-menu-mode) (save-excursion (goto-char (point-min)) @@ -3298,7 +3364,7 @@ If optional arg BUTTON is non-nil, describe its associated package." (defun package-menu-quick-help () "Show short key binding help for `package-menu-mode'. The full list of keys can be viewed with \\[describe-mode]." - (interactive) + (interactive nil package-menu-mode) (package--ensure-package-menu-mode) (message (mapconcat #'package--prettify-quick-help-key package--quick-help-keys "\n"))) @@ -3394,7 +3460,7 @@ call will upgrade the package. If there's an async refresh operation in progress, the flags will be placed as part of `package-menu--post-refresh' instead of immediately." - (interactive) + (interactive nil package-menu-mode) (package--ensure-package-menu-mode) (if (not package--downloads-in-progress) (package-menu--mark-upgrades-1) @@ -3488,7 +3554,7 @@ packages list, respectively." Packages marked for installation are downloaded and installed; packages marked for deletion are removed. Optional argument NOQUERY non-nil means do not ask the user to confirm." - (interactive) + (interactive nil package-menu-mode) (package--ensure-package-menu-mode) (let (install-list delete-list cmd pkg-desc) (save-excursion @@ -3675,7 +3741,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,52 +3766,251 @@ 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-menu-mode) + (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-menu-mode) + (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))) + package-menu-mode) (package--ensure-package-menu-mode) - (package-show-package-list t (if (stringp keyword) - (list keyword) - keyword))) + (when (stringp keyword) + (setq keyword (list 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-menu-mode) + (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-menu-mode) (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-menu-mode) + (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))) + package-menu-mode) + (package--ensure-package-menu-mode) + (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 nil package-menu-mode) + (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 nil package-menu-mode) + (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." - (interactive) + (interactive nil package-menu-mode) (package--ensure-package-menu-mode) (package-menu--generate t t)) @@ -3766,10 +4031,7 @@ The return value is a string (or nil in case we can't find it)." ;; the version at compile time and hardcodes it into the .elc file! (declare (pure t)) ;; Hack alert! - (let ((file - (or (if (boundp 'byte-compile-current-file) byte-compile-current-file) - load-file-name - buffer-file-name))) + (let ((file (or (macroexp-file-name) buffer-file-name))) (cond ((null file) nil) ;; Packages are normally installed into directories named "<pkg>-<vers>", @@ -3790,6 +4052,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 +4074,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 +4087,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 +4142,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 +4167,31 @@ beginning of the line." (package-version-join (package-desc-version package-desc)) (package-desc-summary package-desc)))) +(defun package-browse-url (desc &optional secondary) + "Open the home page of the package under point in a browser. +`browse-url' is used to determine the browser to be used. +If SECONDARY (interactively, the prefix), use the secondary browser." + (interactive (list (tabulated-list-get-id) + current-prefix-arg) + package-menu-mode) + (unless desc + (user-error "No package here")) + (let ((url (cdr (assoc :url (package-desc-extras desc))))) + (unless url + (user-error "No home page for %s" (package-desc-name desc))) + (if secondary + (funcall browse-url-secondary-browser-function url) + (browse-url url)))) + +;;;; 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..006517db759 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. @@ -27,22 +27,13 @@ ;; Todo: -;; - (pcase e (`(,x . ,x) foo)) signals an "x unused" warning if `foo' doesn't -;; use x, because x is bound separately for the equality constraint -;; (as well as any pred/guard) and for the body, so uses at one place don't -;; count for the other. -;; - provide ways to extend the set of primitives, with some kind of -;; define-pcase-matcher. We could easily make it so that (guard BOOLEXP) -;; could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)). -;; But better would be if we could define new ways to match by having the -;; extension provide its own `pcase--split-<foo>' thingy. -;; - along these lines, provide patterns to match CL structs. +;; - Allow to provide new `pcase--split-<foo>' thingy. ;; - 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 continue matching 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 (?). @@ -71,44 +62,37 @@ (defvar pcase--dontwarn-upats '(pcase--dontcare)) -(def-edebug-spec - pcase-PAT - (&or symbolp - ("or" &rest pcase-PAT) - ("and" &rest pcase-PAT) - ("guard" form) - ("let" pcase-PAT form) - ("pred" pcase-FUN) - ("app" pcase-FUN pcase-PAT) - pcase-MACRO - sexp)) - -(def-edebug-spec - pcase-FUN - (&or lambda-expr - ;; Punt on macros/special forms. - (functionp &rest form) - sexp)) - -;; See bug#24717 -(put 'pcase-MACRO 'edebug-form-spec 'pcase--edebug-match-macro) +(def-edebug-elem-spec 'pcase-PAT + '(&or (&interpose symbolp pcase--edebug-match-pat-args) sexp)) + +(def-edebug-elem-spec 'pcase-FUN + '(&or lambda-expr + ;; Punt on macros/special forms. + (functionp &rest form) + sexp)) ;; Only called from edebug. -(declare-function get-edebug-spec "edebug" (symbol)) -(declare-function edebug-match "edebug" (cursor specs)) - -(defun pcase--edebug-match-macro (cursor) - (let (specs) - (mapatoms - (lambda (s) - (let ((m (get s 'pcase-macroexpander))) - (when (and m (get-edebug-spec m)) - (push (cons (symbol-name s) (get-edebug-spec m)) - specs))))) - (edebug-match cursor (cons '&or specs)))) +(declare-function edebug-get-spec "edebug" (symbol)) +(defun pcase--edebug-match-pat-args (head pf) + ;; (cl-assert (null (cdr head))) + (setq head (car head)) + (or (alist-get head '((quote sexp) + (or &rest pcase-PAT) + (and &rest pcase-PAT) + (guard form) + (pred &or ("not" pcase-FUN) pcase-FUN) + (app pcase-FUN pcase-PAT))) + (let ((me (pcase--get-macroexpander head))) + (funcall pf (and me (symbolp me) (edebug-get-spec me)))))) + +(defun pcase--get-macroexpander (s) + "Return the macroexpander for pcase pattern head S, or nil" + (get s 'pcase-macroexpander)) ;;;###autoload (defmacro pcase (exp &rest cases) + ;; FIXME: Add some "global pattern" to wrap every case? + ;; Could be used to wrap all cases in a ` "Evaluate EXP to get EXPVAL; try passing control to one of CASES. CASES is a list of elements of the form (PATTERN CODE...). For the first CASE whose PATTERN \"matches\" EXPVAL, @@ -128,9 +112,9 @@ 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. (and PAT...) matches if all the patterns match. (or PAT...) matches if any of the patterns matches. @@ -140,7 +124,7 @@ FUN in `pred' and `app' can take one of the forms: (F ARG1 .. ARGn) call F with ARG1..ARGn and EXPVAL as n+1'th argument -FUN, BOOLEXP, EXPR, and subsequent PAT can refer to variables +FUN, BOOLEXP, and subsequent PAT can refer to variables bound earlier in the pattern by a SYMBOL pattern. Additional patterns can be defined using `pcase-defmacro'. @@ -193,7 +177,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))))) @@ -223,6 +207,7 @@ If EXP fails to match any of the patterns in CASES, an error is signaled." (pcase--dontwarn-upats (cons x pcase--dontwarn-upats))) (pcase--expand ;; FIXME: Could we add the FILE:LINE data in the error message? + ;; FILE is available from `macroexp-file-name'. exp (append cases `((,x (error "No clause matching `%S'" ,x))))))) ;;;###autoload @@ -336,77 +321,124 @@ of the elements of LIST is performed as if by `pcase-let'. (defun pcase--trivial-upat-p (upat) (and (symbolp upat) (not (memq upat pcase--dontcare-upats)))) -(defun pcase--expand (exp cases) - ;; (message "pid=%S (pcase--expand %S ...hash=%S)" - ;; (emacs-pid) exp (sxhash cases)) +(defun pcase-compile-patterns (exp cases) + "Compile the set of patterns in CASES. +EXP is the expression that will be matched against the patterns. +CASES is a list of elements (PAT . CODEGEN) +where CODEGEN is a function that returns the code to use when +PAT matches. That code has to be in the form of a cons cell. + +CODEGEN will be called with at least 2 arguments, VARVALS and COUNT. +VARVALS is a list of elements of the form (VAR VAL . RESERVED) where VAR +is a variable bound by the pattern and VAL is a duplicable expression +that returns the value this variable should be bound to. +If the pattern PAT uses `or', CODEGEN may be called multiple times, +in which case it may want to generate the code differently to avoid +a potential code explosion. For this reason the COUNT argument indicates +how many time this CODEGEN is called." (macroexp-let2 macroexp-copyable-p val exp - (let* ((defs ()) - (seen '()) - (codegen - (lambda (code vars) - (let ((prev (assq code seen))) - (if (not prev) - (let ((res (pcase-codegen code vars))) - (push (list code vars res) seen) - res) - ;; Since we use a tree-based pattern matching - ;; technique, the leaves (the places that contain the - ;; code to run once a pattern is matched) can get - ;; copied a very large number of times, so to avoid - ;; code explosion, we need to keep track of how many - ;; times we've used each leaf and move it - ;; to a separate function if that number is too high. - ;; - ;; We've already used this branch. So it is shared. - (let* ((code (car prev)) (cdrprev (cdr prev)) - (prevvars (car cdrprev)) (cddrprev (cdr cdrprev)) - (res (car cddrprev))) - (unless (symbolp res) - ;; This is the first repeat, so we have to move - ;; the branch to a separate function. - (let ((bsym - (make-symbol (format "pcase-%d" (length defs))))) - (push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code)) - defs) - (setcar res 'funcall) - (setcdr res (cons bsym (mapcar #'cdr prevvars))) - (setcar (cddr prev) bsym) - (setq res bsym))) - (setq vars (copy-sequence vars)) - (let ((args (mapcar (lambda (pa) - (let ((v (assq (car pa) vars))) - (setq vars (delq v vars)) - (cdr v))) - prevvars))) - ;; If some of `vars' were not found in `prevvars', that's - ;; OK it just means those vars aren't present in all - ;; branches, so they can be used within the pattern - ;; (e.g. by a `guard/let/pred') but not in the branch. - ;; FIXME: But if some of `prevvars' are not in `vars' we - ;; should remove them from `prevvars'! - `(funcall ,res ,@args))))))) - (used-cases ()) + (let* ((seen '()) + (phcounter 0) (main (pcase--u - (mapcar (lambda (case) - `(,(pcase--match val (pcase--macroexpand (car case))) - ,(lambda (vars) - (unless (memq case used-cases) - ;; Keep track of the cases that are used. - (push case used-cases)) - (funcall - (if (pcase--small-branch-p (cdr case)) - ;; Don't bother sharing multiple - ;; occurrences of this leaf since it's small. - #'pcase-codegen codegen) - (cdr case) - vars)))) - cases)))) + (mapcar + (lambda (case) + `(,(pcase--match val (pcase--macroexpand (car case))) + ,(lambda (vars) + (let ((prev (assq case seen))) + (unless prev + ;; Keep track of the cases that are used. + (push (setq prev (list case)) seen)) + ;; Put a counter in the cdr just so that not + ;; all branches look identical (to avoid things + ;; like `macroexp--if' optimizing them too + ;; optimistically). + (let ((ph (cons 'pcase--placeholder + (setq phcounter (1+ phcounter))))) + (setcdr prev (cons (cons vars ph) (cdr prev))) + ph))))) + cases)))) + ;; Take care of the place holders now. + (dolist (branch seen) + (let ((codegen (cdar branch)) + (uses (cdr branch))) + ;; Find all the vars that are in scope (the union of the + ;; vars provided in each use case). + (let* ((allvarinfo '()) + (_ (dolist (use uses) + (dolist (v (car use)) + (let ((vi (assq (car v) allvarinfo))) + (if vi + (if (cddr v) (setcdr vi 'used)) + (push (cons (car v) (cddr v)) allvarinfo)))))) + (allvars (mapcar #'car allvarinfo))) + (dolist (use uses) + (let* ((vars (car use)) + (varvals + (mapcar (lambda (v) + `(,v ,(cadr (assq v vars)) + ,(cdr (assq v allvarinfo)))) + allvars)) + (placeholder (cdr use)) + (code (funcall codegen varvals (length uses)))) + ;; (cl-assert (eq (car placeholder) 'pcase--placeholder)) + (setcar placeholder (car code)) + (setcdr placeholder (cdr code))))))) (dolist (case cases) - (unless (or (memq case used-cases) + (unless (or (assq case seen) (memq (car case) pcase--dontwarn-upats)) - (message "Redundant pcase pattern: %S" (car case)))) - (macroexp-let* defs main)))) + (setq main + (macroexp-warn-and-return + (format "pcase pattern %S shadowed by previous pcase pattern" + (car case)) + main)))) + main))) + +(defun pcase--expand (exp cases) + ;; (message "pid=%S (pcase--expand %S ...hash=%S)" + ;; (emacs-pid) exp (sxhash cases)) + (let* ((defs ()) + (codegen + (lambda (code) + (if (member code '(nil (nil) ('nil))) + (lambda (&rest _) ''nil) + (let ((bsym ())) + (lambda (varvals count &rest _) + (let* ((ignored-vars + (delq nil (mapcar (lambda (vv) (if (nth 2 vv) (car vv))) + varvals))) + (ignores (if ignored-vars + `((ignore . ,ignored-vars))))) + ;; Since we use a tree-based pattern matching + ;; technique, the leaves (the places that contain the + ;; code to run once a pattern is matched) can get + ;; copied a very large number of times, so to avoid + ;; code explosion, we need to keep track of how many + ;; times we've used each leaf and move it + ;; to a separate function if that number is too high. + (if (or (< count 2) (pcase--small-branch-p code)) + `(let ,(mapcar (lambda (vv) (list (car vv) (cadr vv))) + varvals) + ;; Try and silence some of the most common + ;; spurious "unused var" warnings. + ,@ignores + ,@code) + ;; Several occurrence of this non-small branch in + ;; the output. + (unless bsym + (setq bsym (make-symbol + (format "pcase-%d" (length defs)))) + (push `(,bsym (lambda ,(mapcar #'car varvals) + ,@ignores ,@code)) + defs)) + `(funcall ,bsym ,@(mapcar #'cadr varvals))))))))) + (main + (pcase-compile-patterns + exp + (mapcar (lambda (case) + (cons (car case) (funcall codegen (cdr case)))) + cases)))) + (macroexp-let* defs main))) (defun pcase--macroexpand (pat) "Expands all macro-patterns in PAT." @@ -416,10 +448,9 @@ of the elements of LIST is performed as if by `pcase-let'. (if (pcase--self-quoting-p pat) `',pat pat)) ((memq head '(pred guard quote)) pat) ((memq head '(or and)) `(,head ,@(mapcar #'pcase--macroexpand (cdr pat)))) - ((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 @@ -444,7 +475,13 @@ for the result of evaluating EXP (first arg to `pcase'). (decl (assq 'declare body))) (when decl (setq body (remove decl body))) `(progn - (defun ,fsym ,args ,@body) + ;; FIXME: We use `eval-and-compile' here so that the pcase macro can be + ;; used in the same file where it's defined, but ideally, we should + ;; handle this using something similar to `overriding-plist-environment' + ;; but for `symbol-function' slots so compiling a file doesn't have the + ;; side-effect of defining the function. + (eval-and-compile + (defun ,fsym ,args ,@body)) (define-symbol-prop ',fsym 'edebug-form-spec ',(cadr (assq 'debug decl))) (define-symbol-prop ',name 'pcase-macroexpander #',fsym)))) @@ -460,15 +497,6 @@ for the result of evaluating EXP (first arg to `pcase'). (t `(match ,val . ,upat)))) -(defun pcase-codegen (code vars) - ;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding - ;; let* which might prevent the setcar/setcdr in pcase--expand's fancy - ;; codegen from later metamorphosing this let into a funcall. - (if vars - `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars) - ,@code) - `(progn ,@code))) - (defun pcase--small-branch-p (code) (and (= 1 (length code)) (or (not (consp (car code))) @@ -481,8 +509,10 @@ for the result of evaluating EXP (first arg to `pcase'). ;; the depth of the generated tree. (defun pcase--if (test then else) (cond - ((eq else :pcase--dontcare) then) - ((eq then :pcase--dontcare) (debug) else) ;Can/should this ever happen? + ((eq else :pcase--dontcare) `(progn (ignore ,test) ,then)) + ;; This happens very rarely. Known case: + ;; (pcase EXP ((and 1 pcase--dontcare) FOO)) + ((eq then :pcase--dontcare) `(progn (ignore ,test) ,else)) (t (macroexp-if test then else)))) ;; Note about MATCH: @@ -507,11 +537,14 @@ for the result of evaluating EXP (first arg to `pcase'). "Expand matcher for rules BRANCHES. Each BRANCH has the form (MATCH CODE . VARS) where CODE is the code generator for that branch. -VARS is the set of vars already bound by earlier matches. MATCH is the pattern that needs to be matched, of the form: (match VAR . PAT) (and MATCH ...) - (or MATCH ...)" + (or MATCH ...) +VARS is the set of vars already bound by earlier matches. +It is a list of (NAME VAL . USED) where NAME is the variable's symbol, +VAL is the expression to which it should be bound and USED is a boolean +recording whether the var has been referenced by earlier parts of the match." (when (setq branches (delq nil branches)) (let* ((carbranch (car branches)) (match (car carbranch)) (cdarbranch (cdr carbranch)) @@ -590,7 +623,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 +686,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 returns 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 +704,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 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 +751,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 +768,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,37 +787,44 @@ 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 hopefully an upper bound on the bindings we need, + ;; FIXME: See bug#46786 for a counter example :-( + (env (mapcar (lambda (x) + (setcdr (cdr x) 'used) + (list (car x) (cadr 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) (setq arg newsym))) - (if (functionp fun) + (if (or (functionp fun) (not (consp 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))))) + (if found (progn (setcdr (cdr found) 'used) (cadr found)) + (let* ((env (macroexp--fgrep vars exp))) + (if env + (macroexp-let* (mapcar (lambda (x) + (setcdr (cdr x) 'used) + (list (car x) (cadr x))) + env) + exp) + exp))))) ;; It's very tempting to use `pcase' below, tho obviously, it'd create ;; bootstrapping problems. @@ -772,7 +834,7 @@ Otherwise, it defers to REST which is a list of branches of the form \(ELSE-MATCH ELSE-CODE . ELSE-VARS)." ;; Depending on the order in which we choose to check each of the MATCHES, ;; the resulting tree may be smaller or bigger. So in general, we'd want - ;; to be careful to chose the "optimal" order. But predicate + ;; to be careful to choose the "optimal" order. But predicate ;; patterns make this harder because they create dependencies ;; between matches. So we don't bother trying to reorder anything. (cond @@ -833,7 +895,7 @@ Otherwise, it defers to REST which is a list of branches of the form ((memq upat '(t _)) (let ((code (pcase--u1 matches code vars rest))) (if (eq upat '_) code - (macroexp--warn-and-return + (macroexp-warn-and-return "Pattern t is deprecated. Use `_' instead" code)))) ((eq upat 'pcase--dontcare) :pcase--dontcare) @@ -851,21 +913,14 @@ Otherwise, it defers to REST which is a list of branches of the form (pcase--u else-rest)))) ((and (symbolp upat) upat) (pcase--mark-used sym) - (if (not (assq upat vars)) - (pcase--u1 matches code (cons (cons upat sym) vars) rest) - ;; Non-linear pattern. Turn it into an `eq' test. - (pcase--u1 (cons `(match ,sym . (pred (eq ,(cdr (assq upat vars))))) - matches) - code vars rest))) - ((eq (car-safe upat) 'let) - ;; A upat of the form (let VAR EXP). - ;; (pcase--u1 matches code - ;; (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest) - (macroexp-let2 - macroexp-copyable-p sym - (pcase--eval (nth 2 upat) vars) - (pcase--u1 (cons (pcase--match sym (nth 1 upat)) matches) - code vars rest))) + (let ((v (assq upat vars))) + (if (not v) + (pcase--u1 matches code (cons (list upat sym) vars) rest) + ;; Non-linear pattern. Turn it into an `eq' test. + (setcdr (cdr v) 'used) + (pcase--u1 (cons `(match ,sym . (pred (eql ,(cadr v)))) + matches) + code vars rest)))) ((eq (car-safe upat) 'app) ;; A upat of the form (app FUN PAT) (pcase--mark-used sym) @@ -923,14 +978,13 @@ Otherwise, it defers to REST which is a list of branches of the form (t (error "Unknown pattern `%S'" upat))))) (t (error "Incorrect MATCH %S" (car matches))))) -(def-edebug-spec - pcase-QPAT +(def-edebug-elem-spec 'pcase-QPAT ;; Cf. edebug spec for `backquote-form' in edebug.el. - (&or ("," pcase-PAT) - (pcase-QPAT [&rest [¬ ","] pcase-QPAT] - . [&or nil pcase-QPAT]) - (vector &rest pcase-QPAT) - sexp)) + '(&or ("," pcase-PAT) + (pcase-QPAT [&rest [¬ ","] pcase-QPAT] + . [&or nil pcase-QPAT]) + (vector &rest pcase-QPAT) + sexp)) (pcase-defmacro \` (qpat) "Backquote-style pcase patterns: \\=`QPAT @@ -969,13 +1023,23 @@ The predicate is the logical-AND of: (nreverse upats)))) ((consp qpat) `(and (pred consp) - (app car ,(list '\` (car qpat))) - (app cdr ,(list '\` (cdr qpat))))) + (app car-safe ,(list '\` (car qpat))) + (app cdr-safe ,(list '\` (cdr qpat))))) ((or (stringp qpat) (numberp qpat) (symbolp qpat)) `',qpat) ;; In all other cases just raise an error so we can't break ;; backward compatibility when adding \` support for other ;; compounded values that are not `consp' (t (error "Unknown QPAT: %S" qpat)))) +(pcase-defmacro let (pat expr) + "Matches if EXPR matches PAT." + (declare (debug (pcase-PAT form))) + `(app (lambda (_) ,expr) ,pat)) + +;; (pcase-defmacro guard (expr) +;; "Matches if EXPR is non-nil." +;; (declare (debug (form))) +;; `(pred (lambda (_) ,expr))) + (provide 'pcase) ;;; pcase.el ends here diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index cd2e80907a8..2fd4724aef1 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) @@ -129,8 +127,9 @@ Also add the value to the front of the list in the variable `values'." (interactive (list (read--expression "Eval: "))) (message "Evaluating...") - (push (eval expression lexical-binding) values) - (pp-display-expression (car values) "*Pp Eval Output*")) + (let ((result (eval expression lexical-binding))) + (values--store-value result) + (pp-display-expression result "*Pp Eval Output*"))) ;;;###autoload (defun pp-macroexpand-expression (expression) @@ -164,8 +163,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..fb659753501 100644 --- a/lisp/emacs-lisp/radix-tree.el +++ b/lisp/emacs-lisp/radix-tree.el @@ -194,13 +194,13 @@ If not found, return nil." "Return an alist of all bindings in TREE for prefixes of STRING." (radix-tree--prefixes tree string 0 nil)) -(eval-and-compile - (pcase-defmacro radix-tree-leaf (vpat) - "Pattern which matches a radix-tree leaf. +(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..455fcac701f 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,17 +212,12 @@ 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.") ;; Define the local "\C-c" keymap (defvar reb-mode-map - (let ((map (make-sparse-keymap)) - (menu-map (make-sparse-keymap))) + (let ((map (make-sparse-keymap))) (define-key map "\C-c\C-c" 'reb-toggle-case) (define-key map "\C-c\C-q" 'reb-quit) (define-key map "\C-c\C-w" 'reb-copy) @@ -232,46 +227,40 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (define-key map "\C-c\C-e" 'reb-enter-subexp-mode) (define-key map "\C-c\C-b" 'reb-change-target-buffer) (define-key map "\C-c\C-u" 'reb-force-update) - (define-key map [menu-bar reb-mode] (cons "Re-Builder" menu-map)) - (define-key menu-map [rq] - '(menu-item "Quit" reb-quit - :help "Quit the RE Builder mode")) - (define-key menu-map [div1] '(menu-item "--")) - (define-key menu-map [rt] - '(menu-item "Case sensitive" reb-toggle-case - :button (:toggle . (with-current-buffer - reb-target-buffer - (null case-fold-search))) - :help "Toggle case sensitivity of searches for RE Builder target buffer")) - (define-key menu-map [rb] - '(menu-item "Change target buffer..." reb-change-target-buffer - :help "Change the target buffer and display it in the target window")) - (define-key menu-map [rs] - '(menu-item "Change syntax..." reb-change-syntax - :help "Change the syntax used by the RE Builder")) - (define-key menu-map [div2] '(menu-item "--")) - (define-key menu-map [re] - '(menu-item "Enter subexpression mode" reb-enter-subexp-mode - :help "Enter the subexpression mode in the RE Builder")) - (define-key menu-map [ru] - '(menu-item "Force update" reb-force-update - :help "Force an update in the RE Builder target window without a match limit")) - (define-key menu-map [rn] - '(menu-item "Go to next match" reb-next-match - :help "Go to next match in the RE Builder target window")) - (define-key menu-map [rp] - '(menu-item "Go to previous match" reb-prev-match - :help "Go to previous match in the RE Builder target window")) - (define-key menu-map [div3] '(menu-item "--")) - (define-key menu-map [rc] - '(menu-item "Copy current RE" reb-copy - :help "Copy current RE into the kill ring for later insertion")) map) "Keymap used by the RE Builder.") +(easy-menu-define reb-mode-menu reb-mode-map + "Menu for the RE Builder." + '("Re-Builder" + ["Copy current RE" reb-copy + :help "Copy current RE into the kill ring for later insertion"] + "---" + ["Go to previous match" reb-prev-match + :help "Go to previous match in the RE Builder target window"] + ["Go to next match" reb-next-match + :help "Go to next match in the RE Builder target window"] + ["Force update" reb-force-update + :help "Force an update in the RE Builder target window without a match limit"] + ["Enter subexpression mode" reb-enter-subexp-mode + :help "Enter the subexpression mode in the RE Builder"] + "---" + ["Change syntax..." reb-change-syntax + :help "Change the syntax used by the RE Builder"] + ["Change target buffer..." reb-change-target-buffer + :help "Change the target buffer and display it in the target window"] + ["Case sensitive" reb-toggle-case + :style toggle + :selected (with-current-buffer reb-target-buffer + (null case-fold-search)) + :help "Toggle case sensitivity of searches for RE Builder target buffer"] + "---" + ["Quit" reb-quit + :help "Quit the RE Builder mode"])) + (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 @@ -372,7 +361,6 @@ matching parts of the target buffer will be highlighted." (defun reb-change-target-buffer (buf) "Change the target buffer and display it in the target window." (interactive "bSet target buffer to: ") - (let ((buffer (get-buffer buf))) (if (not buffer) (error "No such buffer") @@ -385,7 +373,6 @@ matching parts of the target buffer will be highlighted." (defun reb-force-update () "Force an update in the RE Builder target window without a match limit." (interactive) - (let ((reb-auto-match-limit nil)) (reb-update-overlays (if reb-subexp-mode reb-subexp-displayed nil)))) @@ -393,7 +380,6 @@ matching parts of the target buffer will be highlighted." (defun reb-quit () "Quit the RE Builder mode." (interactive) - (setq reb-subexp-mode nil reb-subexp-displayed nil) (reb-delete-overlays) @@ -403,7 +389,6 @@ matching parts of the target buffer will be highlighted." (defun reb-next-match () "Go to next match in the RE Builder target window." (interactive) - (reb-assert-buffer-in-window) (with-selected-window reb-target-window (if (not (re-search-forward reb-regexp (point-max) t)) @@ -415,7 +400,6 @@ matching parts of the target buffer will be highlighted." (defun reb-prev-match () "Go to previous match in the RE Builder target window." (interactive) - (reb-assert-buffer-in-window) (with-selected-window reb-target-window (let ((p (point))) @@ -430,7 +414,6 @@ matching parts of the target buffer will be highlighted." (defun reb-toggle-case () "Toggle case sensitivity of searches for RE Builder target buffer." (interactive) - (with-current-buffer reb-target-buffer (setq case-fold-search (not case-fold-search))) (reb-update-modestring) @@ -439,7 +422,6 @@ matching parts of the target buffer will be highlighted." (defun reb-copy () "Copy current RE into the kill ring for later insertion." (interactive) - (reb-update-regexp) (let ((re (with-output-to-string (print (reb-target-binding reb-regexp))))) @@ -489,7 +471,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)))) @@ -507,7 +489,6 @@ Optional argument SYNTAX must be specified if called non-interactively." (defun reb-do-update (&optional subexp) "Update matches in the RE Builder target window. If SUBEXP is non-nil mark only the corresponding sub-expressions." - (reb-assert-buffer-in-window) (reb-update-regexp) (reb-update-overlays subexp)) @@ -545,7 +526,6 @@ optional fourth argument FORCE is non-nil." (defun reb-assert-buffer-in-window () "Assert that `reb-target-buffer' is displayed in `reb-target-window'." - (if (not (eq reb-target-buffer (window-buffer reb-target-window))) (set-window-buffer reb-target-window reb-target-buffer))) @@ -564,7 +544,6 @@ optional fourth argument FORCE is non-nil." (defun reb-display-subexp (&optional subexp) "Highlight only subexpression SUBEXP in the RE Builder." (interactive) - (setq reb-subexp-displayed (or subexp (string-to-number (format "%c" last-command-event)))) (reb-update-modestring) @@ -572,7 +551,6 @@ optional fourth argument FORCE is non-nil." (defun reb-kill-buffer () "When the RE Builder buffer is killed make sure no overlays stay around." - (when (reb-mode-buffer-p) (reb-delete-overlays))) @@ -604,7 +582,6 @@ optional fourth argument FORCE is non-nil." (defun reb-insert-regexp () "Insert current RE." - (let ((re (or (reb-target-binding reb-regexp) (reb-empty-regexp)))) (cond ((eq reb-re-syntax 'read) @@ -640,7 +617,6 @@ Return t if the (cooked) expression changed." ;; And now the real core of the whole thing (defun reb-count-subexps (re) "Return number of sub-expressions in the regexp RE." - (let ((i 0) (beg 0)) (while (string-match "\\\\(" re beg) (setq i (1+ i) @@ -832,8 +808,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/ring.el b/lisp/emacs-lisp/ring.el index 96894655b45..ea27bb3c31b 100644 --- a/lisp/emacs-lisp/ring.el +++ b/lisp/emacs-lisp/ring.el @@ -248,8 +248,6 @@ If SEQ is already a ring, return it." (ring-insert-at-beginning ring (elt seq count)))) ring))) -;;; provide ourself: - (provide 'ring) ;;; ring.el ends here diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index 8de98b4cfb4..56e588ee0d5 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -890,7 +890,7 @@ Return (REGEXP . PRECEDENCE)." (* (or (seq "[:" (+ (any "a-z")) ":]") (not (any "]")))) "]") - anything + (not (any "*+?^$[\\")) (seq "\\" (or anything (seq (any "sScC_") anything) @@ -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,13 @@ into a plain rx-expression, collecting names into `rx--pcase-vars'." (cons head (mapcar #'rx--pcase-transform rest))) (_ rx))) +(defun rx--reduce-right (f l) + "Right-reduction on L by F. L must be non-empty." + (if (cdr l) + (funcall f (car l) (rx--reduce-right f (cdr l))) + (car l))) + +;;;###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 @@ -1435,13 +1442,28 @@ following constructs: introduced by a previous (let REF ...) construct." (let* ((rx--pcase-vars nil) - (regexp (rx--to-expr (rx--pcase-transform (cons 'seq regexps))))) - `(and (pred (string-match ,regexp)) - ,@(let ((i 0)) - (mapcar (lambda (name) - (setq i (1+ i)) - `(app (match-string ,i) ,name)) - (reverse rx--pcase-vars)))))) + (regexp (rx--to-expr (rx--pcase-transform (cons 'seq regexps)))) + (nvars (length rx--pcase-vars))) + `(and (pred stringp) + ,(if (zerop nvars) + ;; No variables bound: a single predicate suffices. + `(pred (string-match ,regexp)) + ;; Pack the submatches into a dotted list which is then + ;; immediately destructured into individual variables again. + ;; This is of course slightly inefficient when NVARS > 1. + ;; A dotted list is used to reduce the number of conses + ;; to create and take apart. + `(app (lambda (s) + (and (string-match ,regexp s) + ,(rx--reduce-right + (lambda (a b) `(cons ,a ,b)) + (mapcar (lambda (i) `(match-string ,i s)) + (number-sequence 1 nvars))))) + ,(list '\` + (rx--reduce-right + #'cons + (mapcar (lambda (name) (list '\, name)) + (reverse rx--pcase-vars))))))))) ;; Obsolete internal symbol, used in old versions of the `flycheck' package. (define-obsolete-function-alias 'rx-submatch-n 'rx-to-string "27.1") diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index ef2b1092c83..6c15463ad52 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 @@ -134,9 +134,10 @@ Unlike `seq-map', FUNCTION takes two arguments: the element of the sequence, and its index within the sequence." (let ((index 0)) (seq-do (lambda (elt) - (funcall function elt index) - (setq index (1+ index))) - sequence))) + (funcall function elt index) + (setq index (1+ index))) + sequence)) + nil) (cl-defgeneric seqp (object) "Return non-nil if OBJECT is a sequence, nil otherwise." @@ -146,6 +147,7 @@ the sequence, and its index within the sequence." "Return a shallow copy of SEQUENCE." (copy-sequence sequence)) +;;;###autoload (cl-defgeneric seq-subseq (sequence start &optional end) "Return the sequence of elements of SEQUENCE from START to END. END is exclusive. @@ -284,9 +286,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 +319,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 +352,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 @@ -395,9 +395,9 @@ found or not." count)) (cl-defgeneric seq-contains (sequence elt &optional testfn) - (declare (obsolete seq-contains-p "27.1")) "Return the first element in SEQUENCE that is equal to ELT. Equality is defined by TESTFN if non-nil or by `equal' if nil." + (declare (obsolete seq-contains-p "27.1")) (seq-some (lambda (e) (when (funcall (or testfn #'equal) elt e) e)) @@ -413,7 +413,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))) @@ -430,6 +431,7 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil." (setq index (1+ index))) nil))) +;;;###autoload (cl-defgeneric seq-uniq (sequence &optional testfn) "Return a list of the elements of SEQUENCE with duplicates removed. TESTFN is used to compare elements, or `equal' if TESTFN is nil." @@ -446,7 +448,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) @@ -456,6 +458,7 @@ negative integer or 0, nil is returned." (setq sequence (seq-drop sequence n))) (nreverse result)))) +;;;###autoload (cl-defgeneric seq-intersection (sequence1 sequence2 &optional testfn) "Return a list of the elements that appear in both SEQUENCE1 and SEQUENCE2. Equality is defined by TESTFN if non-nil or by `equal' if nil." @@ -466,6 +469,7 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil." (seq-reverse sequence1) '())) +;;;###autoload (cl-defgeneric seq-difference (sequence1 sequence2 &optional testfn) "Return a list of the elements that appear in SEQUENCE1 but not in SEQUENCE2. Equality is defined by TESTFN if non-nil or by `equal' if nil." @@ -476,6 +480,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 +501,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..86d5130bbed --- /dev/null +++ b/lisp/emacs-lisp/shortdoc.el @@ -0,0 +1,1295 @@ +;;; 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-heading + '((t :inherit variable-pitch :height 1.3 :weight bold)) + "Face used for a heading." + :version "28.1") + +(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 + :args (string) + :doc "Trim STRING of leading and trailing white space." + :eval (string-trim " foo ")) + (string-trim-left + :eval (string-trim-left "oofoo" "o+")) + (string-trim-right + :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 'shortdoc-heading + '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 'shortdoc-section) + "\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..ab3cb3c5ace 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -52,16 +52,24 @@ ;; 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/2021/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 ;; and Ceriel Jacobs (BookBody.pdf available at -;; http://dickgrune.com/Books/PTAPG_1st_Edition/). +;; https://dickgrune.com/Books/PTAPG_1st_Edition/). ;; ;; OTOH we had to kill many chickens, read many coffee grounds, and practice ;; untold numbers of black magic spells, to come up with the indentation code. ;; Since then, some of that code has been beaten into submission, but the -;; smie-indent-keyword is still pretty obscure. +;; `smie-indent-keyword' function is still pretty obscure. + ;; Conflict resolution: ;; @@ -239,7 +247,7 @@ be either: ;; (exp (exp (or "+" "*" "=" ..) exp)). ;; Basically, make it EBNF (except for the specification of a separator in ;; the repetition, maybe). - (let* ((nts (mapcar 'car bnf)) ;Non-terminals. + (let* ((nts (mapcar #'car bnf)) ;Non-terminals. (first-ops-table ()) (last-ops-table ()) (first-nts-table ()) @@ -258,7 +266,7 @@ be either: (push resolver precs)) (t (error "Unknown resolver %S" resolver)))) (apply #'smie-merge-prec2s over - (mapcar 'smie-precs->prec2 precs)))) + (mapcar #'smie-precs->prec2 precs)))) again) (dolist (rules bnf) (let ((nt (car rules)) @@ -489,7 +497,7 @@ CSTS is a list of pairs representing arcs in a graph." res)) cycle))) (mapconcat - (lambda (elems) (mapconcat 'identity elems "=")) + (lambda (elems) (mapconcat #'identity elems "=")) (append names (list (car names))) " < "))) @@ -559,7 +567,7 @@ PREC2 is a table as returned by `smie-precs->prec2' or ;; Then eliminate trivial constraints iteratively. (let ((i 0)) (while csts - (let ((rhvs (mapcar 'cdr csts)) + (let ((rhvs (mapcar #'cdr csts)) (progress nil)) (dolist (cst csts) (unless (memq (car cst) rhvs) @@ -649,8 +657,8 @@ use syntax-tables to handle them in efficient C code.") Same calling convention as `smie-forward-token-function' except it should move backward to the beginning of the previous token.") -(defalias 'smie-op-left 'car) -(defalias 'smie-op-right 'cadr) +(defalias 'smie-op-left #'car) +(defalias 'smie-op-right #'cadr) (defun smie-default-backward-token () (forward-comment (- (point))) @@ -966,8 +974,7 @@ I.e. a good choice can be: (defcustom smie-blink-matching-inners t "Whether SMIE should blink to matching opener for inner keywords. If non-nil, it will blink not only for \"begin..end\" but also for \"if...else\"." - :type 'boolean - :group 'smie) + :type 'boolean) (defun smie-blink-matching-check (start end) (save-excursion @@ -1133,8 +1140,7 @@ OPENER is non-nil if TOKEN is an opener and nil if it's a closer." (defcustom smie-indent-basic 4 "Basic amount of indentation." - :type 'integer - :group 'smie) + :type 'integer) (defvar smie-rules-function #'ignore "Function providing the indentation rules. @@ -1181,7 +1187,7 @@ designed specifically for use in this function.") (and ;; (looking-at comment-start-skip) ;(bug#16041). (forward-comment (point-max)))))) -(defalias 'smie-rule-hanging-p 'smie-indent--hanging-p) +(defalias 'smie-rule-hanging-p #'smie-indent--hanging-p) (defun smie-indent--hanging-p () "Return non-nil if the current token is \"hanging\". A hanging keyword is one that's at the end of a line except it's not at @@ -1197,7 +1203,7 @@ the beginning of a line." (funcall smie--hanging-eolp-function) (point)))))) -(defalias 'smie-rule-bolp 'smie-indent--bolp) +(defalias 'smie-rule-bolp #'smie-indent--bolp) (defun smie-indent--bolp () "Return non-nil if the current token is the first on the line." (save-excursion (skip-chars-backward " \t") (bolp))) @@ -1356,9 +1362,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. @@ -1413,7 +1419,7 @@ BASE-POS is the position relative to which offsets should be applied." (forward-sexp 1) nil) ((eobp) nil) - (t (error "Bumped into unknown token"))))) + (t (error "Bumped into unknown token: %S" tok))))) (defun smie-indent-backward-token () "Skip token backward and return it, along with its levels." @@ -1802,9 +1808,11 @@ Each function is called with no argument, shouldn't move point, and should return either nil if it has no opinion, or an integer representing the column to which that point should be aligned, if we were to reindent it.") +(defalias 'smie--funcall #'funcall) ;Debugging/tracing convenience indirection. + (defun smie-indent-calculate () "Compute the indentation to use for point." - (run-hook-with-args-until-success 'smie-indent-functions)) + (run-hook-wrapped 'smie-indent-functions #'smie--funcall)) (defun smie-indent-line () "Indent current line using the SMIE indentation engine." @@ -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 @@ -2008,7 +2016,7 @@ value with which to replace it." ;; FIXME improve value-type. :type '(choice (const nil) (alist :key-type symbol)) - :initialize 'custom-initialize-set + :initialize #'custom-initialize-set :set #'smie-config--setter) (defun smie-config-local (rules) @@ -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..9c8c967ee9c 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 @@ -214,27 +215,14 @@ The variable list SPEC is the same as in `if-let'." (define-obsolete-function-alias 'string-reverse 'reverse "25.1") -(defsubst string-trim-left (string &optional regexp) - "Trim STRING of leading string matching REGEXP. - -REGEXP defaults to \"[ \\t\\n\\r]+\"." - (if (string-match (concat "\\`\\(?:" (or regexp "[ \t\n\r]+") "\\)") string) - (substring string (match-end 0)) - string)) - -(defsubst string-trim-right (string &optional regexp) - "Trim STRING of trailing string matching REGEXP. - -REGEXP defaults to \"[ \\t\\n\\r]+\"." - (let ((i (string-match-p (concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'") - string))) - (if i (substring string 0 i) string))) - -(defsubst string-trim (string &optional trim-left trim-right) - "Trim STRING of leading and trailing strings matching TRIM-LEFT and TRIM-RIGHT. - -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. @@ -254,6 +242,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 +367,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..6d5b04b83bb 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 @@ -275,12 +290,13 @@ Note: back-references in REGEXPs do not work." ',(string-to-syntax (nth 1 action))) ,@(nthcdr 2 action)) `((let ((mb (match-beginning ,gn)) - (me (match-end ,gn)) - (syntax ,(nth 1 action))) - (if syntax - (put-text-property - mb me 'syntax-table syntax)) - ,@(nthcdr 2 action))))) + (me (match-end ,gn))) + ,(macroexp-let2 nil syntax (nth 1 action) + `(progn + (if ,syntax + (put-text-property + mb me 'syntax-table ,syntax)) + ,@(nthcdr 2 action))))))) (t `((let ((mb (match-beginning ,gn)) (me (match-end ,gn)) @@ -325,6 +341,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 +353,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 +371,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 +401,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 +486,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..0b10dfdc0af 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 @@ -404,8 +410,7 @@ specified by `tabulated-list-sort-key'. It then erases the buffer and inserts the entries with `tabulated-list-printer'. Optional argument REMEMBER-POS, if non-nil, means to move point -to the entry with the same ID element as the current line and -recenter window line accordingly. +to the entry with the same ID element as the current line. Non-nil UPDATE argument means to use an alternative printing method which is faster if most entries haven't changed since the @@ -418,18 +423,10 @@ changing `tabulated-list-sort-key'." (funcall tabulated-list-entries) tabulated-list-entries)) (sorter (tabulated-list--get-sorter)) - entry-id saved-pt saved-col window-line) + entry-id saved-pt saved-col) (and remember-pos (setq entry-id (tabulated-list-get-id)) - (setq saved-col (current-column)) - (when (eq (window-buffer) (current-buffer)) - (setq window-line - (save-excursion - (save-restriction - (widen) - (narrow-to-region (window-start) (point)) - (goto-char (point-min)) - (vertical-motion (buffer-size))))))) + (setq saved-col (current-column))) ;; Sort the entries, if necessary. (when sorter (setq entries (sort entries sorter))) @@ -484,9 +481,7 @@ changing `tabulated-list-sort-key'." ;; If REMEMBER-POS was specified, move to the "old" location. (if saved-pt (progn (goto-char saved-pt) - (move-to-column saved-col) - (when window-line - (recenter window-line))) + (move-to-column saved-col)) (goto-char (point-min))))) (defun tabulated-list-print-entry (id cols) @@ -547,10 +542,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 +756,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..d9db1d3cdc9 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. @@ -6,6 +6,8 @@ ;; Keywords: spreadsheet 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 @@ -19,26 +21,19 @@ ;; 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. -(let* ((pause nil) - (x (if pause "\^Xq" "")) +(let* (;; (pause nil) + (x (if nil "\^Xq" "")) ;; pause (y "\^X\^Fses-test.ses\r\^[<")) ;;Fiddle with the existing spreadsheet (fset 'ses-exercise-example @@ -652,6 +647,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 +670,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 +700,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 +716,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/testcover.el b/lisp/emacs-lisp/testcover.el index 312e38769c5..75b27d08e56 100644 --- a/lisp/emacs-lisp/testcover.el +++ b/lisp/emacs-lisp/testcover.el @@ -258,10 +258,10 @@ vector. Return VALUE." (aset testcover-vector after-index (testcover--copy-object value))) ((eq 'maybe old-result) (aset testcover-vector after-index 'edebug-ok-coverage)) - ((eq '1value old-result) + ((eq 'testcover-1value old-result) (aset testcover-vector after-index (cons old-result (testcover--copy-object value)))) - ((and (eq (car-safe old-result) '1value) + ((and (eq (car-safe old-result) 'testcover-1value) (not (condition-case () (equal (cdr old-result) value) (circular-list t)))) @@ -358,11 +358,11 @@ eliminated by adding more test cases." data (aref coverage len)) (when (and (not (eq data 'edebug-ok-coverage)) (not (memq (car-safe data) - '(1value maybe noreturn))) + '(testcover-1value maybe noreturn))) (setq j (+ def-mark (aref points len)))) (setq ov (make-overlay (1- j) j)) (overlay-put ov 'face - (if (memq data '(edebug-unknown maybe 1value)) + (if (memq data '(edebug-unknown maybe testcover-1value)) 'testcover-nohits 'testcover-1value)))) (set-buffer-modified-p changed)))) @@ -450,12 +450,12 @@ or return multiple values." (`(defconst ,sym . ,args) (push sym testcover-module-constants) (testcover-analyze-coverage-progn args) - '1value) + 'testcover-1value) (`(defun ,name ,_ . ,doc-and-body) (let ((val (testcover-analyze-coverage-progn doc-and-body))) (cl-case val - ((1value) (push name testcover-module-1value-functions)) + ((testcover-1value) (push name testcover-module-1value-functions)) ((maybe) (push name testcover-module-potentially-1value-functions))) nil)) @@ -466,13 +466,13 @@ or return multiple values." ;; To avoid infinite recursion, don't examine quoted objects. ;; This will cause the coverage marks on an instrumented quoted ;; form to look odd. See bug#25316. - '1value) + 'testcover-1value) (`(\` ,bq-form) (testcover-analyze-coverage-backquote-form bq-form)) ((or 't 'nil (pred keywordp)) - '1value) + 'testcover-1value) ((pred vectorp) (testcover-analyze-coverage-compose (append form nil) @@ -482,7 +482,7 @@ or return multiple values." nil) ((pred atom) - '1value) + 'testcover-1value) (_ ;; Whatever we have here, it's not wrapped, so treat it as a list of forms. @@ -494,7 +494,7 @@ Analyze all the forms in FORMS and return 1value, maybe or nil depending on the analysis of the last one. Find the coverage vectors referenced by `edebug-enter' forms nested within FORMS and update them with the results of the analysis." - (let ((result '1value)) + (let ((result 'testcover-1value)) (while (consp forms) (setq result (testcover-analyze-coverage (pop forms)))) result)) @@ -518,7 +518,7 @@ form to be treated accordingly." (setq val (testcover-analyze-coverage-wrapped-form wrapped-form)) (when (or (eq wrapper '1value) val) ;; The form is 1-valued or potentially 1-valued. - (aset testcover-vector after-id (or val '1value))) + (aset testcover-vector after-id (or val 'testcover-1value))) (cond ((or (eq wrapper 'noreturn) @@ -526,13 +526,13 @@ form to be treated accordingly." ;; This function won't return, so indicate to testcover-before that ;; it should record coverage. (aset testcover-vector before-id (cons 'noreturn after-id)) - (aset testcover-vector after-id '1value) - (setq val '1value)) + (aset testcover-vector after-id 'testcover-1value) + (setq val 'testcover-1value)) ((eq (car-safe wrapped-form) '1value) ;; This function is always supposed to return the same value. - (setq val '1value) - (aset testcover-vector after-id '1value))) + (setq val 'testcover-1value) + (aset testcover-vector after-id 'testcover-1value))) val)) (defun testcover-analyze-coverage-wrapped-form (form) @@ -540,26 +540,26 @@ form to be treated accordingly." FORM is treated as if it will be evaluated." (pcase form ((pred keywordp) - '1value) + 'testcover-1value) ((pred symbolp) (when (or (memq form testcover-constants) (memq form testcover-module-constants)) - '1value)) + 'testcover-1value)) ((pred atom) - '1value) + 'testcover-1value) (`(\` ,bq-form) (testcover-analyze-coverage-backquote-form bq-form)) (`(defconst ,sym ,val . ,_) (push sym testcover-module-constants) (testcover-analyze-coverage val) - '1value) + 'testcover-1value) (`(,(or 'dotimes 'dolist) (,_ ,expr . ,result) . ,body) ;; These always return RESULT if provided. (testcover-analyze-coverage expr) (testcover-analyze-coverage-progn body) (let ((val (testcover-analyze-coverage-progn result))) ;; If the third value is not present, the loop always returns nil. - (if result val '1value))) + (if result val 'testcover-1value))) (`(,(or 'let 'let*) ,bindings . ,body) (testcover-analyze-coverage-progn bindings) (testcover-analyze-coverage-progn body)) @@ -604,12 +604,12 @@ FORM is treated as if it will be evaluated." (defun testcover-analyze-coverage-wrapped-application (func args) "Analyze the application of FUNC to ARGS for code coverage." (cond - ((eq func 'quote) '1value) + ((eq func 'quote) 'testcover-1value) ((or (memq func testcover-1value-functions) (memq func testcover-module-1value-functions)) ;; The function should always return the same value. (testcover-analyze-coverage-progn args) - '1value) + 'testcover-1value) ((or (memq func testcover-potentially-1value-functions) (memq func testcover-module-potentially-1value-functions)) ;; The function might always return the same value. @@ -635,14 +635,14 @@ If either argument is nil, return nil, otherwise if either argument is maybe, return maybe. Return 1value only if both arguments are 1value." (cl-case val - (1value result) + (testcover-1value result) (maybe (and result 'maybe)) (nil nil))) (defun testcover-analyze-coverage-compose (forms func) "Analyze a list of FORMS for code coverage using FUNC. The list is 1valued if all of its constituent elements are also 1valued." - (let ((result '1value)) + (let ((result 'testcover-1value)) (while (consp forms) (setq result (testcover-coverage-combine result (funcall func (car forms)))) (setq forms (cdr forms))) @@ -652,7 +652,7 @@ The list is 1valued if all of its constituent elements are also 1valued." (defun testcover-analyze-coverage-backquote (bq-list) "Analyze BQ-LIST, the body of a backquoted list, for code coverage." - (let ((result '1value)) + (let ((result 'testcover-1value)) (while (consp bq-list) (let ((form (car bq-list)) val) @@ -670,7 +670,7 @@ The list is 1valued if all of its constituent elements are also 1valued." "Analyze a single FORM from a backquoted list for code coverage." (cond ((vectorp form) (testcover-analyze-coverage-backquote (append form nil))) - ((atom form) '1value) + ((atom form) 'testcover-1value) ((memq (car form) (list '\, '\,@)) (testcover-analyze-coverage (cadr form))) (t (testcover-analyze-coverage-backquote form)))) 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..9354687b081 100644 --- a/lisp/emacs-lisp/trace.el +++ b/lisp/emacs-lisp/trace.el @@ -161,7 +161,7 @@ "Helper function to get internal values. You can call this function to add internal values in the trace buffer." (unless inhibit-trace - (with-current-buffer trace-buffer + (with-current-buffer (get-buffer-create trace-buffer) (goto-char (point-max)) (insert (trace-entry-message @@ -174,7 +174,7 @@ and CONTEXT is a string describing the dynamic context (e.g. values of some global variables)." (let ((print-circle t)) (format "%s%s%d -> %S%s\n" - (mapconcat 'char-to-string (make-string (1- level) ?|) " ") + (mapconcat 'char-to-string (make-string (max 0 (1- level)) ?|) " ") (if (> level 1) " " "") level ;; FIXME: Make it so we can click the function name to jump to its @@ -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) |