diff options
Diffstat (limited to 'lisp/emacs-lisp')
32 files changed, 1314 insertions, 414 deletions
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index ea01253d1ea..c0da59c81cb 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -1832,7 +1832,7 @@ Redefining advices affect the construction of an advised definition." ;; @@ Interactive input functions: ;; =============================== -(declare-function 'function-called-at-point "help") +(declare-function function-called-at-point "help") (defun ad-read-advised-function (&optional prompt predicate default) "Read name of advised function with completion from the minibuffer. diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index eb6b746bd80..aa58f7b27fa 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -87,6 +87,29 @@ that text will be copied verbatim to `generated-autoload-file'.") (defconst generate-autoload-section-continuation ";;;;;; " "String to add on each continuation of the section header form.") +;; In some ways it would be nicer to use a value that is recognizably +;; not a time-value, eg t, but that can cause issues if an older Emacs +;; that does not expect non-time-values loads the file. +(defconst autoload--non-timestamp '(0 0 0 0) + "Value to insert when `autoload-timestamps' is nil.") + +(defvar autoload-timestamps nil ; experimental, see bug#22213 + "Non-nil means insert a timestamp for each input file into the output. +We use these in incremental updates of the output file to decide +if we need to rescan an input file. If you set this to nil, +then we use the timestamp of the output file instead. As a result: + - for fixed inputs, the output will be the same every time + - incremental updates of the output file might not be correct if: + i) the timestamp of the output file cannot be trusted (at least + relative to that of the input files) + ii) any of the input files can be modified during the time it takes + to create the output + iii) only a subset of the input files are scanned + These issues are unlikely to happen in practice, and would arguably + represent bugs in the build system. Item iii) will happen if you + use a command like `update-file-autoloads', though, since it only + checks a single input file.") + (defvar autoload-modified-buffers) ;Dynamically scoped var. (defun make-autoload (form file &optional expansion) @@ -160,10 +183,12 @@ expression, in which case we want to handle forms differently." (args (pcase car ((or `defun `defmacro `defun* `defmacro* `cl-defun `cl-defmacro - `define-overloadable-function) (nth 2 form)) + `define-overloadable-function) + (nth 2 form)) (`define-skeleton '(&optional str arg)) ((or `define-generic-mode `define-derived-mode - `define-compilation-mode) nil) + `define-compilation-mode) + nil) (_ t))) (body (nthcdr (or (function-get car 'doc-string-elt) 3) form)) (doc (if (stringp (car body)) (pop body)))) @@ -179,7 +204,8 @@ expression, in which case we want to handle forms differently." define-global-minor-mode define-globalized-minor-mode easy-mmode-define-minor-mode - define-minor-mode)) t) + define-minor-mode)) + t) (eq (car-safe (car body)) 'interactive)) ,(if macrop ''macro nil)))) @@ -234,9 +260,22 @@ If a buffer is visiting the desired autoload file, return it." (enable-local-eval nil)) ;; We used to use `raw-text' to read this file, but this causes ;; problems when the file contains non-ASCII characters. - (let ((delay-mode-hooks t)) - (find-file-noselect - (autoload-ensure-default-file (autoload-generated-file)))))) + (let* ((delay-mode-hooks t) + (file (autoload-generated-file)) + (file-missing (not (file-exists-p file)))) + (when file-missing + (autoload-ensure-default-file file)) + (with-current-buffer + (find-file-noselect + (autoload-ensure-file-writeable + file)) + ;; block backups when the file has just been created, since + ;; the backups will just be the auto-generated headers. + ;; bug#23203 + (when file-missing + (setq buffer-backed-up t) + (save-buffer)) + (current-buffer))))) (defun autoload-generated-file () (expand-file-name generated-autoload-file @@ -277,7 +316,7 @@ The variable `autoload-print-form-outbuf' specifies the buffer to put the output in." (cond ;; If the form is a sequence, recurse. - ((eq (car form) 'progn) (mapcar 'autoload-print-form (cdr form))) + ((eq (car form) 'progn) (mapcar #'autoload-print-form (cdr form))) ;; Symbols at the toplevel are meaningless. ((symbolp form) nil) (t @@ -357,25 +396,36 @@ not be relied upon." ;;;###autoload (put 'autoload-ensure-writable 'risky-local-variable t) +(defun autoload-ensure-file-writeable (file) + ;; Probably pointless, but replaces the old AUTOGEN_VCS in lisp/Makefile, + ;; which was designed to handle CVSREAD=1 and equivalent. + (and autoload-ensure-writable + (let ((modes (file-modes file))) + (if (zerop (logand modes #o0200)) + ;; Ignore any errors here, and let subsequent attempts + ;; to write the file raise any real error. + (ignore-errors (set-file-modes file (logior modes #o0200)))))) + file) + (defun autoload-ensure-default-file (file) "Make sure that the autoload file FILE exists, creating it if needed. If the file already exists and `autoload-ensure-writable' is non-nil, make it writable." - (if (file-exists-p file) - ;; Probably pointless, but replaces the old AUTOGEN_VCS in lisp/Makefile, - ;; which was designed to handle CVSREAD=1 and equivalent. - (and autoload-ensure-writable - (let ((modes (file-modes file))) - (if (zerop (logand modes #o0200)) - ;; Ignore any errors here, and let subsequent attempts - ;; to write the file raise any real error. - (ignore-errors (set-file-modes file (logior modes #o0200)))))) - (write-region (autoload-rubric file) nil file)) - file) + (write-region (autoload-rubric file) nil file)) (defun autoload-insert-section-header (outbuf autoloads load-name file time) "Insert the section-header line, which lists the file name and which functions are in it, etc." + ;; (cl-assert ;Make sure we don't insert it in the middle of another section. + ;; (save-excursion + ;; (or (not (re-search-backward + ;; (concat "\\(" + ;; (regexp-quote generate-autoload-section-header) + ;; "\\)\\|\\(" + ;; (regexp-quote generate-autoload-section-trailer) + ;; "\\)") + ;; nil t)) + ;; (match-end 2)))) (insert generate-autoload-section-header) (prin1 `(autoloads ,autoloads ,load-name ,file ,time) outbuf) @@ -434,7 +484,7 @@ which lists the file name and which functions are in it, etc." ;; without checking its content. This makes it generate wrong load ;; names for cases like lisp/term which is not added to load-path. (setq dir (expand-file-name (pop names) dir))) - (t (setq name (mapconcat 'identity names "/"))))) + (t (setq name (mapconcat #'identity names "/"))))) (if (string-match "\\.elc?\\(\\.\\|\\'\\)" name) (substring name 0 (match-beginning 0)) name))) @@ -450,8 +500,116 @@ Return non-nil in the case where no autoloads were added at point." (let ((generated-autoload-file buffer-file-name)) (autoload-generate-file-autoloads file (current-buffer)))) -(defvar print-readably) - +(defvar autoload-compute-prefixes t + "If non-nil, autoload will add code to register the prefixes used in a file. +Standard prefixes won't be registered anyway. I.e. if a file \"foo.el\" defines +variables or functions that use \"foo-\" as prefix, that will not be registered. +But all other prefixes will be included.") + +(defconst autoload-def-prefixes-max-entries 5 + "Target length of the list of definition prefixes per file. +If set too small, the prefixes will be too generic (i.e. they'll use little +memory, we'll end up looking in too many files when we need a particular +prefix), and if set too large, they will be too specific (i.e. they will +cost more memory use).") + +(defconst autoload-def-prefixes-max-length 12 + "Target size of definition prefixes. +Don't try to split prefixes that are already longer than that.") + +(require 'radix-tree) + +(defun autoload--make-defs-autoload (defs file) + + ;; Remove the defs that obey the rule that file foo.el (or + ;; foo-mode.el) uses "foo-" as prefix. + ;; FIXME: help--symbol-completion-table still doesn't know how to use + ;; the rule that file foo.el (or foo-mode.el) uses "foo-" as prefix. + ;;(let ((prefix + ;; (concat (substring file 0 (string-match "-mode\\'" file)) "-"))) + ;; (dolist (def (prog1 defs (setq defs nil))) + ;; (unless (string-prefix-p prefix def) + ;; (push def defs)))) + + ;; Then compute a small set of prefixes that cover all the + ;; remaining definitions. + (let* ((tree (let ((tree radix-tree-empty)) + (dolist (def defs) + (setq tree (radix-tree-insert tree def t))) + tree)) + (prefixes nil)) + ;; Get the root prefixes, that we should include in any case. + (radix-tree-iter-subtrees + tree (lambda (prefix subtree) + (push (cons prefix subtree) prefixes))) + ;; In some cases, the root prefixes are too short, e.g. if you define + ;; "cc-helper" and "c-mode", you'll get "c" in the root prefixes. + (dolist (pair (prog1 prefixes (setq prefixes nil))) + (let ((s (car pair))) + (if (or (> (length s) 2) ;Long enough! + (string-match ".[[:punct:]]\\'" s) ;A real (tho short) prefix? + (radix-tree-lookup (cdr pair) "")) ;Nothing to expand! + (push pair prefixes) ;Keep it as is. + (radix-tree-iter-subtrees + (cdr pair) (lambda (prefix subtree) + (push (cons (concat s prefix) subtree) prefixes)))))) + ;; FIXME: The expansions done below are mostly pointless, such as + ;; for `yenc', where we replace "yenc-" with an exhaustive list (5 + ;; elements). + ;; (while + ;; (let ((newprefixes nil) + ;; (changes nil)) + ;; (dolist (pair prefixes) + ;; (let ((prefix (car pair))) + ;; (if (or (> (length prefix) autoload-def-prefixes-max-length) + ;; (radix-tree-lookup (cdr pair) "")) + ;; ;; No point splitting it any further. + ;; (push pair newprefixes) + ;; (setq changes t) + ;; (radix-tree-iter-subtrees + ;; (cdr pair) (lambda (sprefix subtree) + ;; (push (cons (concat prefix sprefix) subtree) + ;; newprefixes)))))) + ;; (and changes + ;; (<= (length newprefixes) + ;; autoload-def-prefixes-max-entries) + ;; (let ((new nil) + ;; (old nil)) + ;; (dolist (pair prefixes) + ;; (unless (memq pair newprefixes) ;Not old + ;; (push pair old))) + ;; (dolist (pair newprefixes) + ;; (unless (memq pair prefixes) ;Not new + ;; (push pair new))) + ;; (cl-assert new) + ;; (message "Expanding %S to %S" + ;; (mapcar #'car old) (mapcar #'car new)) + ;; t) + ;; (setq prefixes newprefixes) + ;; (< (length prefixes) autoload-def-prefixes-max-entries)))) + + ;; (message "Final prefixes %s : %S" file (mapcar #'car prefixes)) + (when prefixes + (let ((strings + (mapcar + (lambda (x) + (let ((prefix (car x))) + (if (or (> (length prefix) 2) ;Long enough! + (string-match ".[[:punct:]]\\'" prefix)) + prefix + ;; Some packages really don't follow the rules. + ;; Drop the most egregious cases such as the + ;; one-letter prefixes. + (let ((dropped ())) + (radix-tree-iter-mappings + (cdr x) (lambda (s _) + (push (concat prefix s) dropped))) + (message "Not registering prefix \"%s\" from %s. Affects: %S" + prefix file dropped) + nil)))) + prefixes))) + `(if (fboundp 'register-definition-prefixes) + (register-definition-prefixes ,file ',(delq nil strings))))))) (defun autoload--setup-output (otherbuf outbuf absfile load-name) (let ((outbuf @@ -529,11 +687,11 @@ FILE's modification time." (let (load-name (print-length nil) (print-level nil) - (print-readably t) ; This does something in Lucid Emacs. (float-output-format nil) (visited (get-file-buffer file)) (otherbuf nil) (absfile (expand-file-name file)) + (defs '()) ;; nil until we found a cookie. output-start) (when @@ -578,27 +736,93 @@ FILE's modification time." package--builtin-versions)) (princ "\n"))))) - (goto-char (point-min)) - (while (not (eobp)) - (skip-chars-forward " \t\n\f") - (cond - ((looking-at (regexp-quote generate-autoload-cookie)) - ;; If not done yet, figure out where to insert this text. - (unless output-start - (setq output-start (autoload--setup-output - otherbuf outbuf absfile load-name))) - (autoload--print-cookie-text output-start load-name file)) - ((looking-at ";") - ;; Don't read the comment. - (forward-line 1)) - (t - (forward-sexp 1) - (forward-line 1)))))) + ;; Do not insert autoload entries for excluded files. + (unless (member absfile autoload-excludes) + (goto-char (point-min)) + (while (not (eobp)) + (skip-chars-forward " \t\n\f") + (cond + ((looking-at (regexp-quote generate-autoload-cookie)) + ;; If not done yet, figure out where to insert this text. + (unless output-start + (setq output-start (autoload--setup-output + otherbuf outbuf absfile load-name))) + (autoload--print-cookie-text output-start load-name file)) + ((looking-at ";") + ;; Don't read the comment. + (forward-line 1)) + (t + ;; Avoid (defvar <foo>) by requiring a trailing space. + ;; Also, ignore this prefix business + ;; for ;;;###tramp-autoload and friends. + (when (and (equal generate-autoload-cookie ";;;###autoload") + (looking-at "(\\(def[^ ]+\\) ['(]*\\([^' ()\"\n]+\\)[\n \t]") + (not (member + (match-string 1) + '("define-obsolete-function-alias" + "define-obsolete-variable-alias" + "define-category" "define-key" + "defgroup" "defface" "defadvice" + "def-edebug-spec" + ;; Hmm... this is getting ugly: + "define-widget" + "define-erc-response-handler" + "defun-rcirc-command")))) + (push (match-string 2) defs)) + (forward-sexp 1) + (forward-line 1))))))) + + (when (and autoload-compute-prefixes defs) + ;; This output needs to always go in the main loaddefs.el, + ;; regardless of generated-autoload-file. + ;; FIXME: the files that don't have autoload cookies but + ;; do have definitions end up listed twice in loaddefs.el: + ;; once for their register-definition-prefixes and once in + ;; the list of "files without any autoloads". + (let ((form (autoload--make-defs-autoload defs load-name))) + (cond + ((null form)) ;All defs obey the default rule, yay! + ((not otherbuf) + (unless output-start + (setq output-start (autoload--setup-output + nil outbuf absfile load-name))) + (let ((autoload-print-form-outbuf + (marker-buffer output-start))) + (autoload-print-form form))) + (t + (let* ((other-output-start + ;; To force the output to go to the main loaddefs.el + ;; rather than to generated-autoload-file, + ;; there are two cases: if outbuf is non-nil, + ;; then passing otherbuf=nil is enough, but if + ;; outbuf is nil, that won't cut it, so we + ;; locally bind generated-autoload-file. + (let ((generated-autoload-file + (default-value 'generated-autoload-file))) + (autoload--setup-output nil outbuf absfile load-name))) + (autoload-print-form-outbuf + (marker-buffer other-output-start))) + (autoload-print-form form) + (with-current-buffer (marker-buffer other-output-start) + (save-excursion + ;; Insert the section-header line which lists + ;; the file name and which functions are in it, etc. + (goto-char other-output-start) + (let ((relfile (file-relative-name absfile))) + (autoload-insert-section-header + (marker-buffer other-output-start) + "actual autoloads are elsewhere" load-name relfile + (if autoload-timestamps + (nth 5 (file-attributes absfile)) + autoload--non-timestamp)) + (insert ";;; Generated autoloads from " relfile "\n"))) + (insert generate-autoload-section-trailer))))))) (when output-start (let ((secondary-autoloads-file-buf (if otherbuf (current-buffer)))) (with-current-buffer (marker-buffer output-start) + (cl-assert (> (point) output-start)) (save-excursion ;; Insert the section-header line which lists the file name ;; and which functions are in it, etc. @@ -624,7 +848,9 @@ FILE's modification time." ;; We'd really want to just use ;; `emacs-internal' instead. nil nil 'emacs-mule-unix) - (nth 5 (file-attributes relfile)))) + (if autoload-timestamps + (nth 5 (file-attributes relfile)) + autoload--non-timestamp))) (insert ";;; Generated autoloads from " relfile "\n"))) (insert generate-autoload-section-trailer)))) (or noninteractive @@ -655,6 +881,8 @@ FILE's modification time." (let ((version-control 'never)) (save-buffer))))) +;; FIXME This command should be deprecated. +;; See http://debbugs.gnu.org/22213#41 ;;;###autoload (defun update-file-autoloads (file &optional save-after outfile) "Update the autoloads for FILE. @@ -672,6 +900,9 @@ Return FILE if there was no autoload cookie in it, else nil." (read-file-name "Write autoload definitions to file: "))) (let* ((generated-autoload-file (or outfile generated-autoload-file)) (autoload-modified-buffers nil) + ;; We need this only if the output file handles more than one input. + ;; See http://debbugs.gnu.org/22213#38 and subsequent. + (autoload-timestamps t) (no-autoloads (autoload-generate-file-autoloads file))) (if autoload-modified-buffers (if save-after (autoload-save-buffers)) @@ -689,6 +920,9 @@ 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-time (if (file-exists-p output-file) + (nth 5 (file-attributes output-file)))) (found nil)) (with-current-buffer (autoload-find-generated-file) ;; This is to make generated-autoload-file have Unix EOLs, so @@ -713,16 +947,28 @@ removes any prior now out-of-date autoload entries." (file-time (nth 5 (file-attributes file)))) (if (and (or (null existing-buffer) (not (buffer-modified-p existing-buffer))) - (or + (cond + ;; FIXME? Arguably we should throw a + ;; user error, or some kind of warning, + ;; if we were called from update-file-autoloads, + ;; which can update only a single input file. + ;; It's not appropriate to use the output + ;; file modtime in such a case, + ;; if there are multiple input files + ;; contributing to the output. + ((and output-time + (member last-time + (list t autoload--non-timestamp))) + (not (time-less-p output-time file-time))) ;; last-time is the time-stamp (specifying ;; the last time we looked at the file) and ;; the file hasn't been changed since. - (and (listp last-time) - (not (time-less-p last-time file-time))) + ((listp last-time) + (not (time-less-p last-time file-time))) ;; last-time is an MD5 checksum instead. - (and (stringp last-time) - (equal last-time - (md5 buf nil nil 'emacs-mule))))) + ((stringp last-time) + (equal last-time + (md5 buf nil nil 'emacs-mule))))) (throw 'up-to-date nil) (autoload-remove-section begin) (setq found t)))) @@ -768,12 +1014,13 @@ write its autoloads into the specified file instead." (dolist (suf (get-load-suffixes)) (unless (string-match "\\.elc" suf) (push suf tmp))) (concat "^[^=.].*" (regexp-opt tmp t) "\\'"))) - (files (apply 'nconc + (files (apply #'nconc (mapcar (lambda (dir) (directory-files (expand-file-name dir) t files-re)) dirs))) - (done ()) + (done ()) ;Files processed; to remove duplicates. + (changed nil) ;Non-nil if some change occurred. (last-time) ;; Files with no autoload cookies or whose autoloads go to other ;; files because of file-local autoload-generated-file settings. @@ -782,13 +1029,16 @@ write its autoloads into the specified file instead." (generated-autoload-file (if (called-interactively-p 'interactive) (read-file-name "Write autoload definitions to file: ") - generated-autoload-file))) + generated-autoload-file)) + (output-time + (if (file-exists-p generated-autoload-file) + (nth 5 (file-attributes generated-autoload-file))))) (with-current-buffer (autoload-find-generated-file) (save-excursion ;; Canonicalize file names and remove the autoload file itself. (setq files (delete (file-relative-name buffer-file-name) - (mapcar 'file-relative-name files))) + (mapcar #'file-relative-name files))) (goto-char (point-min)) (while (search-forward generate-autoload-section-header nil t) @@ -800,28 +1050,33 @@ write its autoloads into the specified file instead." ;; Remove the obsolete section. (autoload-remove-section (match-beginning 0)) (setq last-time (nth 4 form)) - (when (listp last-time) - (dolist (file file) - (let ((file-time (nth 5 (file-attributes file)))) - (when (and file-time - (not (time-less-p last-time file-time))) - ;; file unchanged - (push file no-autoloads) - (setq files (delete file files))))))) + (if (member last-time (list t autoload--non-timestamp)) + (setq last-time output-time)) + (dolist (file file) + (let ((file-time (nth 5 (file-attributes file)))) + (when (and file-time + (not (time-less-p last-time file-time))) + ;; file unchanged + (push file no-autoloads) + (setq files (delete file files)))))) ((not (stringp file))) ((or (not (file-exists-p file)) ;; Remove duplicates as well, just in case. - (member file done) - ;; If the file is actually excluded. - (member (expand-file-name file) autoload-excludes)) + (member file done)) ;; Remove the obsolete section. + (setq changed t) (autoload-remove-section (match-beginning 0))) - ((and (listp (nth 4 form)) - (not (time-less-p (nth 4 form) - (nth 5 (file-attributes file))))) + ((not (time-less-p (let ((oldtime (nth 4 form))) + (if (member oldtime + (list + t autoload--non-timestamp)) + output-time + oldtime)) + (nth 5 (file-attributes file)))) ;; File hasn't changed. nil) (t + (setq changed t) (autoload-remove-section (match-beginning 0)) (if (autoload-generate-file-autoloads ;; Passing `current-buffer' makes it insert at point. @@ -833,7 +1088,6 @@ write its autoloads into the specified file instead." (let ((no-autoloads-time (or last-time '(0 0 0 0))) file-time) (dolist (file files) (cond - ((member (expand-file-name file) autoload-excludes) nil) ;; Passing nil as second argument forces ;; autoload-generate-file-autoloads to look for the right ;; spot where to insert each autoloads section. @@ -841,7 +1095,8 @@ write its autoloads into the specified file instead." (autoload-generate-file-autoloads file nil buffer-file-name)) (push file no-autoloads) (if (time-less-p no-autoloads-time file-time) - (setq no-autoloads-time file-time))))) + (setq no-autoloads-time file-time))) + (t (setq changed t)))) (when no-autoloads ;; Sort them for better readability. @@ -850,11 +1105,17 @@ write its autoloads into the specified file instead." (goto-char (point-max)) (search-backward "\f" nil t) (autoload-insert-section-header - (current-buffer) nil nil no-autoloads no-autoloads-time) + (current-buffer) nil nil no-autoloads (if autoload-timestamps + no-autoloads-time + autoload--non-timestamp)) (insert generate-autoload-section-trailer))) - (let ((version-control 'never)) - (save-buffer)) + ;; Don't modify the file if its content has not been changed, so `make' + ;; dependencies don't trigger unnecessarily. + (when changed + (let ((version-control 'never)) + (save-buffer))) + ;; In case autoload entries were added to other files because of ;; file-local autoload-generated-file settings. (autoload-save-buffers)))) @@ -886,7 +1147,7 @@ should be non-nil)." (push (expand-file-name file) autoload-excludes))))))) (let ((args command-line-args-left)) (setq command-line-args-left nil) - (apply 'update-directory-autoloads args))) + (apply #'update-directory-autoloads args))) (provide 'autoload) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index b3bf4a58849..dbaf2bc6f6a 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1209,8 +1209,9 @@ 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-int string-to-number substring sxhash symbol-function - symbol-name symbol-plist symbol-value string-make-unibyte + string-to-int string-to-number substring + sxhash sxhash-equal sxhash-eq sxhash-eql + symbol-function symbol-name symbol-plist symbol-value string-make-unibyte string-make-multibyte string-as-multibyte string-as-unibyte string-to-multibyte tan truncate diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 1526e2fdeb9..dc7574e778d 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1360,31 +1360,33 @@ extra args." (dolist (elt '(format message error)) (put elt 'byte-compile-format-like t)) -;; Warn if a custom definition fails to specify :group. +;; Warn if a custom definition fails to specify :group, or :type. (defun byte-compile-nogroup-warn (form) - (if (and (memq (car form) '(custom-declare-face custom-declare-variable)) - byte-compile-current-group) - ;; The group will be provided implicitly. - nil - (let ((keyword-args (cdr (cdr (cdr (cdr form))))) - (name (cadr form))) - (or (not (eq (car-safe name) 'quote)) - (and (eq (car form) 'custom-declare-group) - (equal name ''emacs)) - (plist-get keyword-args :group) - (not (and (consp name) (eq (car name) 'quote))) - (byte-compile-warn - "%s for `%s' fails to specify containing group" - (cdr (assq (car form) - '((custom-declare-group . defgroup) - (custom-declare-face . defface) - (custom-declare-variable . defcustom)))) - (cadr name))) - ;; Update the current group, if needed. - (if (and byte-compile-current-file ;Only when compiling a whole file. - (eq (car form) 'custom-declare-group) - (eq (car-safe name) 'quote)) - (setq byte-compile-current-group (cadr name)))))) + (let ((keyword-args (cdr (cdr (cdr (cdr form))))) + (name (cadr form))) + (when (eq (car-safe name) 'quote) + (or (not (eq (car form) 'custom-declare-variable)) + (plist-get keyword-args :type) + (byte-compile-warn + "defcustom for `%s' fails to specify type" (cadr name))) + (if (and (memq (car form) '(custom-declare-face custom-declare-variable)) + byte-compile-current-group) + ;; The group will be provided implicitly. + nil + (or (and (eq (car form) 'custom-declare-group) + (equal name ''emacs)) + (plist-get keyword-args :group) + (byte-compile-warn + "%s for `%s' fails to specify containing group" + (cdr (assq (car form) + '((custom-declare-group . defgroup) + (custom-declare-face . defface) + (custom-declare-variable . defcustom)))) + (cadr name))) + ;; Update the current group, if needed. + (if (and byte-compile-current-file ;Only when compiling a whole file. + (eq (car form) 'custom-declare-group)) + (setq byte-compile-current-group (cadr name))))))) ;; Warn if the function or macro is being redefined with a different ;; number of arguments. @@ -2957,6 +2959,8 @@ for symbols generated by the byte compiler itself." ;; Special macro-expander used during byte-compilation. (defun byte-compile-macroexpand-declare-function (fn file &rest args) + (declare (advertised-calling-convention + (fn file &optional arglist fileonly) nil)) (let ((gotargs (and (consp args) (listp (car args)))) (unresolved (assq fn byte-compile-unresolved-functions))) (when unresolved ; function was called before declaration diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el index b6fa0546088..e1e756be077 100644 --- a/lisp/emacs-lisp/check-declare.el +++ b/lisp/emacs-lisp/check-declare.el @@ -43,7 +43,7 @@ "Name of buffer used to display any `check-declare' warnings.") (defun check-declare-locate (file basefile) - "Return the full path of FILE. + "Return the relative name of FILE. Expands files with a \".c\" or \".m\" extension relative to the Emacs \"src/\" directory. Otherwise, `locate-library' searches for FILE. If that fails, expands FILE relative to BASEFILE's directory part. @@ -70,6 +70,7 @@ the result." (string-match "\\.el\\'" tfile)) tfile (concat tfile ".el"))))) + (setq file (file-relative-name file)) (if ext (concat "ext:" file) file))) @@ -80,49 +81,40 @@ where only the first two elements need be present. This claims that FNFILE defines FN, with ARGLIST. FILEONLY non-nil means only check that FNFILE exists, not that it defines FN. This is for function definitions that we don't know how to recognize (e.g. some macros)." - (let ((m (format "Scanning %s..." file)) - alist form len fn fnfile arglist fileonly) - (message "%s" m) + (let (alist) (with-temp-buffer (insert-file-contents file) ;; FIXME we could theoretically be inside a string. (while (re-search-forward "^[ \t]*\\((declare-function\\)[ \t\n]" nil t) - (goto-char (match-beginning 1)) - (if (and (setq form (ignore-errors (read (current-buffer)))) + (let ((pos (match-beginning 1))) + (goto-char pos) + (let ((form (ignore-errors (read (current-buffer)))) + len fn formfile fnfile arglist fileonly) + (if (and ;; Exclude element of byte-compile-initial-macro-environment. (or (listp (cdr form)) (setq form nil)) (> (setq len (length form)) 2) (< len 6) + (setq formfile (nth 2 form)) (symbolp (setq fn (cadr form))) (setq fn (symbol-name fn)) ; later we use as a search string - (stringp (setq fnfile (nth 2 form))) - (setq fnfile (check-declare-locate fnfile - (expand-file-name file))) + (stringp formfile) + (setq fnfile (check-declare-locate formfile file)) ;; Use t to distinguish unspecified arglist from empty one. (or (eq t (setq arglist (if (> len 3) (nth 3 form) t))) (listp arglist)) (symbolp (setq fileonly (nth 4 form)))) - (setq alist (cons (list fnfile fn arglist fileonly) alist)) - ;; FIXME make this more noticeable. - (if form (message "Malformed declaration for `%s'" (cadr form)))))) - (message "%sdone" m) + (setq alist (cons (list fnfile fn arglist fileonly) alist)) + (when form + (check-declare-warn file (or fn "unknown function") + (if (stringp formfile) formfile + "unknown file") + "Malformed declaration" + (line-number-at-pos pos)))))))) alist)) -(defun check-declare-errmsg (errlist &optional full) - "Return a string with the number of errors in ERRLIST, if any. -Normally just counts the number of elements in ERRLIST. -With optional argument FULL, sums the number of elements in each element." - (if errlist - (let ((l (length errlist))) - (when full - (setq l 0) - (dolist (e errlist) - (setq l (+ l (1- (length e)))))) - (format "%d problem%s found" l (if (= l 1) "" "s"))) - "OK")) - (autoload 'byte-compile-arglist-signature "bytecomp") (defgroup check-declare nil @@ -144,11 +136,9 @@ to only check that FNFILE exists, not that it actually defines FN. Returns nil if all claims are found to be true, otherwise a list of errors with elements of the form \(FILE FN TYPE), where TYPE is a string giving details of the error." - (let ((m (format "Checking %s..." fnfile)) - (cflag (member (file-name-extension fnfile) '("c" "m"))) + (let ((cflag (member (file-name-extension fnfile) '("c" "m"))) (ext (string-match "^ext:" fnfile)) re fn sig siglist arglist type errlist minargs maxargs) - (message "%s" m) (if ext (setq fnfile (substring fnfile 4))) (if (file-regular-p fnfile) @@ -216,7 +206,8 @@ fset\\|\\(?:cl-\\)?defmethod\\)\\>" type) (setq arglist (nth 2 e) type (if (not re) - "file not found" + (when (or check-declare-ext-errors (not ext)) + "file not found") (if (not (setq sig (assoc (cadr e) siglist))) (unless (nth 3 e) ; fileonly "function not found") @@ -235,13 +226,6 @@ fset\\|\\(?:cl-\\)?defmethod\\)\\>" type) "arglist mismatch"))))) (when type (setq errlist (cons (list (car e) (cadr e) type) errlist)))) - (message "%s%s" m - (if (or re (or check-declare-ext-errors - (not ext))) - (check-declare-errmsg errlist) - (progn - (setq errlist nil) - "skipping external file"))) errlist)) (defun check-declare-sort (alist) @@ -258,30 +242,27 @@ Returned list has elements FNFILE (FILE ...)." (setq sort (cons (list fnfile (cons file rest)) sort))))) sort)) -(defun check-declare-warn (file fn fnfile type) +(defun check-declare-warn (file fn fnfile type &optional line) "Warn that FILE made a false claim about FN in FNFILE. -TYPE is a string giving the nature of the error. Warning is displayed in -`check-declare-warning-buffer'." +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) - (let ((line 0) - (col 0)) - (insert - (with-current-buffer (find-file-noselect file) - (goto-char (point-min)) - (when (re-search-forward - (format "(declare-function[ \t\n]+%s" fn) nil t) - (goto-char (match-beginning 0)) - (setq line (line-number-at-pos)) - (setq col (1+ (current-column)))) - (format "%s:%d:%d:" - (file-name-nondirectory file) - line col)))) + (insert (format "%s:%d:" (file-relative-name file) (or line 0))) entry)) (warning-fill-prefix " ")) + (unless line + (with-current-buffer (find-file-noselect file) + (goto-char (point-min)) + (when (and (not line) + (re-search-forward + (format "(declare-function[ \t\n]+%s" fn) nil t)) + (goto-char (match-beginning 0)) + (setq line (line-number-at-pos))))) (display-warning 'check-declare (format-message "said `%s' was defined in %s: %s" - fn (file-name-nondirectory fnfile) type) + fn (file-relative-name fnfile) type) nil check-declare-warning-buffer))) (declare-function compilation-forget-errors "compile" ()) @@ -289,7 +270,18 @@ TYPE is a string giving the nature of the error. Warning is displayed in (defun check-declare-files (&rest files) "Check veracity of all `declare-function' statements in FILES. Return a list of any errors found." - (let (alist err errlist) + (if (get-buffer check-declare-warning-buffer) + (kill-buffer check-declare-warning-buffer)) + (let ((buf (get-buffer-create check-declare-warning-buffer)) + alist err errlist) + (with-current-buffer buf + (unless (derived-mode-p 'compilation-mode) + (compilation-mode)) + (setq mode-line-process + '(:propertize ":run" face compilation-mode-line-run)) + (let ((inhibit-read-only t)) + (insert "\f\n")) + (compilation-forget-errors)) (dolist (file files) (setq alist (cons (cons file (check-declare-scan file)) alist))) ;; Sort so that things are ordered by the files supposed to @@ -298,19 +290,15 @@ Return a list of any errors found." (if (setq err (check-declare-verify (car e) (cdr e))) (setq errlist (cons (cons (car e) err) errlist)))) (setq errlist (nreverse errlist)) - (if (get-buffer check-declare-warning-buffer) - (kill-buffer check-declare-warning-buffer)) - (with-current-buffer (get-buffer-create check-declare-warning-buffer) - (unless (derived-mode-p 'compilation-mode) - (compilation-mode)) - (let ((inhibit-read-only t)) - (insert "\f\n")) - (compilation-forget-errors)) ;; Sort back again so that errors are ordered by the files ;; containing the declare-function statements. (dolist (e (check-declare-sort errlist)) (dolist (f (cdr e)) (check-declare-warn (car e) (cadr f) (car f) (nth 2 f)))) + (with-current-buffer buf + (setq mode-line-process + '(:propertize ":exit" face compilation-mode-line-run)) + (force-mode-line-update)) errlist)) ;;;###autoload @@ -320,34 +308,22 @@ See `check-declare-directory' for more information." (interactive "fFile to check: ") (or (file-exists-p file) (error "File `%s' not found" file)) - (let ((m (format "Checking %s..." file)) - errlist) - (message "%s" m) - (setq errlist (check-declare-files file)) - (message "%s%s" m (check-declare-errmsg errlist)) - errlist)) + (check-declare-files file)) ;;;###autoload (defun check-declare-directory (root) "Check veracity of all `declare-function' statements under directory ROOT. Returns non-nil if any false statements are found." (interactive "DDirectory to check: ") - (or (file-directory-p (setq root (expand-file-name root))) + (setq root (directory-file-name (file-relative-name root))) + (or (file-directory-p root) (error "Directory `%s' not found" root)) - (let ((m "Checking `declare-function' statements...") - (m2 "Finding files with declarations...") - errlist files) - (message "%s" m) - (message "%s" m2) - (setq files (process-lines find-program root - "-name" "*.el" - "-exec" grep-program - "-l" "^[ \t]*(declare-function" "{}" ";")) - (message "%s%d found" m2 (length files)) + (let ((files (process-lines find-program root + "-name" "*.el" + "-exec" grep-program + "-l" "^[ \t]*(declare-function" "{}" "+"))) (when files - (setq errlist (apply 'check-declare-files files)) - (message "%s%s" m (check-declare-errmsg errlist t)) - errlist))) + (apply #'check-declare-files files)))) (provide 'check-declare) diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index fd8f108a54e..3a81adeb6a6 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -1638,6 +1638,17 @@ function,command,variable,option or symbol." ms1)))))) ;; * If a user option variable records a true-or-false ;; condition, give it a name that ends in `-flag'. + ;; "True ..." should be "Non-nil ..." + (when (looking-at "\"\\*?\\(True\\)\\b") + (if (checkdoc-autofix-ask-replace + (match-beginning 1) (match-end 1) + "Say \"Non-nil\" instead of \"True\"? " + "Non-nil") + nil + (checkdoc-create-error + "\"True\" should usually be \"Non-nil\"" + (match-beginning 1) (match-end 1)))) + ;; If the variable has -flag in the name, make sure (if (and (string-match "-flag$" (car fp)) (not (looking-at "\"\\*?Non-nil\\s-+means\\s-+"))) @@ -1798,6 +1809,16 @@ Replace with \"%s\"? " original replace) "Probably \"%s\" should be imperative \"%s\"" original replace) (match-beginning 1) (match-end 1)))))) + ;; "Return true ..." should be "Return non-nil ..." + (when (looking-at "\"Return \\(true\\)\\b") + (if (checkdoc-autofix-ask-replace + (match-beginning 1) (match-end 1) + "Say \"non-nil\" instead of \"true\"? " + "non-nil") + nil + (checkdoc-create-error + "\"true\" should usually be \"non-nil\"" + (match-beginning 1) (match-end 1)))) ;; Done with functions ))) ;;* When a documentation string refers to a Lisp symbol, write it as diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 8bf0675f54b..0033a94fb5c 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -173,7 +173,9 @@ the elements themselves. (defun cl-mapcan (cl-func cl-seq &rest cl-rest) "Like `cl-mapcar', but nconc's together the values returned by the function. \n(fn FUNCTION SEQUENCE...)" - (apply 'nconc (apply 'cl-mapcar cl-func cl-seq cl-rest))) + (if 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) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 4f263c6bb8d..61186e1a881 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -358,6 +358,26 @@ the specializer used will be the one returned by BODY." ,nbody)))))) (f (error "Unexpected macroexpansion result: %S" f)))))) +(put 'cl-defmethod 'function-documentation + '(cl--generic-make-defmethod-docstring)) + +(defun cl--generic-make-defmethod-docstring () + ;; FIXME: Copy&paste from pcase--make-docstring. + (let* ((main (documentation (symbol-function 'cl-defmethod) 'raw)) + (ud (help-split-fundoc main 'cl-defmethod))) + ;; So that eg emacs -Q -l cl-lib --eval "(documentation 'pcase)" works, + ;; where cl-lib is anything using pcase-defmacro. + (require 'help-fns) + (with-temp-buffer + (insert (or (cdr ud) main)) + (insert "\n\n\tCurrently supported forms for TYPE:\n\n") + (dolist (method (reverse (cl--generic-method-table + (cl--generic 'cl-generic-generalizers)))) + (let* ((info (cl--generic-method-info method))) + (when (nth 2 info) + (insert (nth 2 info) "\n\n")))) + (let ((combined-doc (buffer-string))) + (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc))))) ;;;###autoload (defmacro cl-defmethod (name args &rest body) @@ -375,15 +395,17 @@ modifies how the method is combined with other methods, including: :after - Method will be called after the primary :around - Method will be called around everything else The absence of QUALIFIER means this is a \"primary\" method. +The set of acceptable qualifiers and their meaning is defined +\(and can be extended) by the methods of `cl-generic-combine-methods'. -TYPE can be one of the basic types (see the full list and their -hierarchy in `cl--generic-typeof-types'), CL struct type, or an -EIEIO class. +ARGS can also include so-called context specializers, introduced by +`&context' (which should appear right after the mandatory arguments, +before any &optional or &rest). They have the form (EXPR TYPE) where +EXPR is an Elisp expression whose value should match TYPE for the +method to be applicable. -Other than that, TYPE can also be of the form `(eql VAL)' in -which case this method will be invoked when the argument is `eql' -to VAL, or `(head VAL)', in which case the argument is required -to be a cons with VAL as its head. +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 2) @@ -415,7 +437,8 @@ to be a cons with VAL as its head. ;; function, so warnings like "not known to be defined" are fair game. ;; But in practice, it's common to use `cl-defmethod' ;; without a previous `cl-defgeneric'. - (declare-function ,name "") + ;; The ",'" is a no-op that pacifies check-declare. + (,'declare-function ,name "") (cl-generic-define-method ',name ',(nreverse qualifiers) ',args ,uses-cnm ,fun))))) @@ -428,6 +451,12 @@ to be a cons with VAL as its head. (setq methods (cdr methods))) methods) +(defun cl--generic-load-hist-format (name qualifiers specializers) + ;; FIXME: This function is used in elisp-mode.el and + ;; elisp-mode-tests.el, but I still decided to use an internal name + ;; because these uses should be removed or moved into cl-generic.el. + `(,name ,qualifiers . ,specializers)) + ;;;###autoload (defun cl-generic-define-method (name qualifiers args uses-cnm function) (pcase-let* @@ -468,7 +497,9 @@ to be a cons with VAL as its head. (cons method mt) ;; Keep the ordering; important for methods with :extra qualifiers. (mapcar (lambda (x) (if (eq x (car me)) method x)) mt))) - (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers)) + (cl-pushnew `(cl-defmethod . ,(cl--generic-load-hist-format + (cl--generic-name generic) + qualifiers specializers)) current-load-list :test #'equal) ;; FIXME: Try to avoid re-constructing a new function if the old one ;; is still valid (e.g. still empty method cache)? @@ -750,7 +781,7 @@ methods.") (fset 'cl-generic-combine-methods #'cl--generic-standard-method-combination)) (cl-defmethod cl-generic-generalizers (specializer) - "Support for the catch-all t specializer." + "Support for the catch-all t specializer which always matches." (if (eq specializer t) (list cl--generic-t-generalizer) (error "Unknown specializer %S" specializer))) @@ -854,18 +885,22 @@ Can only be used from within the lexical body of a primary or around method." (defun cl--generic-search-method (met-name) "For `find-function-regexp-alist'. Searches for a cl-defmethod. -MET-NAME is a cons (SYMBOL . SPECIALIZERS)." +MET-NAME is as returned by `cl--generic-load-hist-format'." (let ((base-re (concat "(\\(?:cl-\\)?defmethod[ \t]+" (regexp-quote (format "%s" (car met-name))) "\\_>"))) (or (re-search-forward (concat base-re "[^&\"\n]*" + (mapconcat (lambda (qualifier) + (regexp-quote (format "%S" qualifier))) + (cadr met-name) + "[ \t\n]*") (mapconcat (lambda (specializer) (regexp-quote (format "%S" (if (consp specializer) (nth 1 specializer) specializer)))) - (remq t (cdr met-name)) + (remq t (cddr met-name)) "[ \t\n]*)[^&\"\n]*")) nil t) (re-search-forward base-re nil t)))) @@ -922,8 +957,10 @@ MET-NAME is a cons (SYMBOL . SPECIALIZERS)." (let* ((info (cl--generic-method-info method))) ;; FIXME: Add hyperlinks for the types as well. (insert (format "%s%S" (nth 0 info) (nth 1 info))) - (let* ((met-name (cons function - (cl--generic-method-specializers method))) + (let* ((met-name (cl--generic-load-hist-format + function + (cl--generic-method-qualifiers method) + (cl--generic-method-specializers method))) (file (find-lisp-object-file-name met-name 'cl-defmethod))) (when file (insert (substitute-command-keys " in `")) @@ -1007,7 +1044,8 @@ The value returned is a list of elements of the form (lambda (tag &rest _) (if (eq (car-safe tag) 'head) (list tag)))) (cl-defmethod cl-generic-generalizers :extra "head" (specializer) - "Support for the `(head VAL)' specializers." + "Support for (head VAL) specializers. +These match if the argument is a cons cell whose car is `eql' to VAL." ;; We have to implement `head' here using the :extra qualifier, ;; since we can't use the `head' specializer to implement itself. (if (not (eq (car-safe specializer) 'head)) @@ -1027,7 +1065,8 @@ The value returned is a list of elements of the form (lambda (tag &rest _) (if (eq (car-safe tag) 'eql) (list tag)))) (cl-defmethod cl-generic-generalizers ((specializer (head eql))) - "Support for the `(eql VAL)' specializers." + "Support for (eql VAL) specializers. +These match if the argument is `eql' to VAL." (puthash (cadr specializer) specializer cl--generic-eql-used) (list cl--generic-eql-generalizer)) @@ -1082,7 +1121,7 @@ The value returned is a list of elements of the form #'cl--generic-struct-specializers) (cl-defmethod cl-generic-generalizers :extra "cl-struct" (type) - "Support for dispatch on cl-struct types." + "Support for dispatch on types defined by `cl-defstruct'." (or (when (symbolp type) ;; Use the "cl--struct-class*" (inlinable) functions/macros rather than @@ -1126,7 +1165,8 @@ The value returned is a list of elements of the form (and (symbolp tag) (assq tag cl--generic-typeof-types)))) (cl-defmethod cl-generic-generalizers :extra "typeof" (type) - "Support for dispatch on builtin types." + "Support for dispatch on builtin types. +See the full list and their hierarchy in `cl--generic-typeof-types'." ;; FIXME: Add support for other types accepted by `cl-typep' such ;; as `character', `atom', `face', `function', ... (or @@ -1164,7 +1204,8 @@ The value returned is a list of elements of the form #'cl--generic-derived-specializers) (cl-defmethod cl-generic-generalizers ((_specializer (head derived-mode))) - "Support for the `(derived-mode MODE)' specializers." + "Support for (derived-mode MODE) specializers. +Used internally for the (major-mode MODE) context specializers." (list cl--generic-derived-generalizer)) (cl-generic-define-context-rewriter major-mode (mode &rest modes) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index c51ed9d8770..37244f5c350 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -1837,6 +1837,27 @@ Labels have lexical scope and dynamic extent." `(throw ',catch-tag ',label)))) ,@macroexpand-all-environment))))) +(defun cl--prog (binder bindings body) + (let (decls) + (while (eq 'declare (car-safe (car body))) + (push (pop body) decls)) + `(cl-block nil + (,binder ,bindings + ,@(nreverse decls) + (cl-tagbody . ,body))))) + +;;;###autoload +(defmacro cl-prog (bindings &rest body) + "Run BODY like a `cl-tagbody' after setting up the BINDINGS. +Shorthand for (cl-block nil (let BINDINGS (cl-tagbody BODY)))" + (cl--prog 'let bindings body)) + +;;;###autoload +(defmacro cl-prog* (bindings &rest body) + "Run BODY like a `cl-tagbody' after setting up the BINDINGS. +Shorthand for (cl-block nil (let* BINDINGS (cl-tagbody BODY)))" + (cl--prog 'let* bindings body)) + ;;;###autoload (defmacro cl-do-symbols (spec &rest body) "Loop over all symbols. @@ -2701,7 +2722,11 @@ non-nil value, that slot cannot be set via `setf'. (let ((accessor (intern (format "%s%s" conc-name slot)))) (push slot slots) (push (nth 1 desc) defaults) + ;; The arg "cl-x" is referenced by name in eg pred-form + ;; and pred-check, so changing it is not straightforward. (push `(cl-defsubst ,accessor (cl-x) + ,(format "Access slot \"%s\" of `%s' struct CL-X." + slot struct) (declare (side-effect-free t)) ,@(and pred-check (list `(or ,pred-check diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index 21aec6cdfcd..443a147b3d2 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -116,6 +116,16 @@ (defun cl-reduce (cl-func cl-seq &rest cl-keys) "Reduce two-argument FUNCTION across SEQ. \nKeywords supported: :start :end :from-end :initial-value :key + +Return the result of calling FUNCTION with the first and the +second element of SEQ, then calling FUNCTION with that result and +the third element of SEQ, then with that result and the fourth +element of SEQ, etc. + +If :INITIAL-VALUE is specified, it is added to the front of SEQ. +If SEQ is empty, return :INITIAL-VALUE and FUNCTION is not +called. + \n(fn FUNCTION SEQ [KEYWORD VALUE]...)" (cl--parsing-keywords (:from-end (:start 0) :end :initial-value :key) () (or (listp cl-seq) (setq cl-seq (append cl-seq nil))) diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index e48376bbabd..fac600e4e13 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -154,7 +154,6 @@ every some mapcon - mapcan mapl maplist map diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index a615f9a5854..0f7691af0f4 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -137,6 +137,9 @@ BODY can start with a bunch of keyword arguments. The following keyword :abbrev-table TABLE Use TABLE instead of the default (CHILD-abbrev-table). A nil value means to simply use the same abbrev-table as the parent. +:after-hook FORM + A single lisp form which is evaluated after the mode hooks have been + run. It should not be quoted. Here is how you could define LaTeX-Thesis mode as a variant of LaTeX mode: @@ -184,7 +187,8 @@ See Info node `(elisp)Derived Modes' for more details." (declare-abbrev t) (declare-syntax t) (hook (derived-mode-hook-name child)) - (group nil)) + (group nil) + (after-hook nil)) ;; Process the keyword args. (while (keywordp (car body)) @@ -192,6 +196,7 @@ See Info node `(elisp)Derived Modes' for more details." (`:group (setq group (pop body))) (`: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))) (_ (pop body)))) (setq docstring (derived-mode-make-docstring @@ -272,7 +277,11 @@ No problems result if this variable is not bound. ,@body ) ;; Run the hooks, if any. - (run-mode-hooks ',hook))))) + (run-mode-hooks ',hook) + ,@(when after-hook + `((if delay-mode-hooks + (push ',after-hook delayed-after-hook-forms) + ,after-hook))))))) ;; PUBLIC: find the ultimate class of a derived mode. @@ -344,7 +353,7 @@ which more-or-less shadow%s %s's corresponding table%s." (format "`%s' " parent)) "might have run,\nthis mode ")) (format "runs the hook `%s'" hook) - ", as the final step\nduring initialization."))) + ", as the final or penultimate step\nduring initialization."))) (unless (string-match "\\\\[{[]" docstring) ;; And don't forget to put the mode's keymap. diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 05229d2df04..38295c302ea 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -108,9 +108,10 @@ 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 - arguments for `easy-mmode-define-keymap'. 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. + (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. diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index e8484fa1f94..c283c168b5e 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -233,6 +233,12 @@ If the result is non-nil, then break. Errors are ignored." :type 'number :group 'edebug) +(defcustom edebug-sit-on-break t + "Whether or not to pause for `edebug-sit-for-seconds' on reaching a break." + :type 'boolean + :group 'edebug + :version "25.2") + ;;; Form spec utilities. (defun get-edebug-spec (symbol) @@ -2489,6 +2495,7 @@ MSG is printed after `::::} '." (progn ;; Display result of previous evaluation. (if (and edebug-break + edebug-sit-on-break (not (eq edebug-execution-mode 'Continue-fast))) (sit-for edebug-sit-for-seconds)) ; Show message. (edebug-previous-result))) diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el index 6aba8a3acbd..413b94f01a8 100644 --- a/lisp/emacs-lisp/eieio-compat.el +++ b/lisp/emacs-lisp/eieio-compat.el @@ -266,7 +266,7 @@ Summary: ;; Local Variables: -;; generated-autoload-file: "eieio-core.el" +;; generated-autoload-file: "eieio-loaddefs.el" ;; End: (provide 'eieio-compat) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 223c2a69a62..52577adefac 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -33,6 +33,7 @@ (require 'cl-lib) (require 'pcase) +(require 'eieio-loaddefs) ;;; ;; A few functions that are better in the official EIEIO src, but @@ -756,9 +757,7 @@ Argument FN is the function calling this verifier." ;; The slot-missing method is a cool way of allowing an object author ;; to intercept missing slot definitions. Since it is also the LAST ;; thing called in this fn, its return value would be retrieved. - (slot-missing obj slot 'oref) - ;;(signal 'invalid-slot-name (list (eieio-object-name obj) slot)) - ) + (slot-missing obj slot 'oref)) (cl-check-type obj eieio-object) (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) @@ -780,9 +779,7 @@ Fills in OBJ's SLOT with its default value." ;; Oref that slot. (aref (eieio--class-class-allocation-values cl) c) - (slot-missing obj slot 'oref-default) - ;;(signal 'invalid-slot-name (list (class-name cl) slot)) - ) + (slot-missing obj slot 'oref-default)) (eieio-barf-if-slot-unbound (let ((val (cl--slot-descriptor-initform (aref (eieio--class-slots cl) @@ -822,9 +819,7 @@ Fills in OBJ's SLOT with VALUE." (aset (eieio--class-class-allocation-values class) c value)) ;; See oref for comment on `slot-missing' - (slot-missing obj slot 'oset value) - ;;(signal 'invalid-slot-name (list (eieio-object-name obj) slot)) - ) + (slot-missing obj slot 'oset value)) (eieio--validate-slot-value class c value slot) (aset obj c value)))) @@ -1070,6 +1065,7 @@ method invocation orders of the involved classes." (eieio--class-precedence-list (symbol-value tag)))))) (cl-defmethod cl-generic-generalizers :extra "class" (specializer) + "Support for dispatch on types defined by EIEIO's `defclass'." ;; CLHS says: ;; A class must be defined before it can be used as a parameter ;; specializer in a defmethod form. @@ -1098,100 +1094,10 @@ method invocation orders of the involved classes." #'eieio--generic-subclass-specializers) (cl-defmethod cl-generic-generalizers ((_specializer (head subclass))) + "Support for (subclass CLASS) specializers. +These match if the argument is the name of a subclass of CLASS." (list eieio--generic-subclass-generalizer)) - -;;;### (autoloads nil "eieio-compat" "eieio-compat.el" "dba4205b1a0d7133f1311d975b4d0ebe") -;;; Generated autoloads from eieio-compat.el - -(autoload 'eieio--defalias "eieio-compat" "\ -Like `defalias', but with less side-effects. -More specifically, it has no side-effects at all when the new function -definition is the same (`eq') as the old one. - -\(fn NAME BODY)" nil nil) - -(autoload 'defgeneric "eieio-compat" "\ -Create a generic function METHOD. -DOC-STRING is the base documentation for this class. A generic -function has no body, as its purpose is to decide which method body -is appropriate to use. Uses `defmethod' to create methods, and calls -`defgeneric' for you. With this implementation the ARGS are -currently ignored. You can use `defgeneric' to apply specialized -top level documentation to a method. - -\(fn METHOD ARGS &optional DOC-STRING)" nil t) - -(function-put 'defgeneric 'doc-string-elt '3) - -(make-obsolete 'defgeneric 'cl-defgeneric '"25.1") - -(autoload 'defmethod "eieio-compat" "\ -Create a new METHOD through `defgeneric' with ARGS. - -The optional second argument KEY is a specifier that -modifies how the method is called, including: - :before - Method will be called before the :primary - :primary - The default if not specified - :after - Method will be called after the :primary - :static - First arg could be an object or class -The next argument is the ARGLIST. The ARGLIST specifies the arguments -to the method as with `defun'. The first argument can have a type -specifier, such as: - ((VARNAME CLASS) ARG2 ...) -where VARNAME is the name of the local variable for the method being -created. The CLASS is a class symbol for a class made with `defclass'. -A DOCSTRING comes after the ARGLIST, and is optional. -All the rest of the args are the BODY of the method. A method will -return the value of the last form in the BODY. - -Summary: - - (defmethod mymethod [:before | :primary | :after | :static] - ((typearg class-name) arg2 &optional opt &rest rest) - \"doc-string\" - body) - -\(fn METHOD &rest ARGS)" nil t) - -(function-put 'defmethod 'doc-string-elt '3) - -(make-obsolete 'defmethod 'cl-defmethod '"25.1") - -(autoload 'eieio--defgeneric-init-form "eieio-compat" "\ - - -\(fn METHOD DOC-STRING)" nil nil) - -(autoload 'eieio--defmethod "eieio-compat" "\ - - -\(fn METHOD KIND ARGCLASS CODE)" nil nil) - -(autoload 'eieio-defmethod "eieio-compat" "\ -Obsolete work part of an old version of the `defmethod' macro. - -\(fn METHOD ARGS)" nil nil) - -(make-obsolete 'eieio-defmethod 'cl-defmethod '"24.1") - -(autoload 'eieio-defgeneric "eieio-compat" "\ -Obsolete work part of an old version of the `defgeneric' macro. - -\(fn METHOD DOC-STRING)" nil nil) - -(make-obsolete 'eieio-defgeneric 'cl-defgeneric '"24.1") - -(autoload 'eieio-defclass "eieio-compat" "\ - - -\(fn CNAME SUPERCLASSES SLOTS OPTIONS)" nil nil) - -(make-obsolete 'eieio-defclass 'eieio-defclass-internal '"25.1") - -;;;*** - - (provide 'eieio-core) ;;; eieio-core.el ends here diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el index 0ba1eba4f48..d2d87ea1537 100644 --- a/lisp/emacs-lisp/eieio-custom.el +++ b/lisp/emacs-lisp/eieio-custom.el @@ -473,7 +473,7 @@ Return the symbol for the group, or nil" (provide 'eieio-custom) ;; Local variables: -;; generated-autoload-file: "eieio.el" +;; generated-autoload-file: "eieio-loaddefs.el" ;; End: ;;; eieio-custom.el ends here diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index c1f8297b4a5..2f1d69f78f8 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -349,7 +349,7 @@ INDENT is the current indentation level." (provide 'eieio-opt) ;; Local variables: -;; generated-autoload-file: "eieio.el" +;; generated-autoload-file: "eieio-loaddefs.el" ;; End: ;;; eieio-opt.el ends here diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index f045e267ff4..80ac8eff322 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -678,7 +678,8 @@ This class is not stored in the `parent' slot of a class vector." (setq eieio-default-superclass (cl--find-class 'eieio-default-superclass)) -(defalias 'standard-class 'eieio-default-superclass) +(define-obsolete-function-alias 'standard-class + 'eieio-default-superclass "25.2") (cl-defgeneric make-instance (class &rest initargs) "Make a new instance of CLASS based on INITARGS. @@ -765,11 +766,7 @@ dynamically set from SLOTS." ;; Shared initialize will parse our slots for us. (shared-initialize this slots)) -(cl-defgeneric slot-missing (object slot-name operation &optional new-value) - "Method invoked when an attempt to access a slot in OBJECT fails.") - -(cl-defmethod slot-missing ((object eieio-default-superclass) slot-name - _operation &optional _new-value) +(cl-defgeneric slot-missing (object slot-name _operation &optional _new-value) "Method invoked when an attempt to access a slot in OBJECT fails. SLOT-NAME is the name of the failed slot, OPERATION is the type of access that was requested, and optional NEW-VALUE is the value that was desired @@ -777,8 +774,9 @@ to be set. This method is called from `oref', `oset', and other functions which directly reference slots in EIEIO objects." - (signal 'invalid-slot-name (list (eieio-object-name object) - slot-name))) + (signal 'invalid-slot-name + (list (if (eieio-object-p object) (eieio-object-name object) object) + slot-name))) (cl-defgeneric slot-unbound (object class slot-name fn) "Slot unbound is invoked during an attempt to reference an unbound slot.") @@ -815,22 +813,19 @@ first and modify the returned object.") (if params (shared-initialize nobj params)) nobj)) -(cl-defgeneric destructor (this &rest params) - "Destructor for cleaning up any dynamic links to our object.") - -(cl-defmethod destructor ((_this eieio-default-superclass) &rest _params) - "Destructor for cleaning up any dynamic links to our object. -Argument THIS is the object being destroyed. PARAMS are additional -ignored parameters." +(cl-defgeneric destructor (_this &rest _params) + "Destructor for cleaning up any dynamic links to our object." + (declare (obsolete nil "25.2")) ;; No cleanup... yet. - ) + nil) -(cl-defgeneric object-print (this &rest strings) - "Pretty printer for object THIS. Call function `object-name' with STRINGS. +(cl-defgeneric object-print (this &rest _strings) + "Pretty printer for object THIS. It is sometimes useful to put a summary of the object into the default #<notation> string when using EIEIO browsing tools. -Implement this method to customize the summary.") +Implement this method to customize the summary." + (format "%S" this)) (cl-defmethod object-print ((this eieio-default-superclass) &rest strings) "Pretty printer for object THIS. Call function `object-name' with STRINGS. @@ -938,11 +933,12 @@ this object." ;;; Unimplemented functions from CLOS ;; -(defun change-class (_obj _class) +(defun eieio-change-class (_obj _class) "Change the class of OBJ to type CLASS. 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 "25.2") ;; Hook ourselves into help system for describing classes and methods. ;; FIXME: This is not actually needed any more since we can click on the @@ -970,41 +966,6 @@ variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to (advice-add 'edebug-prin1-to-string :around #'eieio-edebug-prin1-to-string) - -;;; Start of automatically extracted autoloads. - -;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "e8d466f8eee341f3da967c2931b28043") -;;; Generated autoloads from eieio-custom.el - -(autoload 'customize-object "eieio-custom" "\ -Customize OBJ in a custom buffer. -Optional argument GROUP is the sub-group of slots to display. - -\(fn OBJ &optional GROUP)" nil nil) - -;;;*** - -;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "0b9c6be48520da2085812f6e7fed9792") -;;; Generated autoloads from eieio-opt.el - -(autoload 'eieio-browse "eieio-opt" "\ -Create an object browser window to show all objects. -If optional ROOT-CLASS, then start with that, otherwise start with -variable `eieio-default-superclass'. - -\(fn &optional ROOT-CLASS)" t nil) - -(define-obsolete-function-alias 'eieio-help-class 'cl--describe-class "25.1") - -(autoload 'eieio-help-constructor "eieio-opt" "\ -Describe CTR if it is a class constructor. - -\(fn CTR)" nil nil) - -;;;*** - -;;; End of automatically extracted autoloads. - (provide 'eieio) ;;; eieio ends here diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 096102ae7e1..6c2f869f260 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -197,7 +197,10 @@ expression point is on." (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 'pre-command-hook 'eldoc-pre-command-refresh-echo-area t) + (when eldoc-timer + (cancel-timer eldoc-timer) + (setq eldoc-timer nil))))) ;;;###autoload (define-minor-mode global-eldoc-mode diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 7a914da3977..0308c9cd37c 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -1470,7 +1470,7 @@ this exits Emacs, with status as per `ert-run-tests-batch-and-exit'." (user-error "This function is only for use in batch mode")) (let ((nlogs (length command-line-args-left)) (ntests 0) (nrun 0) (nexpected 0) (nunexpected 0) (nskipped 0) - nnotrun logfile notests badtests unexpected) + nnotrun logfile notests badtests unexpected skipped) (with-temp-buffer (while (setq logfile (pop command-line-args-left)) (erase-buffer) @@ -1490,9 +1490,10 @@ Ran \\([0-9]+\\) tests, \\([0-9]+\\) results as expected\ (push logfile unexpected) (setq nunexpected (+ nunexpected (string-to-number (match-string 4))))) - (if (match-string 5) - (setq nskipped (+ nskipped - (string-to-number (match-string 5))))))))) + (when (match-string 5) + (push logfile skipped) + (setq nskipped (+ nskipped + (string-to-number (match-string 5))))))))) (setq nnotrun (- ntests nrun)) (message "\nSUMMARY OF TEST RESULTS") (message "-----------------------") @@ -1516,6 +1517,26 @@ Ran \\([0-9]+\\) tests, \\([0-9]+\\) results as expected\ (when unexpected (message "%d files contained unexpected results:" (length unexpected)) (mapc (lambda (l) (message " %s" l)) unexpected)) + ;; More details on hydra, where the logs are harder to get to. + (when (and (getenv "NIX_STORE") + (not (zerop (+ nunexpected nskipped)))) + (message "\nDETAILS") + (message "-------") + (with-temp-buffer + (dolist (x (list (list skipped "skipped" "SKIPPED") + (list unexpected "unexpected" "FAILED"))) + (mapc (lambda (l) + (erase-buffer) + (insert-file-contents l) + (message "%s:" l) + (when (re-search-forward (format "^[ \t]*[0-9]+ %s results:" + (nth 1 x)) + nil t) + (while (and (zerop (forward-line 1)) + (looking-at (format "^[ \t]*%s" (nth 2 x)))) + (message "%s" (buffer-substring (line-beginning-position) + (line-end-position)))))) + (car x))))) (kill-emacs (cond ((or notests badtests (not (zerop nnotrun))) 2) (unexpected 1) (t 0))))) @@ -2460,7 +2481,7 @@ To be used in the ERT results buffer." stats) for end-time across (ert--stats-test-end-times stats) collect (list test - (float-time (subtract-time + (float-time (time-subtract end-time start-time)))))) (setq data (sort data (lambda (a b) (> (cl-second a) (cl-second b))))) diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 43bcb420c36..cbb134e95d5 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -43,6 +43,8 @@ ;;; Code: +(require 'seq) + ;;; User variables: (defgroup find-function nil @@ -182,15 +184,15 @@ See the functions `find-function' and `find-variable'." LIBRARY should be a string (the name of the library)." ;; If the library is byte-compiled, try to find a source library by ;; the same name. - (if (string-match "\\.el\\(c\\(\\..*\\)?\\)\\'" library) - (setq library (replace-match "" t t library))) + (when (string-match "\\.el\\(c\\(\\..*\\)?\\)\\'" library) + (setq library (replace-match "" t t library))) (or (locate-file library - (or find-function-source-path load-path) - (find-library-suffixes)) + (or find-function-source-path load-path) + (find-library-suffixes)) (locate-file library - (or find-function-source-path load-path) - load-file-rep-suffixes) + (or find-function-source-path load-path) + load-file-rep-suffixes) (when (file-name-absolute-p library) (let ((rel (find-library--load-name library))) (when rel @@ -201,8 +203,44 @@ LIBRARY should be a string (the name of the library)." (locate-file rel (or find-function-source-path load-path) load-file-rep-suffixes))))) + (find-library--from-load-path library) (error "Can't find library %s" library))) +(defun find-library--from-load-path (library) + ;; In `load-history', the file may be ".elc", ".el", ".el.gz", and + ;; LIBRARY may be "foo.el" or "foo", so make sure that we get all + ;; potential matches, and then see whether any of them lead us to an + ;; ".el" or an ".el.gz" file. + (let* ((elc-regexp "\\.el\\(c\\(\\..*\\)?\\)\\'") + (suffix-regexp + (concat "\\(" + (mapconcat 'regexp-quote (find-library-suffixes) "\\'\\|") + "\\|" elc-regexp "\\)\\'")) + (potentials + (mapcar + (lambda (entry) + (if (string-match suffix-regexp (car entry)) + (replace-match "" t t (car entry)) + (car entry))) + (seq-filter + (lambda (entry) + (string-match + (concat "\\`" + (regexp-quote + (replace-regexp-in-string suffix-regexp "" library)) + suffix-regexp) + (file-name-nondirectory (car entry)))) + load-history))) + result) + (dolist (file potentials) + (dolist (suffix (find-library-suffixes)) + (when (not result) + (cond ((file-exists-p file) + (setq result file)) + ((file-exists-p (concat file suffix)) + (setq result (concat file suffix))))))) + result)) + (defvar find-function-C-source-directory (let ((dir (expand-file-name "src" source-directory))) (if (file-accessible-directory-p dir) dir)) @@ -255,9 +293,12 @@ TYPE should be nil to find a function, or `defvar' to find a variable." (cons (current-buffer) (match-beginning 0)))) ;;;###autoload -(defun find-library (library) +(defun find-library (library &optional other-window) "Find the Emacs Lisp source of LIBRARY. -LIBRARY should be a string (the name of the library)." +LIBRARY should be a string (the name of the library). If the +optional OTHER-WINDOW argument (i.e., the command argument) is +specified, pop to a different window before displaying the +buffer." (interactive (let* ((dirs (or find-function-source-path load-path)) (suffixes (find-library-suffixes)) @@ -279,11 +320,17 @@ LIBRARY should be a string (the name of the library)." (when (and def (not (test-completion def table))) (setq def nil)) (list - (completing-read (if def (format "Library name (default %s): " def) + (completing-read (if def + (format "Library name (default %s): " def) "Library name: ") - table nil nil nil nil def)))) - (let ((buf (find-file-noselect (find-library-name library)))) - (condition-case nil (switch-to-buffer buf) (error (pop-to-buffer buf))))) + table nil nil nil nil def) + current-prefix-arg))) + (prog1 + (funcall (if other-window + 'pop-to-buffer + 'pop-to-buffer-same-window) + (find-file-noselect (find-library-name library))) + (run-hooks 'find-function-after-hook))) ;;;###autoload (defun find-function-search-for-symbol (symbol type library) diff --git a/lisp/emacs-lisp/let-alist.el b/lisp/emacs-lisp/let-alist.el index e400b499036..3507a395436 100644 --- a/lisp/emacs-lisp/let-alist.el +++ b/lisp/emacs-lisp/let-alist.el @@ -2,13 +2,16 @@ ;; Copyright (C) 2014-2016 Free Software Foundation, Inc. -;; Author: Artur Malabarba <bruce.connor.am@gmail.com> -;; Maintainer: Artur Malabarba <bruce.connor.am@gmail.com> +;; Author: Artur Malabarba <emacs@endlessparentheses.com> +;; Package-Requires: ((emacs "24.1")) ;; Version: 1.0.4 ;; Keywords: extensions lisp ;; Prefix: let-alist ;; Separator: - +;; This is an Elpa :core package. Don't use functionality that is not +;; compatible with Emacs 24.1. + ;; This file is part of GNU Emacs. ;; GNU Emacs is free software: you can redistribute it and/or modify @@ -134,7 +137,7 @@ displayed in the example above." (let ((var (make-symbol "alist"))) `(let ((,var ,alist)) (let ,(mapcar (lambda (x) `(,(car x) ,(let-alist--access-sexp (car x) var))) - (delete-dups (let-alist--deep-dot-search body))) + (delete-dups (let-alist--deep-dot-search body))) ,@body)))) (provide 'let-alist) diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index cfec05cd01d..a277d7a6680 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -168,6 +168,8 @@ (defvar lisp-doc-string-elt-property 'doc-string-elt "The symbol property that holds the docstring position info.") +(defconst lisp-prettify-symbols-alist '(("lambda" . ?λ)) + "Alist of symbol/\"pretty\" characters to be displayed.") ;;;; Font-lock support. @@ -594,7 +596,7 @@ font-lock keywords will not be case sensitive." (font-lock-extra-managed-props help-echo) (font-lock-syntactic-face-function . lisp-font-lock-syntactic-face-function))) - (setq-local prettify-symbols-alist lisp--prettify-symbols-alist) + (setq-local prettify-symbols-alist lisp-prettify-symbols-alist) (setq-local electric-pair-skip-whitespace 'chomp) (setq-local electric-pair-open-newline-between-pairs nil)) @@ -655,9 +657,6 @@ font-lock keywords will not be case sensitive." :type 'hook :group 'lisp) -(defconst lisp--prettify-symbols-alist - '(("lambda" . ?λ))) - ;;; Generic Lisp mode. (defvar lisp-mode-map @@ -1217,8 +1216,15 @@ and initial semicolons." ;; ;; The `fill-column' is temporarily bound to ;; `emacs-lisp-docstring-fill-column' if that value is an integer. - (let ((paragraph-start (concat paragraph-start - "\\|\\s-*\\([(;:\"]\\|`(\\|#'(\\)")) + (let ((paragraph-start + (concat paragraph-start + (format "\\|\\s-*\\([(;%s\"]\\|`(\\|#'(\\)" + ;; If we're inside a string (like the doc + ;; string), don't consider a colon to be + ;; a paragraph-start character. + (if (nth 3 (syntax-ppss)) + "" + ":")))) (paragraph-separate (concat paragraph-separate "\\|\\s-*\".*[,\\.]$")) (fill-column (if (and (integerp emacs-lisp-docstring-fill-column) diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index ba15a65f5e1..98a88711aa5 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -4,7 +4,7 @@ ;; Author: Nicolas Petton <nicolas@petton.fr> ;; Keywords: convenience, map, hash-table, alist, array -;; Version: 1.0 +;; Version: 1.1 ;; Package: map ;; Maintainer: emacs-devel@gnu.org @@ -43,6 +43,7 @@ ;;; Code: (require 'seq) +(eval-when-compile (require 'cl-lib)) (pcase-defmacro map (&rest args) "Build a `pcase' pattern matching map elements. @@ -200,6 +201,16 @@ MAP can be a list, hash-table or array." function map)) +(defun map-do (function map) + "Apply FUNCTION to each element of MAP and return nil. +FUNCTION.is called with two arguments, the key and the value." + (funcall (map--dispatch map + :list #'map--do-alist + :hash-table #'maphash + :array #'map--do-array) + function + map)) + (defun map-keys-apply (function map) "Return the result of applying FUNCTION to each key of MAP. @@ -249,7 +260,7 @@ MAP can be a list, hash-table or array." :hash-table (zerop (hash-table-count map)))) (defun map-contains-key (map key &optional testfn) - "Return non-nil if MAP contain KEY, nil otherwise. + "If MAP contain KEY return KEY, nil otherwise. Equality is defined by TESTFN if non-nil or by `equal' if nil. MAP can be a list, hash-table or array." @@ -282,27 +293,33 @@ MAP can be a list, hash-table or array." "Merge into a map of type TYPE all the key/value pairs in MAPS. MAP can be a list, hash-table or array." - (let (result) + (let ((result (map-into (pop maps) type))) (while maps + ;; FIXME: When `type' is `list', we get an O(N^2) behavior. + ;; 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-into result type))) + (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, call FUNCTION on the two values and use the value returned by it. MAP can be a list, hash-table or array." - (let (result) + (let ((result (map-into (pop maps) type)) + (not-found (cons nil nil))) (while maps (map-apply (lambda (key value) - (setf (map-elt result key) - (if (map-contains-key result key) - (funcall function (map-elt result key) value) - value))) - (pop maps))) - (map-into result type))) + (cl-callf (lambda (old) + (if (eq old not-found) + value + (funcall function old value))) + (map-elt result key not-found))) + (pop maps))) + result)) (defun map-into (map type) "Convert the map MAP into a map of type TYPE. @@ -347,6 +364,20 @@ MAP can be a list, hash-table or array." (setq index (1+ index)))) map))) +(defun map--do-alist (function alist) + "Private function used to iterate over ALIST using FUNCTION." + (seq-do (lambda (pair) + (funcall function + (car pair) + (cdr pair))) + alist)) + +(defun map--do-array (function array) + "Private function used to iterate over ARRAY using FUNCTION." + (seq-do-indexed (lambda (elt index) + (funcall function index elt)) + array)) + (defun map--into-hash-table (map) "Convert MAP into a hash-table." (let ((ht (make-hash-table :size (map-length map) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index e4bb561a87a..e721b553eae 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -150,6 +150,7 @@ (require 'tabulated-list) (require 'macroexp) +(require 'url-handlers) (defgroup package nil "Manager for Emacs Lisp packages." @@ -302,7 +303,7 @@ contrast, `package-user-dir' contains packages for personal use." :version "24.1") (declare-function epg-find-configuration "epg-config" - (protocol &optional force)) + (protocol &optional no-cache program-alist)) (defcustom package-check-signature (if (and (require 'epg-config) @@ -907,12 +908,15 @@ untar into a directory named DIR; otherwise, signal an error." file) (defvar generated-autoload-file) +(defvar autoload-timestamps) (defvar version-control) (defun package-generate-autoloads (name pkg-dir) (let* ((auto-name (format "%s-autoloads.el" name)) ;;(ignore-name (concat name "-pkg.el")) (generated-autoload-file (expand-file-name auto-name pkg-dir)) + ;; We don't need 'em, and this makes the output reproducible. + (autoload-timestamps nil) ;; Silence `autoload-generate-file-autoloads'. (noninteractive inhibit-message) (backup-inhibited t) @@ -2304,7 +2308,7 @@ Otherwise no newline is inserted." (insert "\n") (unless (and pkg-dir (not archive)) ; Installed pkgs don't have archive. (package--print-help-section "Archive" - (or archive "n/a") "\n")) + (or archive "n/a"))) (and version (package--print-help-section "Version" (package-version-join version))) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 7e164c0fe5c..0b8dddfacc9 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -509,6 +509,7 @@ MATCH is the pattern that needs to be matched, of the form: (numberp . stringp) (numberp . byte-code-function-p) (consp . arrayp) + (consp . atom) (consp . vectorp) (consp . stringp) (consp . byte-code-function-p) diff --git a/lisp/emacs-lisp/radix-tree.el b/lisp/emacs-lisp/radix-tree.el new file mode 100644 index 00000000000..8146bb3c283 --- /dev/null +++ b/lisp/emacs-lisp/radix-tree.el @@ -0,0 +1,246 @@ +;;; radix-tree.el --- A simple library of radix trees -*- lexical-binding: t; -*- + +;; Copyright (C) 2016 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Keywords: + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; There are many different options for how to represent radix trees +;; in Elisp. Here I chose a very simple one. A radix-tree can be either: +;; - a node, of the form ((PREFIX . PTREE) . RTREE) where PREFIX is a string +;; meaning that everything that starts with PREFIX is in PTREE, +;; and everything else in RTREE. It also has the property that +;; everything that starts with the first letter of PREFIX but not with +;; that whole PREFIX is not in RTREE (i.e. is not in the tree at all). +;; - anything else is taken as the value to associate with the empty string. +;; So every node is basically an (improper) alist where each mapping applies +;; to a different leading letter. +;; +;; The main downside of this representation is that the lookup operation +;; is slower because each level of the tree is an alist rather than some kind +;; of array, so every level's lookup is O(N) rather than O(1). We could easily +;; solve this by using char-tables instead of alists, but that would make every +;; level take up a lot more memory, and it would make the resulting +;; data structure harder to read (by a human) when printed out. + +;;; Code: + +(defun radix-tree--insert (tree key val i) + (pcase tree + (`((,prefix . ,ptree) . ,rtree) + (let* ((ni (+ i (length prefix))) + (cmp (compare-strings prefix nil nil key i ni))) + (if (eq t cmp) + (let ((nptree (radix-tree--insert ptree key val ni))) + `((,prefix . ,nptree) . ,rtree)) + (let ((n (if (< cmp 0) (- -1 cmp) (- cmp 1)))) + (if (zerop n) + (let ((nrtree (radix-tree--insert rtree key val i))) + `((,prefix . ,ptree) . ,nrtree)) + (let* ((nprefix (substring prefix 0 n)) + (kprefix (substring key (+ i n))) + (pprefix (substring prefix n)) + (ktree (if (equal kprefix "") val + `((,kprefix . ,val))))) + `((,nprefix + . ((,pprefix . ,ptree) . ,ktree)) + . ,rtree))))))) + (_ + (if (= (length key) i) val + (let ((prefix (substring key i))) + `((,prefix . ,val) . ,tree)))))) + +(defun radix-tree--remove (tree key i) + (pcase tree + (`((,prefix . ,ptree) . ,rtree) + (let* ((ni (+ i (length prefix))) + (cmp (compare-strings prefix nil nil key i ni))) + (if (eq t cmp) + (pcase (radix-tree--remove ptree key ni) + (`nil rtree) + (`((,pprefix . ,pptree)) + `((,(concat prefix pprefix) . ,pptree) . ,rtree)) + (nptree `((,prefix . ,nptree) . ,rtree))) + (let ((n (if (< cmp 0) (- -1 cmp) (- cmp 1)))) + (if (zerop n) + (let ((nrtree (radix-tree--remove rtree key i))) + `((,prefix . ,ptree) . ,nrtree)) + tree))))) + (_ + (if (= (length key) i) nil tree)))) + + +(defun radix-tree--lookup (tree string i) + (pcase tree + (`((,prefix . ,ptree) . ,rtree) + (let* ((ni (+ i (length prefix))) + (cmp (compare-strings prefix nil nil string i ni))) + (if (eq t cmp) + (radix-tree--lookup ptree string ni) + (let ((n (if (< cmp 0) (- -1 cmp) (- cmp 1)))) + (if (zerop n) + (radix-tree--lookup rtree string i) + (+ i n)))))) + (val + (if (and val (equal (length string) i)) + (if (integerp val) `(t . ,val) val) + i)))) + +;; (defun radix-tree--trim (tree string i) +;; (if (= i (length string)) +;; tree +;; (pcase tree +;; (`((,prefix . ,ptree) . ,rtree) +;; (let* ((ni (+ i (length prefix))) +;; (cmp (compare-strings prefix nil nil string i ni)) +;; ;; FIXME: We could compute nrtree more efficiently +;; ;; whenever cmp is not -1 or 1. +;; (nrtree (radix-tree--trim rtree string i))) +;; (if (eq t cmp) +;; (pcase (radix-tree--trim ptree string ni) +;; (`nil nrtree) +;; (`((,pprefix . ,pptree)) +;; `((,(concat prefix pprefix) . ,pptree) . ,nrtree)) +;; (nptree `((,prefix . ,nptree) . ,nrtree))) +;; (let ((n (if (< cmp 0) (- -1 cmp) (- cmp 1)))) +;; (cond +;; ((equal (+ n i) (length string)) +;; `((,prefix . ,ptree) . ,nrtree)) +;; (t nrtree)))))) +;; (val val)))) + +(defun radix-tree--prefixes (tree string i prefixes) + (pcase tree + (`((,prefix . ,ptree) . ,rtree) + (let* ((ni (+ i (length prefix))) + (cmp (compare-strings prefix nil nil string i ni)) + ;; FIXME: We could compute prefixes more efficiently + ;; whenever cmp is not -1 or 1. + (prefixes (radix-tree--prefixes rtree string i prefixes))) + (if (eq t cmp) + (radix-tree--prefixes ptree string ni prefixes) + prefixes))) + (val + (if (null val) + prefixes + (cons (cons (substring string 0 i) + (if (eq (car-safe val) t) (cdr val) val)) + prefixes))))) + +(defun radix-tree--subtree (tree string i) + (if (equal (length string) i) tree + (pcase tree + (`((,prefix . ,ptree) . ,rtree) + (let* ((ni (+ i (length prefix))) + (cmp (compare-strings prefix nil nil string i ni))) + (if (eq t cmp) + (radix-tree--subtree ptree string ni) + (let ((n (if (< cmp 0) (- -1 cmp) (- cmp 1)))) + (cond + ((zerop n) (radix-tree--subtree rtree string i)) + ((equal (+ n i) (length string)) + (let ((nprefix (substring prefix n))) + `((,nprefix . ,ptree)))) + (t nil)))))) + (_ nil)))) + +;;; Entry points + +(defconst radix-tree-empty nil + "The empty radix-tree.") + +(defun radix-tree-insert (tree key val) + "Insert a mapping from KEY to VAL in radix TREE." + (when (consp val) (setq val `(t . ,val))) + (if val (radix-tree--insert tree key val 0) + (radix-tree--remove tree key 0))) + +(defun radix-tree-lookup (tree key) + "Return the value associated to KEY in radix TREE. +If not found, return nil." + (pcase (radix-tree--lookup tree key 0) + (`(t . ,val) val) + ((pred numberp) nil) + (val val))) + +(defun radix-tree-subtree (tree string) + "Return the subtree of TREE rooted at the prefix STRING." + (radix-tree--subtree tree string 0)) + +;; (defun radix-tree-trim (tree string) +;; "Return a TREE which only holds entries \"related\" to STRING. +;; \"Related\" is here defined as entries where there's a `string-prefix-p' relation +;; between STRING and the key." +;; (radix-tree-trim tree string 0)) + +(defun radix-tree-prefixes (tree string) + "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) + ;; 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)))) + +(defun radix-tree-iter-subtrees (tree fun) + "Apply FUN to every immediate subtree of radix TREE. +FUN is called with two arguments: PREFIX and SUBTREE. +You can test if SUBTREE is a leaf (and extract its value) with the +pcase pattern (radix-tree-leaf PAT)." + (while tree + (pcase tree + (`((,prefix . ,ptree) . ,rtree) + (funcall fun prefix ptree) + (setq tree rtree)) + (_ (funcall fun "" tree) + (setq tree nil))))) + +(defun radix-tree-iter-mappings (tree fun &optional prefix) + "Apply FUN to every mapping in TREE. +FUN is called with two arguments: KEY and VAL. +PREFIX is only used internally." + (radix-tree-iter-subtrees + tree + (lambda (p s) + (let ((nprefix (concat prefix p))) + (pcase s + ((radix-tree-leaf v) (funcall fun nprefix v)) + (_ (radix-tree-iter-mappings s fun nprefix))))))) + +;; (defun radix-tree->alist (tree) +;; (let ((al nil)) +;; (radix-tree-iter-mappings tree (lambda (p v) (push (cons p v) al))) +;; al)) + +(defun radix-tree-count (tree) + (let ((i 0)) + (radix-tree-iter-mappings tree (lambda (_k _v) (setq i (1+ i)))) + i)) + +(defun radix-tree-from-map (map) + ;; Aka (cl-defmethod map-into (map (type (eql radix-tree)))) ...) + (require 'map) + (let ((rt nil)) + (map-apply (lambda (k v) (setq rt (radix-tree-insert rt k v))) map) + rt)) + +(provide 'radix-tree) +;;; radix-tree.el ends here diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 8362ddafd3f..e5004f8cdab 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.3 +;; Version: 2.18 ;; Package: seq ;; Maintainer: emacs-devel@gnu.org @@ -117,6 +117,16 @@ Return SEQUENCE." (defalias 'seq-each #'seq-do) +(defun seq-do-indexed (function sequence) + "Apply FUNCTION to each element of SEQUENCE and return nil. +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))) + (cl-defgeneric seqp (sequence) "Return non-nil if SEQUENCE is a sequence, nil otherwise." (sequencep sequence)) @@ -144,6 +154,18 @@ if positive or too small if negative)." sequence) (nreverse result))) +(defun seq-map-indexed (function sequence) + "Return the result of applying FUNCTION to each element of SEQUENCE. +Unlike `seq-map', FUNCTION takes two arguments: the element of +the sequence, and its index within the sequence." + (let ((index 0)) + (seq-map (lambda (elt) + (prog1 + (funcall function elt index) + (setq index (1+ index)))) + sequence))) + + ;; faster implementation for sequences (sequencep) (cl-defmethod seq-map (function (sequence sequence)) (mapcar function sequence)) @@ -206,6 +228,16 @@ The result is a sequence of the same type as SEQUENCE." (cl-defmethod seq-sort (pred (list list)) (sort (seq-copy list) pred)) +(defun seq-sort-by (function pred sequence) + "Sort SEQUENCE using PRED as a comparison function. +Elements of SEQUENCE are transformed by FUNCTION before being +sorted. FUNCTION must be a function of one argument." + (seq-sort (lambda (a b) + (funcall pred + (funcall function a) + (funcall function b))) + sequence)) + (cl-defgeneric seq-reverse (sequence) "Return a sequence with elements of SEQUENCE in reverse order." (let ((result '())) @@ -317,7 +349,8 @@ found or not." "Return the first element in SEQUENCE that is equal to ELT. Equality is defined by TESTFN if non-nil or by `equal' if nil." (seq-some (lambda (e) - (funcall (or testfn #'equal) elt e)) + (when (funcall (or testfn #'equal) elt e) + e)) sequence)) (cl-defgeneric seq-position (sequence elt &optional testfn) @@ -449,10 +482,7 @@ If no element is found, return nil." (cl-defmethod seq-drop ((list list) n) "Optimized implementation of `seq-drop' for lists." - (while (and list (> n 0)) - (setq list (cdr list) - n (1- n))) - list) + (nthcdr n list)) (cl-defmethod seq-take ((list list) n) "Optimized implementation of `seq-take' for lists." diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index e8d1939865f..173cd11fba4 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -198,6 +198,171 @@ to bind a single value, BINDINGS can just be a plain tuple." (substring string 0 (- (length string) (length suffix))) string)) +(defun read-multiple-choice (prompt choices) + "Ask user a multiple choice question. +PROMPT should be a string that will be displayed as the prompt. + +CHOICES is an alist where the first element in each entry is a +character to be entered, the second element is a short name for +the entry to be displayed while prompting (if there's room, it +might be shortened), and the third, optional entry is a longer +explanation that will be displayed in a help buffer if the user +requests more help. + +This function translates user input into responses by consulting +the bindings in `query-replace-map'; see the documentation of +that variable for more information. In this case, the useful +bindings are `recenter', `scroll-up', and `scroll-down'. If the +user enters `recenter', `scroll-up', or `scroll-down' responses, +perform the requested window recentering or scrolling and ask +again. + +The return value is the matching entry from the CHOICES list. + +Usage example: + +\(read-multiple-choice \"Continue connecting?\" + '((?a \"always\") + (?s \"session only\") + (?n \"no\")))" + (let* ((altered-names nil) + (full-prompt + (format + "%s (%s): " + prompt + (mapconcat + (lambda (elem) + (let* ((name (cadr elem)) + (pos (seq-position name (car elem))) + (altered-name + (cond + ;; Not in the name string. + ((not pos) + (format "[%c] %s" (car elem) name)) + ;; The prompt character is in the name, so highlight + ;; it on graphical terminals... + ((display-supports-face-attributes-p + '(:underline t) (window-frame)) + (setq name (copy-sequence name)) + (put-text-property pos (1+ pos) + 'face 'read-multiple-choice-face + name) + name) + ;; And put it in [bracket] on non-graphical terminals. + (t + (concat + (substring name 0 pos) + "[" + (upcase (substring name pos (1+ pos))) + "]" + (substring name (1+ pos))))))) + (push (cons (car elem) altered-name) + altered-names) + altered-name)) + (append choices '((?? "?"))) + ", "))) + tchar buf wrong-char answer) + (save-window-excursion + (save-excursion + (while (not tchar) + (message "%s%s" + (if wrong-char + "Invalid choice. " + "") + full-prompt) + (setq tchar + (if (and (display-popup-menus-p) + last-input-event ; not during startup + (listp last-nonmenu-event) + use-dialog-box) + (x-popup-dialog + t + (cons prompt + (mapcar + (lambda (elem) + (cons (capitalize (cadr elem)) + (car elem))) + choices))) + (condition-case nil + (let ((cursor-in-echo-area t)) + (read-char)) + (error nil)))) + (setq answer (lookup-key query-replace-map (vector tchar) t)) + (setq tchar + (cond + ((eq answer 'recenter) + (recenter) t) + ((eq answer 'scroll-up) + (ignore-errors (scroll-up-command)) t) + ((eq answer 'scroll-down) + (ignore-errors (scroll-down-command)) t) + ((eq answer 'scroll-other-window) + (ignore-errors (scroll-other-window)) t) + ((eq answer 'scroll-other-window-down) + (ignore-errors (scroll-other-window-down)) t) + (t tchar))) + (when (eq tchar t) + (setq wrong-char nil + tchar nil)) + ;; The user has entered an invalid choice, so display the + ;; help messages. + (when (and (not (eq tchar nil)) + (not (assq tchar choices))) + (setq wrong-char (not (memq tchar '(?? ?\C-h))) + tchar nil) + (when wrong-char + (ding)) + (with-help-window (setq buf (get-buffer-create + "*Multiple Choice Help*")) + (with-current-buffer buf + (erase-buffer) + (pop-to-buffer buf) + (insert prompt "\n\n") + (let* ((columns (/ (window-width) 25)) + (fill-column 21) + (times 0) + (start (point))) + (dolist (elem choices) + (goto-char start) + (unless (zerop times) + (if (zerop (mod times columns)) + ;; Go to the next "line". + (goto-char (setq start (point-max))) + ;; Add padding. + (while (not (eobp)) + (end-of-line) + (insert (make-string (max (- (* (mod times columns) + (+ fill-column 4)) + (current-column)) + 0) + ?\s)) + (forward-line 1)))) + (setq times (1+ times)) + (let ((text + (with-temp-buffer + (insert (format + "%c: %s\n" + (car elem) + (cdr (assq (car elem) altered-names)))) + (fill-region (point-min) (point-max)) + (when (nth 2 elem) + (let ((start (point))) + (insert (nth 2 elem)) + (unless (bolp) + (insert "\n")) + (fill-region start (point-max)))) + (buffer-string)))) + (goto-char start) + (dolist (line (split-string text "\n")) + (end-of-line) + (if (bolp) + (insert line "\n") + (insert line)) + (forward-line 1))))))))))) + (when (buffer-live-p buf) + (kill-buffer buf)) + (assq tchar choices))) + (provide 'subr-x) ;;; subr-x.el ends here diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el index 654f234fa62..ac509b3465d 100644 --- a/lisp/emacs-lisp/syntax.el +++ b/lisp/emacs-lisp/syntax.el @@ -316,6 +316,9 @@ END) suitable for `syntax-propertize-function'." (unless (eq funs (cdr syntax-propertize-extend-region-functions)) (setq funs syntax-propertize-extend-region-functions))))) + ;; Flush ppss cache between the original value of `start' and that + ;; set above by syntax-propertize-extend-region-functions. + (syntax-ppss-flush-cache start) ;; Move the limit before calling the function, so the function ;; can use syntax-ppss. (setq syntax-propertize--done end) @@ -417,6 +420,9 @@ point (where the PPSS is equivalent to nil).") (error nil))) syntax-ppss-stats)) +(defvar-local syntax-ppss-table nil + "Syntax-table to use during `syntax-ppss', if any.") + (defun syntax-ppss (&optional pos) "Parse-Partial-Sexp State at POS, defaulting to point. The returned value is the same as that of `parse-partial-sexp' @@ -432,6 +438,7 @@ running the hook." (unless pos (setq pos (point))) (syntax-propertize pos) ;; + (with-syntax-table (or syntax-ppss-table (syntax-table)) (let ((old-ppss (cdr syntax-ppss-last)) (old-pos (car syntax-ppss-last)) (ppss nil) @@ -568,7 +575,7 @@ running the hook." ;; we may end up calling parse-partial-sexp with a position before ;; point-min. In that case, just parse from point-min assuming ;; a nil state. - (parse-partial-sexp (point-min) pos))))) + (parse-partial-sexp (point-min) pos)))))) ;; Debugging functions diff --git a/lisp/emacs-lisp/timer-list.el b/lisp/emacs-lisp/timer-list.el new file mode 100644 index 00000000000..9b13e52dd7c --- /dev/null +++ b/lisp/emacs-lisp/timer-list.el @@ -0,0 +1,112 @@ +;;; timer-list.el --- list active timers in a buffer + +;; Copyright (C) 2016 Free Software Foundation, Inc. + +;; Maintainer: emacs-devel@gnu.org +;; 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 <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +;;;###autoload +(defun timer-list (&optional _ignore-auto _nonconfirm) + "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 (float-time (list (aref timer 1) + (aref timer 2) + (aref timer 3))))) + (format "%.2f" + (if (aref timer 7) + time + (- (float-time (list (aref timer 1) + (aref timer 2) + (aref timer 3))) + (float-time))))) + ;; Repeat. + (let ((repeat (aref timer 4))) + (cond + ((numberp repeat) + (format "%.2f" (/ repeat 60))) + ((null repeat) + "-") + (t + (format "%s" repeat)))) + ;; Function. + (let ((function (aref timer 5))) + (replace-regexp-in-string + "\n" " " + (cond + ((byte-code-function-p function) + (replace-regexp-in-string + "[^-A-Za-z0-9 ]" "" + (format "%s" function))) + (t + (format "%s" function))))))) + (put-text-property (line-beginning-position) + (1+ (line-beginning-position)) + 'timer timer) + (insert "\n"))) + (goto-char (point-min))) +;; This command can be destructive if they don't know what they are +;; doing. Kids, don't try this at home! +;;;###autoload (put 'timer-list 'disabled "Beware: manually canceling timers can ruin your Emacs session.") + +(defvar timer-list-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "c" 'timer-list-cancel) + (easy-menu-define nil map "" + '("Timers" + ["Cancel" timer-list-cancel t])) + map)) + +(define-derived-mode timer-list-mode special-mode "timer-list" + "Mode for listing and controlling timers." + (setq truncate-lines t) + (buffer-disable-undo) + (setq-local revert-buffer-function 'timer-list) + (setq buffer-read-only t) + (setq header-line-format + (format "%4s %10s %8s %s" + "Idle" "Next" "Repeat" "Function"))) + +(defun timer-list-cancel () + "Cancel the timer on the line under point." + (interactive) + (let ((timer (get-text-property (line-beginning-position) 'timer)) + (inhibit-read-only t)) + (unless timer + (error "No timer on the current line")) + (cancel-timer timer) + (delete-region (line-beginning-position) + (line-beginning-position 2)))) + +(provide 'timer-list) + +;;; timer-list.el ends here |