diff options
Diffstat (limited to 'lisp/emacs-lisp')
56 files changed, 2915 insertions, 1264 deletions
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 6c49928aee8..3342bea209a 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. @@ -2830,7 +2830,7 @@ advised definition from scratch." (ad-get-cache-id function)))) (ad-set-advice-info function old-advice-info) (advice-remove function advicefunname) - (fset advicefunname old-advice) + (if advicefunname (fset advicefunname old-advice)) (if old-advice (advice-add function :around advicefunname))))) diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index 0f5c04b0ae4..d1f3c359f37 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) @@ -141,7 +164,7 @@ expression, in which case we want to handle forms differently." ((and (memq car '(easy-mmode-define-global-mode define-global-minor-mode define-globalized-minor-mode defun defmacro easy-mmode-define-minor-mode define-minor-mode - define-inline cl-defun cl-defmacro)) + define-inline cl-defun cl-defmacro cl-defgeneric)) (macrop car) (setq expand (let ((load-file-name file)) (macroexpand form))) (memq (car expand) '(progn prog1 defalias))) @@ -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)) + ((= (following-char) ?\;) + ;; Don't read the comment. + (forward-line 1)) + (t + ;; Avoid (defvar <foo>) by requiring a trailing space. + ;; Also, ignore this prefix business + ;; for ;;;###tramp-autoload and friends. + (when (and (equal generate-autoload-cookie ";;;###autoload") + (looking-at "(\\(def[^ ]+\\) ['(]*\\([^' ()\"\n]+\\)[\n \t]") + (not (member + (match-string 1) + '("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)))) @@ -773,12 +1019,13 @@ write its autoloads into the specified file instead." (unless (string-match "\\.\\(elc\\|\\so\\|dll\\)" 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. @@ -787,13 +1034,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) @@ -805,28 +1055,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. @@ -838,7 +1093,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. @@ -846,7 +1100,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. @@ -855,11 +1110,18 @@ 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. + (if (not changed) + (set-buffer-modified-p nil) + (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)))) @@ -891,7 +1153,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/avl-tree.el b/lisp/emacs-lisp/avl-tree.el index 66fe9796623..17f1ffa9f61 100644 --- a/lisp/emacs-lisp/avl-tree.el +++ b/lisp/emacs-lisp/avl-tree.el @@ -98,7 +98,8 @@ ;; avl-tree-right avl-tree-data] branch) node) "Get value of a branch of a node. NODE is the node, and BRANCH is the branch. -0 for left pointer, 1 for right pointer and 2 for the data.") +0 for left pointer, 1 for right pointer and 2 for the data. +\n(fn BRANCH NODE)") ;; The funcall/aref trick wouldn't work for the setf method, unless we @@ -400,7 +401,8 @@ itself." reverse store) (defalias 'avl-tree-stack-p #'avl-tree--stack-p - "Return t if argument is an avl-tree-stack, nil otherwise.") + "Return t if OBJ is an avl-tree-stack, nil otherwise. +\n(fn OBJ)") (defun avl-tree--stack-repopulate (stack) ;; Recursively push children of the node at the head of STACK onto the @@ -419,12 +421,12 @@ itself." (defalias 'avl-tree-create #'avl-tree--create "Create an empty AVL tree. COMPARE-FUNCTION is a function which takes two arguments, A and B, -and returns non-nil if A is less than B, and nil otherwise.") +and returns non-nil if A is less than B, and nil otherwise. +\n(fn COMPARE-FUNCTION)") (defalias 'avl-tree-compare-function #'avl-tree--cmpfun "Return the comparison function for the AVL tree TREE. - -\(fn TREE)") +\n(fn TREE)") (defun avl-tree-empty (tree) "Return t if AVL tree TREE is empty, otherwise return nil." diff --git a/lisp/emacs-lisp/backquote.el b/lisp/emacs-lisp/backquote.el index 94c561cba0a..bb877dd2c97 100644 --- a/lisp/emacs-lisp/backquote.el +++ b/lisp/emacs-lisp/backquote.el @@ -247,4 +247,14 @@ LEVEL is only used internally and indicates the nesting level: tail)) (t (cons 'list heads))))) + +;; Give `,' and `,@' documentation strings which can be examined by C-h f. +(put '\, 'function-documentation + "See `\\=`' (also `pcase') for the usage of `,'.") +(put '\, 'reader-construct t) + +(put '\,@ 'function-documentation + "See `\\=`' for the usage of `,@'.") +(put '\,@ 'reader-construct t) + ;;; backquote.el ends here diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el index 25eddf5f6b0..a2217d20953 100644 --- a/lisp/emacs-lisp/benchmark.el +++ b/lisp/emacs-lisp/benchmark.el @@ -1,4 +1,4 @@ -;;; benchmark.el --- support for benchmarking code +;;; benchmark.el --- support for benchmarking code -*- lexical-binding: t -*- ;; Copyright (C) 2003-2017 Free Software Foundation, Inc. @@ -33,6 +33,7 @@ (defmacro benchmark-elapse (&rest forms) "Return the time in seconds elapsed for execution of FORMS." + (declare (indent 0) (debug t)) (let ((t1 (make-symbol "t1")) (t2 (make-symbol "t2"))) `(let (,t1 ,t2) @@ -41,9 +42,6 @@ (setq ,t2 (current-time)) (float-time (time-subtract ,t2 ,t1))))) -(put 'benchmark-elapse 'edebug-form-spec t) -(put 'benchmark-elapse 'lisp-indent-function 0) - ;;;###autoload (defmacro benchmark-run (&optional repetitions &rest forms) "Time execution of FORMS. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index eac59ecde8b..004f2e28653 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -185,6 +185,7 @@ (require 'bytecomp) (eval-when-compile (require 'cl-lib)) (require 'macroexp) +(require 'subr-x) (defun byte-compile-log-lap-1 (format &rest args) ;; Newer byte codes for stack-ref make the slot 0 non-nil again. @@ -288,8 +289,8 @@ (if (eq (car-safe newfn) 'function) (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form))) ;; This can happen because of macroexp-warn-and-return &co. - (byte-compile-log-warning - (format "Inlining closure %S failed" name)) + (byte-compile-warn + "Inlining closure %S failed" name) form)))) (_ ;; Give up on inlining. @@ -1209,8 +1210,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 @@ -1355,7 +1357,7 @@ (defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable) (let ((length (length bytes)) (bytedecomp-ptr 0) optr tags bytedecomp-op offset - lap tmp) + lap tmp last-constant) (while (not (= bytedecomp-ptr length)) (or make-spliceable (push bytedecomp-ptr lap)) @@ -1384,7 +1386,8 @@ (or (assq tmp byte-compile-variables) (let ((new (list tmp))) (push new byte-compile-variables) - new))))) + new))) + last-constant tmp)) ((eq bytedecomp-op 'byte-stack-set2) (setq bytedecomp-op 'byte-stack-set)) ((and (eq bytedecomp-op 'byte-discardN) (>= offset #x80)) @@ -1393,7 +1396,34 @@ ;; lapcode, we represent this by using a different opcode ;; (with the flag removed from the operand). (setq bytedecomp-op 'byte-discardN-preserve-tos) - (setq offset (- offset #x80)))) + (setq offset (- offset #x80))) + ((eq bytedecomp-op 'byte-switch) + (cl-assert (hash-table-p last-constant) nil + "byte-switch used without preceeding hash table") + ;; We cannot use the original hash table referenced in the op, + ;; so we create a copy of it, and replace the addresses with + ;; TAGs. + (let ((orig-table last-constant)) + (cl-loop for e across constvec + when (eq e last-constant) + do (setq last-constant (copy-hash-table e)) + and return nil) + ;; Replace all addresses with TAGs. + (maphash #'(lambda (value tag) + (let (newtag) + (setq newtag (byte-compile-make-tag)) + (push (cons tag newtag) tags) + (puthash value newtag last-constant))) + last-constant) + ;; Replace the hash table referenced in the lapcode with our + ;; modified one. + (cl-loop for el in-ref lap + when (and (listp el) ;; make sure we're at the correct op + (eq (nth 1 el) 'byte-constant) + (eq (nth 2 el) orig-table)) + ;; Jump tables are never reused, so do this exactly + ;; once. + do (setf (nth 2 el) last-constant) and return nil)))) ;; lap = ( [ (pc . (op . arg)) ]* ) (push (cons optr (cons bytedecomp-op (or offset 0))) lap) @@ -1722,12 +1752,25 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (setcdr tmp2 lap1) (setq tmp3 (cdr (memq tmp2 tmp3)))) (setq lap (delq lap0 lap) - keep-going t)) + keep-going t) + ;; replace references to tag in jump tables, if any + (dolist (table byte-compile-jump-tables) + (catch 'break + (maphash #'(lambda (value tag) + (when (equal tag lap0) + ;; each tag occurs only once in the jump table + (puthash value lap1 table) + (throw 'break nil))) + table)))) ;; ;; unused-TAG: --> <deleted> ;; ((and (eq 'TAG (car lap0)) - (not (rassq lap0 lap))) + (not (rassq lap0 lap)) + ;; make sure this tag isn't used in a jump-table + (cl-loop for table in byte-compile-jump-tables + when (member lap0 (hash-table-values table)) + return nil finally return t)) (and (memq byte-optimize-log '(t byte)) (byte-compile-log " unused tag %d removed" (nth 1 lap0))) (setq lap (delq lap0 lap) @@ -1735,9 +1778,15 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; ;; goto ... --> goto <delete until TAG or end> ;; return ... --> return <delete until TAG or end> - ;; + ;; (unless a jump-table is being used, where deleting may affect + ;; other valid case bodies) + ;; ((and (memq (car lap0) '(byte-goto byte-return)) - (not (memq (car lap1) '(TAG nil)))) + (not (memq (car lap1) '(TAG nil))) + ;; FIXME: Instead of deferring simply when jump-tables are + ;; being used, keep a list of tags used for switch tags and + ;; use them instead (see `byte-compile-inline-lapcode'). + (not byte-compile-jump-tables)) (setq tmp rest) (let ((i 0) (opt-p (memq byte-optimize-log '(t lap))) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index de6755a41c7..4fa31dd4c27 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -240,6 +240,11 @@ The return value is undefined. ;; from ;; (defun foo (arg) (toto)). (declare (doc-string 3) (indent 2)) + (or name (error "Cannot define '%s' as a function" name)) + (if (null + (and (listp arglist) + (null (delq t (mapcar #'symbolp arglist))))) + (error "Malformed arglist: %s" arglist)) (let ((decls (cond ((eq (car-safe docstring) 'declare) (prog1 (cdr docstring) (setq docstring nil))) @@ -469,7 +474,7 @@ load time. In interpreted code, this is entirely equivalent to `progn', except that the value of the expression may be (but is not necessarily) computed at load time if eager macro expansion is enabled." - (declare (debug t) (indent 0)) + (declare (debug (&rest def-form)) (indent 0)) ;; When the byte-compiler expands code, this macro is not used, so we're ;; either about to run `body' (plain interpretation) or we're doing eager ;; macroexpansion. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index eb3f46d3d7a..7cbef8e4340 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -223,6 +223,11 @@ This includes variable references and calls to functions such as `car'." :group 'bytecomp :type 'boolean) +(defcustom byte-compile-cond-use-jump-table t + "Compile `cond' clauses to a jump table implementation (using a hash-table)." + :group 'bytecomp + :type 'boolean) + (defvar byte-compile-dynamic nil "If non-nil, compile function bodies so they load lazily. They are hidden in comments in the compiled file, @@ -412,6 +417,8 @@ specify different fields to sort on." (const calls+callers) (const nil))) (defvar byte-compile-debug nil) +(defvar byte-compile-jump-tables nil + "List of all jump tables used during compilation of this form.") (defvar byte-compile-constants nil "List of all constants encountered during compilation of this form.") (defvar byte-compile-variables nil @@ -747,6 +754,10 @@ otherwise pop it") ;; `byte-compile-lapcode'). (defconst byte-discardN-preserve-tos byte-discardN) +(byte-defop 183 -2 byte-switch + "to take a hash table and a value from the stack, and jump to the address +the value maps to, if any.") + ;; unused: 182-191 (byte-defop 192 1 byte-constant "for reference to a constant") @@ -823,7 +834,7 @@ CONST2 may be evaluated multiple times." op off ; Operation & offset opcode ; numeric value of OP (bytes '()) ; Put the output bytes here - (patchlist nil)) ; List of gotos to patch + (patchlist nil)) ; List of gotos to patch (dolist (lap-entry lap) (setq op (car lap-entry) off (cdr lap-entry)) @@ -900,11 +911,22 @@ CONST2 may be evaluated multiple times." ;; Patch tag PCs into absolute jumps. (dolist (bytes-tail patchlist) (setq pc (caar bytes-tail)) ; Pick PC from goto's tag. + ;; Splits PC's value into 2 bytes. The jump address is + ;; "reconstructed" by the `FETCH2' macro in `bytecode.c'. (setcar (cdr bytes-tail) (logand pc 255)) (setcar bytes-tail (lsh pc -8)) ;; FIXME: Replace this by some workaround. (if (> (car bytes-tail) 255) (error "Bytecode overflow"))) + ;; Similarly, replace TAGs in all jump tables with the correct PC index. + (dolist (hash-table byte-compile-jump-tables) + (maphash #'(lambda (value tag) + (setq pc (cadr tag)) + ;; We don't need to split PC here, as it is stored as a lisp + ;; object in the hash table (whereas other goto-* ops store + ;; it within 2 bytes in the byte string). + (puthash value pc hash-table)) + hash-table)) (apply 'unibyte-string (nreverse bytes)))) @@ -1022,39 +1044,42 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (setcdr list (cddr list))) total))) -;; The purpose of this function is to iterate through the -;; `read-symbol-positions-list'. Each time we process, say, a -;; function definition (`defun') we remove `defun' from -;; `read-symbol-positions-list', and set `byte-compile-last-position' -;; to that symbol's character position. Similarly, if we encounter a -;; variable reference, like in (1+ foo), we remove `foo' from the -;; list. If our current position is after the symbol's position, we -;; assume we've already passed that point, and look for the next -;; occurrence of the symbol. +;; The purpose of `byte-compile-set-symbol-position' is to attempt to +;; set `byte-compile-last-position' to the "current position" in the +;; raw source code. This is used for warning and error messages. ;; -;; This function should not be called twice for the same occurrence of -;; a symbol, and it should not be called for symbols generated by the -;; byte compiler itself; because rather than just fail looking up the -;; symbol, we may find an occurrence of the symbol further ahead, and -;; then `byte-compile-last-position' as advanced too far. +;; The function should be called for most occurrences of symbols in +;; the forms being compiled, strictly in the order they occur in the +;; source code. It should never be called twice for any single +;; occurrence, and should not be called for symbols generated by the +;; byte compiler itself. ;; -;; So your're probably asking yourself: Isn't this function a -;; gross hack? And the answer, of course, would be yes. +;; The function works by scanning the elements in the alist +;; `read-symbol-positions-list' for the next match for the symbol +;; after the current value of `byte-compile-last-position', setting +;; that variable to the match's character position, then deleting the +;; matching element from the list. Thus the new value for +;; `byte-compile-last-position' is later than the old value unless, +;; perhaps, ALLOW-PREVIOUS is non-nil. +;; +;; So your're probably asking yourself: Isn't this function a gross +;; hack? And the answer, of course, would be yes. (defun byte-compile-set-symbol-position (sym &optional allow-previous) (when byte-compile-read-position - (let (last entry) + (let ((last byte-compile-last-position) + entry) (while (progn - (setq last byte-compile-last-position - entry (assq sym read-symbol-positions-list)) + (setq entry (assq sym read-symbol-positions-list)) (when entry (setq byte-compile-last-position (+ byte-compile-read-position (cdr entry)) read-symbol-positions-list (byte-compile-delete-first entry read-symbol-positions-list))) - (or (and allow-previous - (not (= last byte-compile-last-position))) - (> last byte-compile-last-position))))))) + (and entry + (or (and allow-previous + (not (= last byte-compile-last-position))) + (> last byte-compile-last-position)))))))) (defvar byte-compile-last-warned-form nil) (defvar byte-compile-last-logged-file nil) @@ -1160,9 +1185,13 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (compilation-forget-errors) pt)))) -;; Log a message STRING in `byte-compile-log-buffer'. -;; Also log the current function and file if not already done. (defun byte-compile-log-warning (string &optional fill level) + "Log a message STRING in `byte-compile-log-buffer'. +Also log the current function and file if not already done. If +FILL is non-nil, set `warning-fill-prefix' to four spaces. LEVEL +is the warning level (`:warning' or `:error'). Do not call this +function directly; use `byte-compile-warn' or +`byte-compile-report-error' instead." (let ((warning-prefix-function 'byte-compile-warning-prefix) (warning-type-format "") (warning-fill-prefix (if fill " "))) @@ -1186,15 +1215,16 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (unless (and funcp (memq symbol byte-compile-not-obsolete-funcs)) (byte-compile-warn "%s" msg))))) -(defun byte-compile-report-error (error-info) +(defun byte-compile-report-error (error-info &optional fill) "Report Lisp error in compilation. ERROR-INFO is the error data, in the form of either (ERROR-SYMBOL . DATA) -or STRING." +or STRING. If FILL is non-nil, set ‘warning-fill-prefix’ to four spaces +when printing the error message." (setq byte-compiler-error-flag t) (byte-compile-log-warning (if (stringp error-info) error-info (error-message-string error-info)) - nil :error)) + fill :error)) ;;; sanity-checking arglists @@ -1279,6 +1309,7 @@ or STRING." (t (format "%d-%d" (car signature) (cdr signature))))) (defun byte-compile-function-warn (f nargs def) + (byte-compile-set-symbol-position f) (when (get f 'byte-obsolete-info) (byte-compile-warn-obsolete f)) @@ -1360,31 +1391,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. @@ -1881,12 +1914,13 @@ The value is non-nil if there were no errors, nil if errors." (rename-file tempfile target-file t) (or noninteractive (message "Wrote %s" target-file))) ;; This is just to give a better error message than write-region - (signal 'file-error - (list "Opening output file" - (if (file-exists-p target-file) - "Cannot overwrite file" - "Directory not writable or nonexistent") - target-file))) + (let ((exists (file-exists-p target-file))) + (signal (if exists 'file-error 'file-missing) + (list "Opening output file" + (if exists + "Cannot overwrite file" + "Directory not writable or nonexistent") + target-file)))) (kill-buffer (current-buffer))) (if (and byte-compile-generate-call-tree (or (eq t byte-compile-generate-call-tree) @@ -1942,7 +1976,8 @@ With argument ARG, insert value in current buffer after the form." ;; (edebug-all-defs nil) ;; (edebug-all-forms nil) ;; Simulate entry to byte-compile-top-level - (byte-compile-constants nil) + (byte-compile-jump-tables nil) + (byte-compile-constants nil) (byte-compile-variables nil) (byte-compile-tag-number 0) (byte-compile-depth 0) @@ -1983,7 +2018,7 @@ With argument ARG, insert value in current buffer after the form." ;; Compile the forms from the input buffer. (while (progn (while (progn (skip-chars-forward " \t\n\^l") - (looking-at ";")) + (= (following-char) ?\;)) (forward-line 1)) (not (eobp))) (setq byte-compile-read-position (point) @@ -2238,7 +2273,8 @@ list that represents a doc string reference. byte-compile-variables nil byte-compile-depth 0 byte-compile-maxdepth 0 - byte-compile-output nil)))) + byte-compile-output nil + byte-compile-jump-tables nil)))) (defvar byte-compile-force-lexical-warnings nil) @@ -2580,7 +2616,13 @@ FUN should be either a `lambda' value or a `closure' value." (pcase-let* (((or (and `(lambda ,args . ,body) (let env nil)) `(closure ,env ,args . ,body)) fun) + (preamble nil) (renv ())) + ;; Split docstring and `interactive' form from body. + (when (stringp (car body)) + (push (pop body) preamble)) + (when (eq (car-safe (car body)) 'interactive) + (push (pop body) preamble)) ;; Turn the function's closed vars (if any) into local let bindings. (dolist (binding env) (cond @@ -2593,8 +2635,8 @@ FUN should be either a `lambda' value or a `closure' value." ((eq binding t)) (t (push `(defvar ,binding) body)))) (if (null renv) - `(lambda ,args ,@body) - `(lambda ,args (let ,(nreverse renv) ,@body))))) + `(lambda ,args ,@preamble ,@body) + `(lambda ,args ,@preamble (let ,(nreverse renv) ,@body))))) ;;;###autoload (defun byte-compile (form) @@ -2654,8 +2696,11 @@ If FORM is a lambda or a macro, byte-compile it as a function." (when (cddr list) (error "Garbage following &rest VAR in lambda-list"))) ((eq arg '&optional) - (unless (cdr list) - (error "Variable name missing after &optional"))) + (when (or (null (cdr list)) + (memq (cadr list) '(&optional &rest))) + (error "Variable name missing after &optional")) + (when (memq '&optional (cddr list)) + (error "Duplicate &optional"))) ((memq arg vars) (byte-compile-warn "repeated variable %s in lambda-list" arg)) (t @@ -2841,7 +2886,8 @@ for symbols generated by the byte compiler itself." (byte-compile-maxdepth 0) (byte-compile--lexical-environment lexenv) (byte-compile-reserved-constants (or reserved-csts 0)) - (byte-compile-output nil)) + (byte-compile-output nil) + (byte-compile-jump-tables nil)) (if (memq byte-optimize '(t source)) (setq form (byte-optimize-form form byte-compile--for-effect))) (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) @@ -2957,6 +3003,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 @@ -3015,9 +3063,8 @@ for symbols generated by the byte compiler itself." (pcase (cdr form) (`(',var . ,_) (when (assq var byte-compile-lexical-variables) - (byte-compile-log-warning - (format-message "%s cannot use lexical var `%s'" fn var) - nil :error))))) + (byte-compile-report-error + (format-message "%s cannot use lexical var `%s'" fn var)))))) (when (macroexp--const-symbol-p fn) (byte-compile-warn "`%s' called as a function" fn)) (when (and (byte-compile-warning-enabled-p 'interactive-only) @@ -3034,9 +3081,8 @@ for symbols generated by the byte compiler itself." interactive-only)) (t ".")))) (if (eq (car-safe (symbol-function (car form))) 'macro) - (byte-compile-log-warning - (format "Forgot to expand macro %s in %S" (car form) form) - nil :error)) + (byte-compile-report-error + (format "Forgot to expand macro %s in %S" (car form) form))) (if (and handler ;; Make sure that function exists. (and (functionp handler) @@ -3093,15 +3139,57 @@ for symbols generated by the byte compiler itself." ;; happens to be true for byte-code generated by bytecomp.el without ;; lexical-binding, but it's not true in general, and it's not true for ;; code output by bytecomp.el with lexical-binding. - (let ((endtag (byte-compile-make-tag))) + ;; We also restore the value of `byte-compile-depth' and remove TAG depths + ;; accordingly when inlining lapcode containing lap-code, exactly as + ;; documented in `byte-compile-cond-jump-table'. + (let ((endtag (byte-compile-make-tag)) + last-jump-tag ;; last TAG we have jumped to + last-depth ;; last value of `byte-compile-depth' + last-constant ;; value of the last constant encountered + last-switch ;; whether the last op encountered was byte-switch + switch-tags ;; a list of tags that byte-switch could jump to + ;; a list of tags byte-switch will jump to, if the value doesn't + ;; match any entry in the hash table + switch-default-tags) (dolist (op lap) (cond - ((eq (car op) 'TAG) (byte-compile-out-tag op)) - ((memq (car op) byte-goto-ops) (byte-compile-goto (car op) (cdr op))) + ((eq (car op) 'TAG) + (when (or (member op switch-tags) (member op switch-default-tags)) + ;; This TAG is used in a jump table, this means the last goto + ;; was to a done/default TAG, and thus it's cddr should be set to nil. + (when last-jump-tag + (setcdr (cdr last-jump-tag) nil)) + ;; Also, restore the value of `byte-compile-depth' to what it was + ;; before the last goto. + (setq byte-compile-depth last-depth + last-jump-tag nil)) + (byte-compile-out-tag op)) + ((memq (car op) byte-goto-ops) + (setq last-depth byte-compile-depth + last-jump-tag (cdr op)) + (byte-compile-goto (car op) (cdr op)) + (when last-switch + ;; The last op was byte-switch, this goto jumps to a "default" TAG + ;; (when no value in the jump table is satisfied). + (push (cdr op) switch-default-tags) + (setcdr (cdr (cdr op)) nil) + (setq byte-compile-depth last-depth + last-switch nil))) ((eq (car op) 'byte-return) (byte-compile-discard (- byte-compile-depth end-depth) t) (byte-compile-goto 'byte-goto endtag)) - (t (byte-compile-out (car op) (cdr op))))) + (t + (when (eq (car op) 'byte-switch) + ;; The last constant is a jump table. + (push last-constant byte-compile-jump-tables) + (setq last-switch t) + ;; Push all TAGs in the jump to switch-tags. + (maphash #'(lambda (_k tag) + (push tag switch-tags)) + last-constant)) + (setq last-constant (and (eq (car op) 'byte-constant) (cadr op))) + (setq last-depth byte-compile-depth) + (byte-compile-out (car op) (cdr op))))) (byte-compile-out-tag endtag))) (defun byte-compile-unfold-bcf (form) @@ -3133,9 +3221,8 @@ for symbols generated by the byte compiler itself." (dotimes (_ (- (/ (1+ fmax2) 2) alen)) (byte-compile-push-constant nil))) ((zerop (logand fmax2 1)) - (byte-compile-log-warning - (format "Too many arguments for inlined function %S" form) - nil :error) + (byte-compile-report-error + (format "Too many arguments for inlined function %S" form)) (byte-compile-discard (- alen (/ fmax2 2)))) (t ;; Turn &rest args into a list. @@ -3745,10 +3832,9 @@ discarding." (len (length args))) (if (= (logand len 1) 1) (progn - (byte-compile-log-warning + (byte-compile-report-error (format-message - "missing value for `%S' at end of setq" (car (last args))) - nil :error) + "missing value for `%S' at end of setq" (car (last args)))) (byte-compile-form `(signal 'wrong-number-of-arguments '(setq ,len)) byte-compile--for-effect)) @@ -3932,37 +4018,164 @@ that suppresses all warnings during execution of BODY." (byte-compile-out-tag donetag)))) (setq byte-compile--for-effect nil)) +(defun byte-compile-cond-vars (obj1 obj2) + ;; We make sure that of OBJ1 and OBJ2, one of them is a symbol, + ;; and the other is a constant expression whose value can be + ;; compared with `eq' (with `macroexp-const-p'). + (or + (and (symbolp obj1) (macroexp-const-p obj2) (cons obj1 obj2)) + (and (symbolp obj2) (macroexp-const-p obj1) (cons obj2 obj1)))) + +(defun byte-compile-cond-jump-table-info (clauses) + "If CLAUSES is a `cond' form where: +The condition for each clause is of the form (TEST VAR VALUE). +VAR is a variable. +TEST and VAR are the same throughout all conditions. +VALUE satisfies `macroexp-const-p'. + +Return a list of the form ((TEST . VAR) ((VALUE BODY) ...))" + (let ((cases '()) + (ok t) + prev-var prev-test) + (and (catch 'break + (dolist (clause (cdr clauses) ok) + (let* ((condition (car clause)) + (test (car-safe condition)) + (vars (when (consp condition) + (byte-compile-cond-vars (cadr condition) (cl-caddr condition)))) + (obj1 (car-safe vars)) + (obj2 (cdr-safe vars)) + (body (cdr-safe clause))) + (unless prev-var + (setq prev-var obj1)) + (unless prev-test + (setq prev-test test)) + (if (and obj1 (memq test '(eq eql equal)) + (consp condition) + (eq test prev-test) + (eq obj1 prev-var) + ;; discard duplicate clauses + (not (assq obj2 cases))) + (push (list (if (consp obj2) (eval obj2) obj2) body) cases) + (if (eq condition t) + (progn (push (list 'default body) cases) + (throw 'break t)) + (setq ok nil) + (throw 'break nil)))))) + (list (cons prev-test prev-var) (nreverse cases))))) + +(defun byte-compile-cond-jump-table (clauses) + (let* ((table-info (byte-compile-cond-jump-table-info clauses)) + (test (caar table-info)) + (var (cdar table-info)) + (cases (cadr table-info)) + jump-table test-obj body tag donetag default-tag default-case) + (when (and cases (not (= (length cases) 1))) + ;; TODO: Once :linear-search is implemented for `make-hash-table' + ;; set it to `t' for cond forms with a small number of cases. + (setq jump-table (make-hash-table :test test + :purecopy t + :size (if (assq 'default cases) + (1- (length cases)) + (length cases))) + default-tag (byte-compile-make-tag) + donetag (byte-compile-make-tag)) + ;; The structure of byte-switch code: + ;; + ;; varref var + ;; constant #s(hash-table purecopy t data (val1 (TAG1) val2 (TAG2))) + ;; switch + ;; goto DEFAULT-TAG + ;; TAG1 + ;; <clause body> + ;; goto DONETAG + ;; TAG2 + ;; <clause body> + ;; goto DONETAG + ;; DEFAULT-TAG + ;; <body for `t' clause, if any (else `constant nil')> + ;; DONETAG + + (byte-compile-variable-ref var) + (byte-compile-push-constant jump-table) + (byte-compile-out 'byte-switch) + + ;; When the opcode argument is `byte-goto', `byte-compile-goto' sets + ;; `byte-compile-depth' to `nil'. However, we need `byte-compile-depth' + ;; to be non-nil for generating tags for all cases. Since + ;; `byte-compile-depth' will increase by at most 1 after compiling + ;; all of the clause (which is further enforced by cl-assert below) + ;; it should be safe to preserve it's value. + (let ((byte-compile-depth byte-compile-depth)) + (byte-compile-goto 'byte-goto default-tag)) + + (when (assq 'default cases) + (setq default-case (cadr (assq 'default cases)) + cases (butlast cases 1))) + + (dolist (case cases) + (setq tag (byte-compile-make-tag) + test-obj (nth 0 case) + body (nth 1 case)) + (byte-compile-out-tag tag) + (puthash test-obj tag jump-table) + + (let ((byte-compile-depth byte-compile-depth) + (init-depth byte-compile-depth)) + ;; Since `byte-compile-body' might increase `byte-compile-depth' + ;; by 1, not preserving it's value will cause it to potentially + ;; increase by one for every clause body compiled, causing + ;; depth/tag conflicts or violating asserts down the road. + ;; To make sure `byte-compile-body' itself doesn't violate this, + ;; we use `cl-assert'. + (if (null body) + (byte-compile-form t byte-compile--for-effect) + (byte-compile-body body byte-compile--for-effect)) + (cl-assert (or (= byte-compile-depth init-depth) + (= byte-compile-depth (1+ init-depth)))) + (byte-compile-goto 'byte-goto donetag) + (setcdr (cdr donetag) nil))) + + (byte-compile-out-tag default-tag) + (if default-case + (byte-compile-body-do-effect default-case) + (byte-compile-constant nil)) + (byte-compile-out-tag donetag) + (push jump-table byte-compile-jump-tables)))) + (defun byte-compile-cond (clauses) - (let ((donetag (byte-compile-make-tag)) - nexttag clause) - (while (setq clauses (cdr clauses)) - (setq clause (car clauses)) - (cond ((or (eq (car clause) t) - (and (eq (car-safe (car clause)) 'quote) - (car-safe (cdr-safe (car clause))))) - ;; Unconditional clause - (setq clause (cons t clause) - clauses nil)) - ((cdr clauses) - (byte-compile-form (car clause)) - (if (null (cdr clause)) - ;; First clause is a singleton. - (byte-compile-goto-if t byte-compile--for-effect donetag) - (setq nexttag (byte-compile-make-tag)) - (byte-compile-goto 'byte-goto-if-nil nexttag) - (byte-compile-maybe-guarded (car clause) - (byte-compile-body (cdr clause) byte-compile--for-effect)) - (byte-compile-goto 'byte-goto donetag) - (byte-compile-out-tag nexttag))))) - ;; Last clause - (let ((guard (car clause))) - (and (cdr clause) (not (eq guard t)) - (progn (byte-compile-form guard) - (byte-compile-goto-if nil byte-compile--for-effect donetag) - (setq clause (cdr clause)))) - (byte-compile-maybe-guarded guard - (byte-compile-body-do-effect clause))) - (byte-compile-out-tag donetag))) + (or (and byte-compile-cond-use-jump-table + (byte-compile-cond-jump-table clauses)) + (let ((donetag (byte-compile-make-tag)) + nexttag clause) + (while (setq clauses (cdr clauses)) + (setq clause (car clauses)) + (cond ((or (eq (car clause) t) + (and (eq (car-safe (car clause)) 'quote) + (car-safe (cdr-safe (car clause))))) + ;; Unconditional clause + (setq clause (cons t clause) + clauses nil)) + ((cdr clauses) + (byte-compile-form (car clause)) + (if (null (cdr clause)) + ;; First clause is a singleton. + (byte-compile-goto-if t byte-compile--for-effect donetag) + (setq nexttag (byte-compile-make-tag)) + (byte-compile-goto 'byte-goto-if-nil nexttag) + (byte-compile-maybe-guarded (car clause) + (byte-compile-body (cdr clause) byte-compile--for-effect)) + (byte-compile-goto 'byte-goto donetag) + (byte-compile-out-tag nexttag))))) + ;; Last clause + (let ((guard (car clause))) + (and (cdr clause) (not (eq guard t)) + (progn (byte-compile-form guard) + (byte-compile-goto-if nil byte-compile--for-effect donetag) + (setq clause (cdr clause)))) + (byte-compile-maybe-guarded guard + (byte-compile-body-do-effect clause))) + (byte-compile-out-tag donetag)))) (defun byte-compile-and (form) (let ((failtag (byte-compile-make-tag)) @@ -4018,8 +4231,8 @@ that suppresses all warnings during execution of BODY." (progn (mapc 'byte-compile-form (cdr form)) (byte-compile-out 'byte-call (length (cdr (cdr form))))) - (byte-compile-log-warning - (format-message "`funcall' called with no arguments") nil :error) + (byte-compile-report-error + (format-message "`funcall' called with no arguments")) (byte-compile-form '(signal 'wrong-number-of-arguments '(funcall 0)) byte-compile--for-effect))) @@ -4509,7 +4722,7 @@ binding slots have been popped." (and byte-compile-depth (not (= (cdr (cdr tag)) byte-compile-depth)) (error "Compiler bug: depth conflict at tag %d" (car (cdr tag)))) - (setq byte-compile-depth (cdr (cdr tag)))) + (setq byte-compile-depth (cdr (cdr tag)))) (setcdr (cdr tag) byte-compile-depth))) (defun byte-compile-goto (opcode tag) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 3d6132c9aa6..4507af7a59b 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -253,6 +253,32 @@ Returns a form where all lambdas don't have any free variables." `(internal-make-closure ,args ,envector ,docstring . ,body-new))))) +(defun cconv--remap-llv (new-env var closedsym) + ;; In a case such as: + ;; (let* ((fun (lambda (x) (+ x y))) (y 1)) (funcall fun 1)) + ;; A naive lambda-lifting would return + ;; (let* ((fun (lambda (y x) (+ x y))) (y 1)) (funcall fun y 1)) + ;; Where the external `y' is mistakenly captured by the inner one. + ;; So when we detect that case, we rewrite it to: + ;; (let* ((closed-y y) (fun (lambda (y x) (+ x y))) (y 1)) + ;; (funcall fun closed-y 1)) + ;; We do that even if there's no `funcall' that uses `fun' in the scope + ;; where `y' is shadowed by another variable because, to treat + ;; this case better, we'd need to traverse the tree one more time to + ;; collect this data, and I think that it's not worth it. + (mapcar (lambda (mapping) + (if (not (eq (cadr mapping) 'apply-partially)) + mapping + (cl-assert (eq (car mapping) (nth 2 mapping))) + `(,(car mapping) + apply-partially + ,(car mapping) + ,@(mapcar (lambda (arg) + (if (eq var arg) + closedsym arg)) + (nthcdr 3 mapping))))) + new-env)) + (defun cconv-convert (form env extend) ;; This function actually rewrites the tree. "Return FORM with all its lambdas changed so they are closed. @@ -299,9 +325,9 @@ places where they originally did not directly appear." (var (if (not (consp binder)) (prog1 binder (setq binder (list binder))) (when (cddr binder) - (byte-compile-log-warning - (format-message "Malformed `%S' binding: %S" - letsym binder))) + (byte-compile-warn + "Malformed `%S' binding: %S" + letsym binder)) (setq value (cadr binder)) (car binder))) (new-val @@ -350,34 +376,13 @@ places where they originally did not directly appear." (if (assq var new-env) (push `(,var) new-env)) (cconv-convert value env extend))))) - ;; The piece of code below letbinds free variables of a λ-lifted - ;; function if they are redefined in this let, example: - ;; (let* ((fun (lambda (x) (+ x y))) (y 1)) (funcall fun 1)) - ;; Here we can not pass y as parameter because it is redefined. - ;; So we add a (closed-y y) declaration. We do that even if the - ;; function is not used inside this let(*). The reason why we - ;; ignore this case is that we can't "look forward" to see if the - ;; function is called there or not. To treat this case better we'd - ;; need to traverse the tree one more time to collect this data, and - ;; I think that it's not worth it. - (when (memq var new-extend) - (let ((closedsym - (make-symbol (concat "closed-" (symbol-name var))))) - (setq new-env - (mapcar (lambda (mapping) - (if (not (eq (cadr mapping) 'apply-partially)) - mapping - (cl-assert (eq (car mapping) (nth 2 mapping))) - `(,(car mapping) - apply-partially - ,(car mapping) - ,@(mapcar (lambda (arg) - (if (eq var arg) - closedsym arg)) - (nthcdr 3 mapping))))) - new-env)) - (setq new-extend (remq var new-extend)) - (push closedsym new-extend) + (when (and (eq letsym 'let*) (memq var new-extend)) + ;; One of the lambda-lifted vars is shadowed, so add + ;; a reference to the outside binding and arrange to use + ;; that reference. + (let ((closedsym (make-symbol (format "closed-%s" var)))) + (setq new-env (cconv--remap-llv new-env var closedsym)) + (setq new-extend (cons closedsym (remq var new-extend))) (push `(,closedsym ,var) binders-new))) ;; We push the element after redefined free variables are @@ -390,6 +395,21 @@ places where they originally did not directly appear." (setq extend new-extend)) )) ; end of dolist over binders + (when (not (eq letsym 'let*)) + ;; We can't do the cconv--remap-llv at the same place for let and + ;; let* because in the case of `let', the shadowing may occur + ;; before we know that the var will be in `new-extend' (bug#24171). + (dolist (binder binders-new) + (when (memq (car-safe binder) new-extend) + ;; One of the lambda-lifted vars is shadowed, so add + ;; a reference to the outside binding and arrange to use + ;; that reference. + (let* ((var (car-safe binder)) + (closedsym (make-symbol (format "closed-%s" var)))) + (setq new-env (cconv--remap-llv new-env var closedsym)) + (setq new-extend (cons closedsym (remq var new-extend))) + (push `(,closedsym ,var) binders-new))))) + `(,letsym ,(nreverse binders-new) . ,(mapcar (lambda (form) (cconv-convert @@ -548,8 +568,8 @@ FORM is the parent form that binds this var." (`(,_ nil nil nil nil) nil) (`((,(and var (guard (eq ?_ (aref (symbol-name var) 0)))) . ,_) ,_ ,_ ,_ ,_) - (byte-compile-log-warning - (format-message "%s `%S' not left unused" varkind var)))) + (byte-compile-warn + "%s `%S' not left unused" varkind var))) (pcase vardata (`((,var . ,_) nil ,_ ,_ nil) ;; FIXME: This gives warnings in the wrong order, with imprecise line @@ -561,8 +581,8 @@ FORM is the parent form that binds this var." (eq ?_ (aref (symbol-name var) 0)) ;; As a special exception, ignore "ignore". (eq var 'ignored)) - (byte-compile-log-warning (format-message "Unused lexical %s `%S'" - varkind var)))) + (byte-compile-warn "Unused lexical %s `%S'" + varkind var))) ;; If it's unused, there's no point converting it into a cons-cell, even if ;; it's captured and mutated. (`(,binder ,_ t t ,_) @@ -586,9 +606,9 @@ FORM is the parent form that binds this var." (dolist (arg args) (cond ((byte-compile-not-lexical-var-p arg) - (byte-compile-log-warning - (format "Lexical argument shadows the dynamic variable %S" - arg))) + (byte-compile-warn + "Lexical argument shadows the dynamic variable %S" + arg)) ((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ... (t (let ((varstruct (list arg nil nil nil nil))) (cl-pushnew arg byte-compile-lexical-variables) @@ -670,9 +690,8 @@ and updates the data stored in ENV." (setq forms (cddr forms)))) (`((lambda . ,_) . ,_) ; First element is lambda expression. - (byte-compile-log-warning - (format "Use of deprecated ((lambda %s ...) ...) form" (nth 1 (car form))) - t :warning) + (byte-compile-warn + "Use of deprecated ((lambda %s ...) ...) form" (nth 1 (car form))) (dolist (exp `((function ,(car form)) . ,(cdr form))) (cconv-analyze-form exp env))) @@ -681,8 +700,8 @@ and updates the data stored in ENV." (dolist (form forms) (cconv-analyze-form form env)))) ;; ((and `(quote ,v . ,_) (guard (assq v env))) - ;; (byte-compile-log-warning - ;; (format-message "Possible confusion variable/symbol for `%S'" v))) + ;; (byte-compile-warn + ;; "Possible confusion variable/symbol for `%S'" v)) (`(quote . ,_) nil) ; quote form (`(function . ,_) nil) ; same as quote @@ -699,8 +718,8 @@ and updates the data stored in ENV." (`(condition-case ,var ,protected-form . ,handlers) (cconv-analyze-form protected-form env) (when (and var (symbolp var) (byte-compile-not-lexical-var-p var)) - (byte-compile-log-warning - (format "Lexical variable shadows the dynamic variable %S" var))) + (byte-compile-warn + "Lexical variable shadows the dynamic variable %S" var)) (let* ((varstruct (list var nil nil nil nil))) (if var (push varstruct env)) (dolist (handler handlers) diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el index 1538728475c..dc108f956c2 100644 --- a/lisp/emacs-lisp/chart.el +++ b/lisp/emacs-lisp/chart.el @@ -60,6 +60,7 @@ ;; with all the bitmaps you want to use. (require 'eieio) +(eval-when-compile (require 'cl-lib)) (eval-when-compile (require 'cl-generic)) ;;; Code: @@ -118,7 +119,7 @@ Useful if new Emacs is used on B&W display.") List is limited currently, which is ok since you really can't display too much in text characters anyways.") -(define-derived-mode chart-mode fundamental-mode "CHART" +(define-derived-mode chart-mode special-mode "Chart" "Define a mode in Emacs for displaying a chart." (buffer-disable-undo) (set (make-local-variable 'font-lock-global-modes) nil) @@ -205,22 +206,23 @@ Make sure the width/height is correct." (cl-defmethod chart-draw ((c chart) &optional buff) "Start drawing a chart object C in optional BUFF. Erases current contents of buffer." - (save-excursion - (if buff (set-buffer buff)) - (erase-buffer) - (insert (make-string 100 ?\n)) - ;; Start by displaying the axis - (chart-draw-axis c) - ;; Display title - (chart-draw-title c) - ;; Display data - (message "Rendering chart...") - (sit-for 0) - (chart-draw-data c) - ;; Display key - ; (chart-draw-key c) - (message "Rendering chart...done") - )) + (with-silent-modifications + (save-excursion + (if buff (set-buffer buff)) + (erase-buffer) + (insert (make-string (window-height (selected-window)) ?\n)) + ;; Start by displaying the axis + (chart-draw-axis c) + ;; Display title + (chart-draw-title c) + ;; Display data + (message "Rendering chart...") + (sit-for 0) + (chart-draw-data c) + ;; Display key + ; (chart-draw-key c) + (message "Rendering chart...done") + ))) (cl-defmethod chart-draw-title ((c chart)) "Draw a title upon the chart. @@ -434,11 +436,10 @@ or is created with the bounds of SEQ." (setq axis (make-instance 'chart-axis-range :name (oref seq name) :chart c))) - (while l - (if (< (car l) (car range)) (setcar range (car l))) - (if (> (car l) (cdr range)) (setcdr range (car l))) - (setq l (cdr l))) - (oset axis bounds range))) + (dolist (x l) + (if (< x (car range)) (setcar range x)) + (if (> x (cdr range)) (setcdr range x))) + (oset axis bounds range))) (if (eq axis-label 'x-axis) (oset axis loweredge nil)) (eieio-oset c axis-label axis) )) @@ -449,11 +450,10 @@ or is created with the bounds of SEQ." (cl-defmethod chart-trim ((c chart) max) "Trim all sequences in chart C to be at most MAX elements long." (let ((s (oref c sequences))) - (while s - (let ((sl (oref (car s) data))) + (dolist (x s) + (let ((sl (oref x data))) (if (> (length sl) max) - (setcdr (nthcdr (1- max) sl) nil))) - (setq s (cdr s)))) + (setcdr (nthcdr (1- max) sl) nil))))) ) (cl-defmethod chart-sort ((c chart) pred) @@ -614,27 +614,20 @@ SORT-PRED if desired." (defun chart-file-count (dir) "Draw a chart displaying the number of different file extensions in DIR." (interactive "DDirectory: ") - (if (not (string-match "/$" dir)) - (setq dir (concat dir "/"))) (message "Collecting statistics...") (let ((flst (directory-files dir nil nil t)) (extlst (list "<dir>")) (cntlst (list 0))) - (while flst - (let* ((j (string-match "[^\\.]\\(\\.[a-zA-Z]+\\|~\\|#\\)$" (car flst))) - (s (if (file-accessible-directory-p (concat dir (car flst))) - "<dir>" - (if j - (substring (car flst) (match-beginning 1) (match-end 1)) - nil))) + (dolist (f flst) + (let* ((x (file-name-extension f)) + (s (if (file-accessible-directory-p (expand-file-name f dir)) + "<dir>" x)) (m (member s extlst))) - (if (not s) nil + (unless (null s) (if m - (let ((cell (nthcdr (- (length extlst) (length m)) cntlst))) - (setcar cell (1+ (car cell)))) + (cl-incf (car (nthcdr (- (length extlst) (length m)) cntlst))) (setq extlst (cons s extlst) - cntlst (cons 1 cntlst))))) - (setq flst (cdr flst))) + cntlst (cons 1 cntlst)))))) ;; Let's create the chart! (chart-bar-quickie 'vertical "Files Extension Distribution" extlst "File Extensions" diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el index 8665b9dc599..c46426cd366 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 3e782e0a809..1d6fdfa4e87 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -294,12 +294,6 @@ problem discovered. This is useful for adding additional checks.") (defvar checkdoc-diagnostic-buffer "*Style Warnings*" "Name of warning message buffer.") -(defvar checkdoc-defun-regexp - "^(def\\(un\\|var\\|custom\\|macro\\|const\\|subst\\|advice\\)\ -\\s-+\\(\\(\\sw\\|\\s_\\)+\\)[ \t\n]+" - "Regular expression used to identify a defun. -A search leaves the cursor in front of the parameter list.") - (defcustom checkdoc-verb-check-experimental-flag t "Non-nil means to attempt to check the voice of the doc string. This check keys off some words which are commonly misused. See the @@ -609,7 +603,7 @@ style." (checkdoc-overlay-put cdo 'face 'highlight) ;; Make sure the whole doc string is visible if possible. (sit-for 0) - (if (and (looking-at "\"") + (if (and (= (following-char) ?\") (not (pos-visible-in-window-p (save-excursion (forward-sexp 1) (point)) (selected-window)))) @@ -749,9 +743,9 @@ buffer, otherwise searching starts at START-HERE." (while (checkdoc-next-docstring) (message "Searching for doc string spell error...%d%%" (floor (* 100.0 (point)) (point-max))) - (if (looking-at "\"") - (checkdoc-ispell-docstring-engine - (save-excursion (forward-sexp 1) (point-marker))))) + (when (= (following-char) ?\") + (checkdoc-ispell-docstring-engine + (save-excursion (forward-sexp 1) (point-marker))))) (message "Checkdoc: Done.")))) (defun checkdoc-message-interactive-ispell-loop (start-here) @@ -769,7 +763,7 @@ buffer, otherwise searching starts at START-HERE." (while (checkdoc-message-text-next-string (point-max)) (message "Searching for message string spell error...%d%%" (floor (* 100.0 (point)) (point-max))) - (if (looking-at "\"") + (if (= (following-char) ?\") (checkdoc-ispell-docstring-engine (save-excursion (forward-sexp 1) (point-marker))))) (message "Checkdoc: Done.")))) @@ -938,13 +932,31 @@ is the starting location. If this is nil, `point-min' is used instead." (defun checkdoc-next-docstring () "Move to the next doc string after point, and return t. Return nil if there are no more doc strings." - (if (not (re-search-forward checkdoc-defun-regexp nil t)) - nil - ;; search drops us after the identifier. The next sexp is either - ;; the argument list or the value of the variable. skip it. - (forward-sexp 1) - (skip-chars-forward " \n\t") - t)) + (let (found) + (while (and (not (setq found (checkdoc--next-docstring))) + (beginning-of-defun -1))) + found)) + +(defun checkdoc--next-docstring () + "When looking at a definition with a doc string, find it. +Move to the next doc string after point, and return t. When not +looking at a definition containing a doc string, return nil and +don't move point." + (pcase (save-excursion (condition-case nil + (read (current-buffer)) + ;; Conservatively skip syntax errors. + (invalid-read-syntax))) + (`(,(or 'defun 'defvar 'defcustom 'defmacro 'defconst 'defsubst 'defadvice) + ,(pred symbolp) + ;; Require an initializer, i.e. ignore single-argument `defvar' + ;; forms, which never have a doc string. + ,_ . ,_) + (down-list) + ;; Skip over function or macro name, symbol to be defined, and + ;; initializer or argument list. + (forward-sexp 3) + (skip-chars-forward " \n\t") + t))) ;;;###autoload (defun checkdoc-comments (&optional take-notes) @@ -1027,21 +1039,12 @@ space at the end of each line." (interactive) (save-excursion (beginning-of-defun) - (if (not (looking-at checkdoc-defun-regexp)) - ;; I found this more annoying than useful. - ;;(if (not no-error) - ;; (message "Cannot check this sexp's doc string.")) - nil - ;; search drops us after the identifier. The next sexp is either - ;; the argument list or the value of the variable. skip it. - (goto-char (match-end 0)) - (forward-sexp 1) - (skip-chars-forward " \n\t") + (when (checkdoc--next-docstring) (let* ((checkdoc-spellcheck-documentation-flag - (car (memq checkdoc-spellcheck-documentation-flag + (car (memq checkdoc-spellcheck-documentation-flag '(defun t)))) - (beg (save-excursion (beginning-of-defun) (point))) - (end (save-excursion (end-of-defun) (point)))) + (beg (save-excursion (beginning-of-defun) (point))) + (end (save-excursion (end-of-defun) (point)))) (dolist (fun (list #'checkdoc-this-string-valid (lambda () (checkdoc-message-text-search beg end)) (lambda () (checkdoc-rogue-space-check-engine beg end)))) @@ -1049,8 +1052,8 @@ space at the end of each line." (if msg (if no-error (message "%s" (checkdoc-error-text msg)) (user-error "%s" (checkdoc-error-text msg)))))) - (if (called-interactively-p 'interactive) - (message "Checkdoc: done.")))))) + (if (called-interactively-p 'interactive) + (message "Checkdoc: done.")))))) ;;; Ispell interface for forcing a spell check ;; @@ -1062,7 +1065,7 @@ Calls `checkdoc' with spell-checking turned on. Prefix argument is the same as for `checkdoc'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively #'checkdoc nil current-prefix-arg))) + (call-interactively #'checkdoc))) ;;;###autoload (defun checkdoc-ispell-current-buffer () @@ -1071,7 +1074,7 @@ Calls `checkdoc-current-buffer' with spell-checking turned on. Prefix argument is the same as for `checkdoc-current-buffer'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively #'checkdoc-current-buffer nil current-prefix-arg))) + (call-interactively #'checkdoc-current-buffer))) ;;;###autoload (defun checkdoc-ispell-interactive () @@ -1080,7 +1083,7 @@ Calls `checkdoc-interactive' with spell-checking turned on. Prefix argument is the same as for `checkdoc-interactive'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively #'checkdoc-interactive nil current-prefix-arg))) + (call-interactively #'checkdoc-interactive))) ;;;###autoload (defun checkdoc-ispell-message-interactive () @@ -1099,7 +1102,7 @@ Calls `checkdoc-message-text' with spell-checking turned on. Prefix argument is the same as for `checkdoc-message-text'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively #'checkdoc-message-text nil current-prefix-arg))) + (call-interactively #'checkdoc-message-text))) ;;;###autoload (defun checkdoc-ispell-start () @@ -1108,7 +1111,7 @@ Calls `checkdoc-start' with spell-checking turned on. Prefix argument is the same as for `checkdoc-start'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively #'checkdoc-start nil current-prefix-arg))) + (call-interactively #'checkdoc-start))) ;;;###autoload (defun checkdoc-ispell-continue () @@ -1117,7 +1120,7 @@ Calls `checkdoc-continue' with spell-checking turned on. Prefix argument is the same as for `checkdoc-continue'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively #'checkdoc-continue nil current-prefix-arg))) + (call-interactively #'checkdoc-continue))) ;;;###autoload (defun checkdoc-ispell-comments () @@ -1126,7 +1129,7 @@ Calls `checkdoc-comments' with spell-checking turned on. Prefix argument is the same as for `checkdoc-comments'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively #'checkdoc-comments nil current-prefix-arg))) + (call-interactively #'checkdoc-comments))) ;;;###autoload (defun checkdoc-ispell-defun () @@ -1135,7 +1138,7 @@ Calls `checkdoc-defun' with spell-checking turned on. Prefix argument is the same as for `checkdoc-defun'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively #'checkdoc-defun nil current-prefix-arg))) + (call-interactively #'checkdoc-defun))) ;;; Error Management ;; @@ -1378,7 +1381,7 @@ See the style guide in the Emacs Lisp manual for more details." "All variables and subroutines might as well have a \ documentation string") (point) (+ (point) 1) t))))) - (if (and (not err) (looking-at "\"")) + (if (and (not err) (= (following-char) ?\")) (with-syntax-table checkdoc-syntax-table (checkdoc-this-string-valid-engine fp)) err))) @@ -1392,7 +1395,7 @@ regexp short cuts work. FP is the function defun information." ;; we won't accidentally lose our place. This could cause ;; end-of doc string whitespace to also delete the " char. (s (point)) - (e (if (looking-at "\"") + (e (if (= (following-char) ?\") (save-excursion (forward-sexp 1) (point-marker)) (point)))) (or @@ -1472,7 +1475,7 @@ regexp short cuts work. FP is the function defun information." ((looking-at "[\\!?;:.)]") ;; These are ok nil) - ((and checkdoc-permit-comma-termination-flag (looking-at ",")) + ((and checkdoc-permit-comma-termination-flag (= (following-char) ?,)) nil) (t ;; If it is not a complete sentence, let's see if we can @@ -1638,6 +1641,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 +1812,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 749061b7bc5..021ef232749 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -89,7 +89,7 @@ strings case-insensitively." ;;; Control structures. ;;;###autoload -(defun cl--mapcar-many (cl-func cl-seqs) +(defun cl--mapcar-many (cl-func cl-seqs &optional acc) (if (cdr (cdr cl-seqs)) (let* ((cl-res nil) (cl-n (apply 'min (mapcar 'length cl-seqs))) @@ -106,20 +106,23 @@ strings case-insensitively." (setcar cl-p1 (cdr (car cl-p1)))) (aref (car cl-p1) cl-i))) (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2))) - (push (apply cl-func cl-args) cl-res) + (if acc + (push (apply cl-func cl-args) cl-res) + (apply cl-func cl-args)) (setq cl-i (1+ cl-i))) - (nreverse cl-res)) + (and acc (nreverse cl-res))) (let ((cl-res nil) (cl-x (car cl-seqs)) (cl-y (nth 1 cl-seqs))) (let ((cl-n (min (length cl-x) (length cl-y))) (cl-i -1)) (while (< (setq cl-i (1+ cl-i)) cl-n) - (push (funcall cl-func - (if (consp cl-x) (pop cl-x) (aref cl-x cl-i)) - (if (consp cl-y) (pop cl-y) (aref cl-y cl-i))) - cl-res))) - (nreverse cl-res)))) + (let ((val (funcall cl-func + (if (consp cl-x) (pop cl-x) (aref cl-x cl-i)) + (if (consp cl-y) (pop cl-y) (aref cl-y cl-i))))) + (when acc + (push val cl-res))))) + (and acc (nreverse cl-res))))) ;;;###autoload (defun cl-map (cl-type cl-func cl-seq &rest cl-rest) @@ -142,7 +145,7 @@ the elements themselves. (while (not (memq nil cl-args)) (push (apply cl-func cl-args) cl-res) (setq cl-p cl-args) - (while cl-p (setcar cl-p (cdr (pop cl-p)) ))) + (while cl-p (setcar cl-p (cdr (pop cl-p))))) (nreverse cl-res)) (let ((cl-res nil)) (while cl-list @@ -155,8 +158,14 @@ the elements themselves. "Like `cl-mapcar', but does not accumulate values returned by the function. \n(fn FUNCTION SEQUENCE...)" (if cl-rest - (progn (apply 'cl-map nil cl-func cl-seq cl-rest) - cl-seq) + (if (or (cdr cl-rest) (nlistp cl-seq) (nlistp (car cl-rest))) + (progn + (cl--mapcar-many cl-func (cons cl-seq cl-rest)) + cl-seq) + (let ((cl-x cl-seq) (cl-y (car cl-rest))) + (while (and cl-x cl-y) + (funcall cl-func (pop cl-x) (pop cl-y))) + cl-seq)) (mapc cl-func cl-seq))) ;;;###autoload @@ -164,7 +173,12 @@ the elements themselves. "Like `cl-maplist', but does not accumulate values returned by the function. \n(fn FUNCTION LIST...)" (if cl-rest - (apply 'cl-maplist cl-func cl-list cl-rest) + (let ((cl-args (cons cl-list (copy-sequence cl-rest))) + cl-p) + (while (not (memq nil cl-args)) + (apply cl-func cl-args) + (setq cl-p cl-args) + (while cl-p (setcar cl-p (cdr (pop cl-p)))))) (let ((cl-p cl-list)) (while cl-p (funcall cl-func cl-p) (setq cl-p (cdr cl-p))))) cl-list) @@ -173,7 +187,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) @@ -591,13 +607,7 @@ too large if positive or too small if negative)." \n(fn SYMBOL PROPNAME &optional DEFAULT)" (declare (compiler-macro cl--compiler-macro-get) (gv-setter (lambda (store) (ignore def) `(put ,sym ,tag ,store)))) - (or (get sym tag) - (and def - ;; Make sure `def' is really absent as opposed to set to nil. - (let ((plist (symbol-plist sym))) - (while (and plist (not (eq (car plist) tag))) - (setq plist (cdr (cdr plist)))) - (if plist (car (cdr plist)) def))))) + (cl-getf (symbol-plist sym) tag def)) (autoload 'cl--compiler-macro-get "cl-macs") ;;;###autoload @@ -616,26 +626,20 @@ PROPLIST is a list of the sort returned by `symbol-plist'. ,(funcall setter `(cl--set-getf ,getter ,k ,val)) ,val))))))))) - (setplist '--cl-getf-symbol-- plist) - (or (get '--cl-getf-symbol-- tag) - ;; Originally we called cl-get here, - ;; but that fails, because cl-get has a compiler macro - ;; definition that uses getf! - (when def - ;; Make sure `def' is really absent as opposed to set to nil. - (while (and plist (not (eq (car plist) tag))) - (setq plist (cdr (cdr plist)))) - (if plist (car (cdr plist)) def)))) + (let ((val-tail (cdr-safe (plist-member plist tag)))) + (if val-tail (car val-tail) def))) ;;;###autoload (defun cl--set-getf (plist tag val) - (let ((p plist)) - (while (and p (not (eq (car p) tag))) (setq p (cdr (cdr p)))) - (if p (progn (setcar (cdr p) val) plist) (cl-list* tag val plist)))) + (let ((val-tail (cdr-safe (plist-member plist tag)))) + (if val-tail (progn (setcar val-tail val) plist) + (cl-list* tag val plist)))) ;;;###autoload (defun cl--do-remf (plist tag) (let ((p (cdr plist))) + ;; Can't use `plist-member' here because it goes to the cons-cell + ;; of TAG and we need the one before. (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) @@ -861,6 +865,38 @@ including `cl-block' and `cl-eval-when'." "\n"))) "\n")) +(defun cl--print-table (header rows) + ;; FIXME: Isn't this functionality already implemented elsewhere? + (let ((cols (apply #'vector (mapcar #'string-width header))) + (col-space 2)) + (dolist (row rows) + (dotimes (i (length cols)) + (let* ((x (pop row)) + (curwidth (aref cols i)) + (newwidth (if x (string-width x) 0))) + (if (> newwidth curwidth) + (setf (aref cols i) newwidth))))) + (let ((formats '()) + (col 0)) + (dotimes (i (length cols)) + (push (concat (propertize " " + 'display + `(space :align-to ,(+ col col-space))) + "%s") + formats) + (cl-incf col (+ col-space (aref cols i)))) + (let ((format (mapconcat #'identity (nreverse formats) ""))) + (insert (apply #'format format + (mapcar (lambda (str) (propertize str 'face 'italic)) + header)) + "\n") + (insert (apply #'format format + (mapcar (lambda (str) (make-string (string-width str) ?—)) + header)) + "\n") + (dolist (row rows) + (insert (apply #'format format row) "\n")))))) + (defun cl--describe-class-slots (class) "Print help description for the slots in CLASS. Outputs to the current buffer." @@ -873,7 +909,22 @@ Outputs to the current buffer." (cl-struct-unknown-slot nil)))) (insert (propertize "Instance Allocated Slots:\n\n" 'face 'bold)) - (mapc #'cl--describe-class-slot slots) + (let* ((has-doc nil) + (slots-strings + (mapcar + (lambda (slot) + (list (cl-prin1-to-string (cl--slot-descriptor-name slot)) + (cl-prin1-to-string (cl--slot-descriptor-type slot)) + (cl-prin1-to-string (cl--slot-descriptor-initform slot)) + (let ((doc (alist-get :documentation + (cl--slot-descriptor-props slot)))) + (if (not doc) "" + (setq has-doc t) + (substitute-command-keys doc))))) + slots))) + (cl--print-table `("Name" "Type" "Default" . ,(if has-doc '("Doc"))) + slots-strings)) + (insert "\n") (when (> (length cslots) 0) (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold)) (mapc #'cl--describe-class-slot cslots)))) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 8a59aa306b7..8c6d3d5d51f 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -226,7 +226,14 @@ DEFAULT-BODY, if present, is used as the body of a default method. (when (eq 'setf (car-safe name)) (require 'gv) (setq name (gv-setter (cadr name)))) - `(progn + `(prog1 + (progn + (defalias ',name + (cl-generic-define ',name ',args ',(nreverse options)) + ,(help-add-fundoc-usage doc args)) + :autoload-end + ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method)) + (nreverse methods))) ,@(mapcar (lambda (declaration) (let ((f (cdr (assq (car declaration) defun-declarations-alist)))) @@ -235,12 +242,7 @@ DEFAULT-BODY, if present, is used as the body of a default method. (t (message "Warning: Unknown defun property `%S' in %S" (car declaration) name) nil)))) - (cdr declarations)) - (defalias ',name - (cl-generic-define ',name ',args ',(nreverse options)) - ,(help-add-fundoc-usage doc args)) - ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method)) - (nreverse methods))))) + (cdr declarations))))) ;;;###autoload (defun cl-generic-define (name args options) @@ -358,6 +360,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 +397,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 +439,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 +453,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 +499,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 +783,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 +887,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 +959,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 +1046,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 +1067,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 +1123,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 @@ -1103,21 +1144,29 @@ The value returned is a list of elements of the form (defconst cl--generic-typeof-types ;; Hand made from the source code of `type-of'. - '((integer number) (symbol) (string array sequence) (cons list sequence) + '((integer number number-or-marker atom) + (symbol atom) (string array sequence atom) + (cons list sequence) ;; Markers aren't `numberp', yet they are accepted wherever integers are ;; accepted, pretty much. - (marker) (overlay) (float number) (window-configuration) - (process) (window) (subr) (compiled-function) (buffer) - (char-table array sequence) - (bool-vector array sequence) - (frame) (hash-table) (font-spec) (font-entity) (font-object) - (vector array sequence) - ;; Plus, hand made: - (null symbol list sequence) - (list sequence) - (array sequence) - (sequence) - (number))) + (marker number-or-marker atom) + (overlay atom) (float number atom) (window-configuration atom) + (process atom) (window atom) (subr atom) (compiled-function function atom) + (buffer atom) (char-table array sequence atom) + (bool-vector array sequence atom) + (frame atom) (hash-table atom) (terminal atom) + (thread atom) (mutex atom) (condvar atom) + (font-spec atom) (font-entity atom) (font-object atom) + (vector array sequence atom) + ;; Plus, really hand made: + (null symbol list sequence atom)) + "Alist of supertypes. +Each element has the form (TYPE . SUPERTYPES) where TYPE is one of +the symbols returned by `type-of', and SUPERTYPES is the list of its +supertypes from the most specific to least specific.") + +(defconst cl--generic-all-builtin-types + (delete-dups (copy-sequence (apply #'append cl--generic-typeof-types)))) (cl-generic-define-generalizer cl--generic-typeof-generalizer ;; FIXME: We could also change `type-of' to return `null' for nil. @@ -1126,11 +1175,12 @@ 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', ... + ;; as `character', `face', `function', ... (or - (and (assq type cl--generic-typeof-types) + (and (memq type cl--generic-all-builtin-types) (progn ;; FIXME: While this wrinkle in the semantics can be occasionally ;; problematic, this warning is more often annoying than helpful. @@ -1164,7 +1214,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) @@ -1173,9 +1224,5 @@ The value returned is a list of elements of the form (progn (cl-assert (null modes)) mode) `(derived-mode ,mode . ,modes)))) -;; Local variables: -;; generated-autoload-file: "cl-loaddefs.el" -;; End: - (provide 'cl-generic) ;;; cl-generic.el ends here diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index b1db07fe165..8c4455a3dad 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -347,8 +347,9 @@ Call `cl-float-limits' to set this.") (cl--defalias 'cl-copy-seq 'copy-sequence) -(declare-function cl--mapcar-many "cl-extra" (cl-func cl-seqs)) +(declare-function cl--mapcar-many "cl-extra" (cl-func cl-seqs &optional acc)) +;;;###autoload (defun cl-mapcar (cl-func cl-x &rest cl-rest) "Apply FUNCTION to each element of SEQ, and make a list of the results. If there are several SEQs, FUNCTION is called with that many arguments, @@ -358,7 +359,7 @@ SEQ, this is like `mapcar'. With several, it is like the Common Lisp \n(fn FUNCTION SEQ...)" (if cl-rest (if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest))) - (cl--mapcar-many cl-func (cons cl-x cl-rest)) + (cl--mapcar-many cl-func (cons cl-x cl-rest) 'accumulate) (let ((cl-res nil) (cl-y (car cl-rest))) (while (and cl-x cl-y) (push (funcall cl-func (pop cl-x) (pop cl-y)) cl-res)) @@ -413,125 +414,30 @@ Signal an error if X is not a list." (declare (gv-setter (lambda (store) `(setcar (nthcdr 9 ,x) ,store)))) (nth 9 x)) -(defun cl-caaar (x) - "Return the `car' of the `car' of the `car' of X." - (declare (compiler-macro internal--compiler-macro-cXXr)) - (car (car (car x)))) - -(defun cl-caadr (x) - "Return the `car' of the `car' of the `cdr' of X." - (declare (compiler-macro internal--compiler-macro-cXXr)) - (car (car (cdr x)))) - -(defun cl-cadar (x) - "Return the `car' of the `cdr' of the `car' of X." - (declare (compiler-macro internal--compiler-macro-cXXr)) - (car (cdr (car x)))) - -(defun cl-caddr (x) - "Return the `car' of the `cdr' of the `cdr' of X." - (declare (compiler-macro internal--compiler-macro-cXXr)) - (car (cdr (cdr x)))) - -(defun cl-cdaar (x) - "Return the `cdr' of the `car' of the `car' of X." - (declare (compiler-macro internal--compiler-macro-cXXr)) - (cdr (car (car x)))) - -(defun cl-cdadr (x) - "Return the `cdr' of the `car' of the `cdr' of X." - (declare (compiler-macro internal--compiler-macro-cXXr)) - (cdr (car (cdr x)))) - -(defun cl-cddar (x) - "Return the `cdr' of the `cdr' of the `car' of X." - (declare (compiler-macro internal--compiler-macro-cXXr)) - (cdr (cdr (car x)))) - -(defun cl-cdddr (x) - "Return the `cdr' of the `cdr' of the `cdr' of X." - (declare (compiler-macro internal--compiler-macro-cXXr)) - (cdr (cdr (cdr x)))) - -(defun cl-caaaar (x) - "Return the `car' of the `car' of the `car' of the `car' of X." - (declare (compiler-macro internal--compiler-macro-cXXr)) - (car (car (car (car x))))) - -(defun cl-caaadr (x) - "Return the `car' of the `car' of the `car' of the `cdr' of X." - (declare (compiler-macro internal--compiler-macro-cXXr)) - (car (car (car (cdr x))))) - -(defun cl-caadar (x) - "Return the `car' of the `car' of the `cdr' of the `car' of X." - (declare (compiler-macro internal--compiler-macro-cXXr)) - (car (car (cdr (car x))))) - -(defun cl-caaddr (x) - "Return the `car' of the `car' of the `cdr' of the `cdr' of X." - (declare (compiler-macro internal--compiler-macro-cXXr)) - (car (car (cdr (cdr x))))) - -(defun cl-cadaar (x) - "Return the `car' of the `cdr' of the `car' of the `car' of X." - (declare (compiler-macro internal--compiler-macro-cXXr)) - (car (cdr (car (car x))))) - -(defun cl-cadadr (x) - "Return the `car' of the `cdr' of the `car' of the `cdr' of X." - (declare (compiler-macro internal--compiler-macro-cXXr)) - (car (cdr (car (cdr x))))) - -(defun cl-caddar (x) - "Return the `car' of the `cdr' of the `cdr' of the `car' of X." - (declare (compiler-macro internal--compiler-macro-cXXr)) - (car (cdr (cdr (car x))))) - -(defun cl-cadddr (x) - "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X." - (declare (compiler-macro internal--compiler-macro-cXXr)) - (car (cdr (cdr (cdr x))))) - -(defun cl-cdaaar (x) - "Return the `cdr' of the `car' of the `car' of the `car' of X." - (declare (compiler-macro internal--compiler-macro-cXXr)) - (cdr (car (car (car x))))) - -(defun cl-cdaadr (x) - "Return the `cdr' of the `car' of the `car' of the `cdr' of X." - (declare (compiler-macro internal--compiler-macro-cXXr)) - (cdr (car (car (cdr x))))) - -(defun cl-cdadar (x) - "Return the `cdr' of the `car' of the `cdr' of the `car' of X." - (declare (compiler-macro internal--compiler-macro-cXXr)) - (cdr (car (cdr (car x))))) - -(defun cl-cdaddr (x) - "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X." - (declare (compiler-macro internal--compiler-macro-cXXr)) - (cdr (car (cdr (cdr x))))) - -(defun cl-cddaar (x) - "Return the `cdr' of the `cdr' of the `car' of the `car' of X." - (declare (compiler-macro internal--compiler-macro-cXXr)) - (cdr (cdr (car (car x))))) - -(defun cl-cddadr (x) - "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X." - (declare (compiler-macro internal--compiler-macro-cXXr)) - (cdr (cdr (car (cdr x))))) - -(defun cl-cdddar (x) - "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X." - (declare (compiler-macro internal--compiler-macro-cXXr)) - (cdr (cdr (cdr (car x))))) - -(defun cl-cddddr (x) - "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X." - (declare (compiler-macro internal--compiler-macro-cXXr)) - (cdr (cdr (cdr (cdr x))))) +(defalias 'cl-caaar 'caaar) +(defalias 'cl-caadr 'caadr) +(defalias 'cl-cadar 'cadar) +(defalias 'cl-caddr 'caddr) +(defalias 'cl-cdaar 'cdaar) +(defalias 'cl-cdadr 'cdadr) +(defalias 'cl-cddar 'cddar) +(defalias 'cl-cdddr 'cdddr) +(defalias 'cl-caaaar 'caaaar) +(defalias 'cl-caaadr 'caaadr) +(defalias 'cl-caadar 'caadar) +(defalias 'cl-caaddr 'caaddr) +(defalias 'cl-cadaar 'cadaar) +(defalias 'cl-cadadr 'cadadr) +(defalias 'cl-caddar 'caddar) +(defalias 'cl-cadddr 'cadddr) +(defalias 'cl-cdaaar 'cdaaar) +(defalias 'cl-cdaadr 'cdaadr) +(defalias 'cl-cdadar 'cdadar) +(defalias 'cl-cdaddr 'cdaddr) +(defalias 'cl-cddaar 'cddaar) +(defalias 'cl-cddadr 'cddadr) +(defalias 'cl-cdddar 'cdddar) +(defalias 'cl-cddddr 'cddddr) ;;(defun last* (x &optional n) ;; "Returns the last link in the list LIST. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 928f5d87f8f..58bcdd52acf 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -923,6 +923,7 @@ For more details, see Info node `(cl)Loop Facility'. "count" "maximize" "minimize" "if" "unless" "return"] form] + ["using" (symbolp symbolp)] ;; Simple default, which covers 99% of the cases. symbolp form))) (if (not (memq t (mapcar #'symbolp @@ -1837,6 +1838,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. @@ -2037,8 +2059,8 @@ except that it additionally expands symbol macros." (pcase exp ((pred symbolp) ;; Perform symbol-macro expansion. - (when (cdr (assq (symbol-name exp) env)) - (setq exp (cadr (assq (symbol-name exp) env))))) + (when (cdr (assq exp env)) + (setq exp (cadr (assq exp env))))) (`(setq . ,_) ;; Convert setq to setf if required by symbol-macro expansion. (let* ((args (mapcar (lambda (f) (cl--sm-macroexpand f env)) @@ -2056,7 +2078,7 @@ except that it additionally expands symbol macros." (let ((letf nil) (found nil) (nbs ())) (dolist (binding bindings) (let* ((var (if (symbolp binding) binding (car binding))) - (sm (assq (symbol-name var) env))) + (sm (assq var env))) (push (if (not (cdr sm)) binding (let ((nexp (cadr sm))) @@ -2113,7 +2135,7 @@ Within the body FORMs, references to the variable NAME will be replaced by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). \(fn ((NAME EXPANSION) ...) FORM...)" - (declare (indent 1) (debug ((&rest (symbol sexp)) cl-declarations body))) + (declare (indent 1) (debug ((&rest (symbolp sexp)) cl-declarations body))) (cond ((cdr bindings) `(cl-symbol-macrolet (,(car bindings)) @@ -2127,7 +2149,7 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). (let ((expansion ;; FIXME: For N bindings, this will traverse `body' N times! (macroexpand-all (macroexp-progn body) - (cons (list (symbol-name (caar bindings)) + (cons (list (caar bindings) (cl-cadar bindings)) macroexpand-all-environment)))) (if (or (null (cdar bindings)) (cl-cddar bindings)) @@ -2557,20 +2579,19 @@ non-nil value, that slot cannot be set via `setf'. [&or symbolp (gate symbolp &rest - (&or [":conc-name" symbolp] - [":constructor" symbolp &optional cl-lambda-list] - [":copier" symbolp] - [":predicate" symbolp] - [":include" symbolp &rest sexp] ;; Not finished. - ;; The following are not supported. - ;; [":print-function" ...] - ;; [":type" ...] - ;; [":initial-offset" ...] - ))] + [&or symbolp + (&or [":conc-name" symbolp] + [":constructor" symbolp &optional cl-lambda-list] + [":copier" symbolp] + [":predicate" symbolp] + [":include" symbolp &rest sexp] ;; Not finished. + [":print-function" sexp] + [":type" symbolp] + [":named"] + [":initial-offset" natnump])])] [&optional stringp] ;; All the above is for the following def-form. - &rest &or symbolp (symbolp def-form - &optional ":read-only" sexp)))) + &rest &or symbolp (symbolp &optional def-form &rest sexp)))) (let* ((name (if (consp struct) (car struct) struct)) (opts (cdr-safe struct)) (slots nil) @@ -2634,7 +2655,7 @@ non-nil value, that slot cannot be set via `setf'. (setq descs (nconc (make-list (car args) '(cl-skip-slot)) descs))) (t - (error "Slot option %s unrecognized" opt))))) + (error "Structure option %s unrecognized" opt))))) (unless (or include-name type) (setq include-name cl--struct-default-parent)) (when include-name (setq include (cl--struct-get-class include-name))) @@ -2698,7 +2719,7 @@ non-nil value, that slot cannot be set via `setf'. (let ((pos 0) (descp descs)) (while descp (let* ((desc (pop descp)) - (slot (car desc))) + (slot (pop desc))) (if (memq slot '(cl-tag-slot cl-skip-slot)) (progn (push nil slots) @@ -2708,8 +2729,12 @@ non-nil value, that slot cannot be set via `setf'. (error "Duplicate slots named %s in %s" slot name)) (let ((accessor (intern (format "%s%s" conc-name slot)))) (push slot slots) - (push (nth 1 desc) defaults) + (push (pop 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 @@ -2719,7 +2744,25 @@ non-nil value, that slot cannot be set via `setf'. (if (= pos 0) '(car cl-x) `(nth ,pos cl-x)))) forms) - (if (cadr (memq :read-only (cddr desc))) + (when (cl-oddp (length desc)) + (push + (macroexp--warn-and-return + (format "Missing value for option `%S' of slot `%s' in struct %s!" + (car (last desc)) slot name) + 'nil) + forms) + (when (and (keywordp (car defaults)) + (not (keywordp (car desc)))) + (let ((kw (car defaults))) + (push + (macroexp--warn-and-return + (format " I'll take `%s' to be an option rather than a default value." + kw) + 'nil) + forms) + (push kw desc) + (setcar defaults nil)))) + (if (plist-get desc ':read-only) (push `(gv-define-expander ,accessor (lambda (_cl-do _cl-x) (error "%s is a read-only slot" ',accessor))) @@ -3003,7 +3046,7 @@ omitted, a default message listing FORM itself is used." (delq nil (mapcar (lambda (x) (unless (macroexp-const-p x) x)) - (cdr form)))))) + (cdr-safe form)))))) `(progn (or ,form (cl--assertion-failed diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 0b079410002..bba7b83a792 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -151,7 +151,20 @@ (add-to-list 'current-load-list `(define-type . ,name)) (cl--struct-register-child parent-class tag) (unless (eq named t) - (eval `(defconst ,tag ',class) t) + ;; We used to use `defconst' instead of `set' but that + ;; has a side-effect of purecopying during the dump, so that the + ;; class object stored in the tag ends up being a *copy* of the + ;; one stored in the `cl--class' property! We could have fixed + ;; this needless duplication by using the purecopied object, but + ;; that then breaks down a bit later when we modify the + ;; cl-structure-class class object to close the recursion + ;; between cl-structure-object and cl-structure-class (because + ;; modifying purecopied objects is not allowed. Since this is + ;; done during dumping, we could relax this rule and allow the + ;; modification, but it's cumbersome). + ;; So in the end, it's easier to just avoid the duplication by + ;; avoiding the use of the purespace here. + (set tag class) ;; In the cl-generic support, we need to be able to check ;; if a vector is a cl-struct object, without knowing its particular type. ;; So we use the (otherwise) unused function slots of the tag symbol diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el new file mode 100644 index 00000000000..8a8d4a4c1af --- /dev/null +++ b/lisp/emacs-lisp/cl-print.el @@ -0,0 +1,231 @@ +;;; cl-print.el --- CL-style generic printing -*- lexical-binding: t; -*- + +;; Copyright (C) 2017 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Keywords: +;; Version: 1.0 +;; Package-Requires: ((emacs "25")) + +;; 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: + +;; Customizable print facility. +;; +;; The heart of it is the generic function `cl-print-object' to which you +;; can add any method you like. +;; +;; The main entry point is `cl-prin1'. + +;;; Code: + +(defvar cl-print-readably nil + "If non-nil, try and make sure the result can be `read'.") + +(defvar cl-print--number-table nil) + +;;;###autoload +(cl-defgeneric cl-print-object (object stream) + "Dispatcher to print OBJECT on STREAM according to its type. +You can add methods to it to customize the output. +But if you just want to print something, don't call this directly: +call other entry points instead, such as `cl-prin1'." + ;; This delegates to the C printer. The C printer will not call us back, so + ;; we should only use it for objects which don't have nesting. + (prin1 object stream)) + +(cl-defmethod cl-print-object ((object cons) stream) + (let ((car (pop object))) + (if (and (memq car '(\, quote \` \,@ \,.)) + (consp object) + (null (cdr object))) + (progn + (princ (if (eq car 'quote) '\' car) stream) + (cl-print-object (car object) stream)) + (princ "(" stream) + (cl-print-object car stream) + (while (and (consp object) + (not (and cl-print--number-table + (numberp (gethash object cl-print--number-table))))) + (princ " " stream) + (cl-print-object (pop object) stream)) + (when object + (princ " . " stream) (cl-print-object object stream)) + (princ ")" stream)))) + +(cl-defmethod cl-print-object ((object vector) stream) + (princ "[" stream) + (dotimes (i (length object)) + (unless (zerop i) (princ " " stream)) + (cl-print-object (aref object i) stream)) + (princ "]" stream)) + +(defvar cl-print-compiled nil + "Control how to print byte-compiled functions. Can be: +- `static' to print the vector of constants. +- `disassemble' to print the disassembly of the code. +- nil to skip printing any details about the code.") + +(cl-defmethod cl-print-object ((object compiled-function) stream) + ;; We use "#f(...)" rather than "#<...>" so that pp.el gives better results. + (princ "#f(compiled-function " stream) + (let ((args (help-function-arglist object 'preserve-names))) + (if args + (prin1 args stream) + (princ "()" stream))) + (let ((doc (documentation object 'raw))) + (when doc + (princ " " stream) + (prin1 doc stream))) + (let ((inter (interactive-form object))) + (when inter + (princ " " stream) + (cl-print-object + (if (eq 'byte-code (car-safe (cadr inter))) + `(interactive ,(make-byte-code nil (nth 1 (cadr inter)) + (nth 2 (cadr inter)) + (nth 3 (cadr inter)))) + inter) + stream))) + (if (eq cl-print-compiled 'disassemble) + (princ + (with-temp-buffer + (insert "\n") + (disassemble-1 object 0) + (buffer-string)) + stream) + (princ " #<bytecode>" stream) + (when (eq cl-print-compiled 'static) + (princ " " stream) + (cl-print-object (aref object 2) stream))) + (princ ")" stream)) + +;; This belongs in nadvice.el, of course, but some load-ordering issues make it +;; complicated: cl-generic uses macros from cl-macs and cl-macs uses advice-add +;; from nadvice, so nadvice needs to be loaded before cl-generic and hence +;; can't use cl-defmethod. +(cl-defmethod cl-print-object :extra "nadvice" + ((object compiled-function) stream) + (if (not (advice--p object)) + (cl-call-next-method) + (princ "#f(advice-wrapper " stream) + (when (fboundp 'advice--where) + (princ (advice--where object) stream) + (princ " " stream)) + (cl-print-object (advice--cdr object) stream) + (princ " " stream) + (cl-print-object (advice--car object) stream) + (let ((props (advice--props object))) + (when props + (princ " " stream) + (cl-print-object props stream))) + (princ ")" stream))) + +(cl-defmethod cl-print-object ((object cl-structure-object) stream) + (princ "#s(" stream) + (let* ((class (symbol-value (aref object 0))) + (slots (cl--struct-class-slots class))) + (princ (cl--struct-class-name class) stream) + (dotimes (i (length slots)) + (let ((slot (aref slots i))) + (princ " :" stream) + (princ (cl--slot-descriptor-name slot) stream) + (princ " " stream) + (cl-print-object (aref object (1+ i)) stream)))) + (princ ")" stream)) + +;;; Circularity and sharing. + +;; I don't try to support the `print-continuous-numbering', because +;; I think it's ill defined anyway: if an object appears only once in each call +;; its sharing can't be properly preserved! + +(cl-defmethod cl-print-object :around (object stream) + ;; FIXME: Only put such an :around method on types where it's relevant. + (let ((n (if cl-print--number-table (gethash object cl-print--number-table)))) + (if (not (numberp n)) + (cl-call-next-method) + (if (> n 0) + ;; Already printed. Just print a reference. + (progn (princ "#" stream) (princ n stream) (princ "#" stream)) + (puthash object (- n) cl-print--number-table) + (princ "#" stream) (princ (- n) stream) (princ "=" stream) + (cl-call-next-method))))) + +(defvar cl-print--number-index nil) + +(defun cl-print--find-sharing (object table) + ;; Avoid recursion: not only because it's too easy to bump into + ;; `max-lisp-eval-depth', but also because function calls are fairly slow. + ;; At first, I thought using a list for our stack would cause too much + ;; garbage to generated, but I didn't notice any such problem in practice. + ;; I experimented with using an array instead, but the result was slightly + ;; slower and the reduction in GC activity was less than 1% on my test. + (let ((stack (list object))) + (while stack + (let ((object (pop stack))) + (unless + ;; Skip objects which don't have identity! + (or (floatp object) (numberp object) + (null object) (if (symbolp object) (intern-soft object))) + (let ((n (gethash object table))) + (cond + ((numberp n)) ;All done. + (n ;Already seen, but only once. + (let ((n (1+ cl-print--number-index))) + (setq cl-print--number-index n) + (puthash object (- n) table))) + (t + (puthash object t table) + (pcase object + (`(,car . ,cdr) + (push cdr stack) + (push car stack)) + ((pred stringp) + ;; We presumably won't print its text-properties. + nil) + ((or (pred arrayp) (pred byte-code-function-p)) + ;; FIXME: Inefficient for char-tables! + (dotimes (i (length object)) + (push (aref object i) stack)))))))))))) + +(defun cl-print--preprocess (object) + (let ((print-number-table (make-hash-table :test 'eq :rehash-size 2.0))) + (if (fboundp 'print--preprocess) + ;; Use the predefined C version if available. + (print--preprocess object) ;Fill print-number-table! + (let ((cl-print--number-index 0)) + (cl-print--find-sharing object print-number-table))) + print-number-table)) + +;;;###autoload +(defun cl-prin1 (object &optional stream) + (cond + (cl-print-readably (prin1 object stream)) + ((not print-circle) (cl-print-object object stream)) + (t + (let ((cl-print--number-table (cl-print--preprocess object))) + (cl-print-object object stream))))) + +;;;###autoload +(defun cl-prin1-to-string (object) + (with-temp-buffer + (cl-prin1 object (current-buffer)) + (buffer-string))) + +(provide 'cl-print) +;;; cl-print.el ends here diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index 5fc9eb1d9af..67ff1a00bd3 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))) @@ -134,24 +144,24 @@ cl-accum))) ;;;###autoload -(defun cl-fill (seq item &rest cl-keys) +(defun cl-fill (cl-seq cl-item &rest cl-keys) "Fill the elements of SEQ with ITEM. \nKeywords supported: :start :end \n(fn SEQ ITEM [KEYWORD VALUE]...)" (cl--parsing-keywords ((:start 0) :end) () - (if (listp seq) - (let ((p (nthcdr cl-start seq)) - (n (if cl-end (- cl-end cl-start) 8000000))) - (while (and p (>= (setq n (1- n)) 0)) - (setcar p item) + (if (listp cl-seq) + (let ((p (nthcdr cl-start cl-seq)) + (n (and cl-end (- cl-end cl-start)))) + (while (and p (or (null n) (>= (cl-decf n) 0))) + (setcar p cl-item) (setq p (cdr p)))) - (or cl-end (setq cl-end (length seq))) - (if (and (= cl-start 0) (= cl-end (length seq))) - (fillarray seq item) + (or cl-end (setq cl-end (length cl-seq))) + (if (and (= cl-start 0) (= cl-end (length cl-seq))) + (fillarray cl-seq cl-item) (while (< cl-start cl-end) - (aset seq cl-start item) + (aset cl-seq cl-start cl-item) (setq cl-start (1+ cl-start))))) - seq)) + cl-seq)) ;;;###autoload (defun cl-replace (cl-seq1 cl-seq2 &rest cl-keys) @@ -170,16 +180,20 @@ SEQ1 is destructively modified, then returned. (elt cl-seq2 (+ cl-start2 cl-n)))))) (if (listp cl-seq1) (let ((cl-p1 (nthcdr cl-start1 cl-seq1)) - (cl-n1 (if cl-end1 (- cl-end1 cl-start1) 4000000))) + (cl-n1 (and cl-end1 (- cl-end1 cl-start1)))) (if (listp cl-seq2) (let ((cl-p2 (nthcdr cl-start2 cl-seq2)) - (cl-n (min cl-n1 - (if cl-end2 (- cl-end2 cl-start2) 4000000)))) - (while (and cl-p1 cl-p2 (>= (setq cl-n (1- cl-n)) 0)) + (cl-n (cond ((and cl-n1 cl-end2) + (min cl-n1 (- cl-end2 cl-start2))) + ((and cl-n1 (null cl-end2)) cl-n1) + ((and (null cl-n1) cl-end2) (- cl-end2 cl-start2))))) + (while (and cl-p1 cl-p2 (or (null cl-n) (>= (cl-decf cl-n) 0))) (setcar cl-p1 (car cl-p2)) (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)))) - (setq cl-end2 (min (or cl-end2 (length cl-seq2)) - (+ cl-start2 cl-n1))) + (setq cl-end2 (if (null cl-n1) + (or cl-end2 (length cl-seq2)) + (min (or cl-end2 (length cl-seq2)) + (+ cl-start2 cl-n1)))) (while (and cl-p1 (< cl-start2 cl-end2)) (setcar cl-p1 (aref cl-seq2 cl-start2)) (setq cl-p1 (cdr cl-p1) cl-start2 (1+ cl-start2))))) @@ -205,9 +219,10 @@ to avoid corrupting the original SEQ. \n(fn ITEM SEQ [KEYWORD VALUE]...)" (cl--parsing-keywords (:test :test-not :key :if :if-not :count :from-end (:start 0) :end) () - (if (<= (or cl-count (setq cl-count 8000000)) 0) + (let ((len (length cl-seq))) + (if (<= (or cl-count (setq cl-count len)) 0) cl-seq - (if (or (nlistp cl-seq) (and cl-from-end (< cl-count 4000000))) + (if (or (nlistp cl-seq) (and cl-from-end (< cl-count (/ len 2)))) (let ((cl-i (cl--position cl-item cl-seq cl-start cl-end cl-from-end))) (if cl-i @@ -219,7 +234,7 @@ to avoid corrupting the original SEQ. (if (listp cl-seq) cl-res (if (stringp cl-seq) (concat cl-res) (vconcat cl-res)))) cl-seq)) - (setq cl-end (- (or cl-end 8000000) cl-start)) + (setq cl-end (- (or cl-end len) cl-start)) (if (= cl-start 0) (while (and cl-seq (> cl-end 0) (cl--check-test cl-item (car cl-seq)) @@ -240,7 +255,7 @@ to avoid corrupting the original SEQ. :start 0 :end (1- cl-end) :count (1- cl-count) cl-keys)))) cl-seq)) - cl-seq))))) + cl-seq)))))) ;;;###autoload (defun cl-remove-if (cl-pred cl-list &rest cl-keys) @@ -268,20 +283,21 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. \n(fn ITEM SEQ [KEYWORD VALUE]...)" (cl--parsing-keywords (:test :test-not :key :if :if-not :count :from-end (:start 0) :end) () - (if (<= (or cl-count (setq cl-count 8000000)) 0) + (let ((len (length cl-seq))) + (if (<= (or cl-count (setq cl-count len)) 0) cl-seq (if (listp cl-seq) - (if (and cl-from-end (< cl-count 4000000)) + (if (and cl-from-end (< cl-count (/ len 2))) (let (cl-i) (while (and (>= (setq cl-count (1- cl-count)) 0) (setq cl-i (cl--position cl-item cl-seq cl-start - cl-end cl-from-end))) + cl-end cl-from-end))) (if (= cl-i 0) (setq cl-seq (cdr cl-seq)) (let ((cl-tail (nthcdr (1- cl-i) cl-seq))) (setcdr cl-tail (cdr (cdr cl-tail))))) (setq cl-end cl-i)) cl-seq) - (setq cl-end (- (or cl-end 8000000) cl-start)) + (setq cl-end (- (or cl-end len) cl-start)) (if (= cl-start 0) (progn (while (and cl-seq @@ -302,7 +318,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. (setq cl-p (cdr cl-p))) (setq cl-end (1- cl-end))))) cl-seq) - (apply 'cl-remove cl-item cl-seq cl-keys))))) + (apply 'cl-remove cl-item cl-seq cl-keys)))))) ;;;###autoload (defun cl-delete-if (cl-pred cl-list &rest cl-keys) @@ -337,6 +353,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. (defun cl--delete-duplicates (cl-seq cl-keys cl-copy) (if (listp cl-seq) (cl--parsing-keywords + ;; We need to parse :if, otherwise `cl-if' is unbound. (:test :test-not :key (:start 0) :end :from-end :if) () (if cl-from-end @@ -385,15 +402,17 @@ to avoid corrupting the original SEQ. (cl--parsing-keywords (:test :test-not :key :if :if-not :count (:start 0) :end :from-end) () (if (or (eq cl-old cl-new) - (<= (or cl-count (setq cl-from-end nil cl-count 8000000)) 0)) + (<= (or cl-count (setq cl-from-end nil + cl-count (length cl-seq))) 0)) cl-seq (let ((cl-i (cl--position cl-old cl-seq cl-start cl-end))) (if (not cl-i) cl-seq (setq cl-seq (copy-sequence cl-seq)) - (or cl-from-end - (progn (setf (elt cl-seq cl-i) cl-new) - (setq cl-i (1+ cl-i) cl-count (1- cl-count)))) + (unless cl-from-end + (setf (elt cl-seq cl-i) cl-new) + (cl-incf cl-i) + (cl-decf cl-count)) (apply 'cl-nsubstitute cl-new cl-old cl-seq :count cl-count :start cl-i cl-keys)))))) @@ -423,17 +442,18 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. \n(fn NEW OLD SEQ [KEYWORD VALUE]...)" (cl--parsing-keywords (:test :test-not :key :if :if-not :count (:start 0) :end :from-end) () - (or (eq cl-old cl-new) (<= (or cl-count (setq cl-count 8000000)) 0) - (if (and (listp cl-seq) (or (not cl-from-end) (> cl-count 4000000))) + (let ((len (length cl-seq))) + (or (eq cl-old cl-new) (<= (or cl-count (setq cl-count len)) 0) + (if (and (listp cl-seq) (or (not cl-from-end) (> cl-count (/ len 2)))) (let ((cl-p (nthcdr cl-start cl-seq))) - (setq cl-end (- (or cl-end 8000000) cl-start)) + (setq cl-end (- (or cl-end len) cl-start)) (while (and cl-p (> cl-end 0) (> cl-count 0)) (if (cl--check-test cl-old (car cl-p)) (progn (setcar cl-p cl-new) (setq cl-count (1- cl-count)))) (setq cl-p (cdr cl-p) cl-end (1- cl-end)))) - (or cl-end (setq cl-end (length cl-seq))) + (or cl-end (setq cl-end len)) (if cl-from-end (while (and (< cl-start cl-end) (> cl-count 0)) (setq cl-end (1- cl-end)) @@ -446,7 +466,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. (progn (aset cl-seq cl-start cl-new) (setq cl-count (1- cl-count)))) - (setq cl-start (1+ cl-start)))))) + (setq cl-start (1+ cl-start))))))) cl-seq)) ;;;###autoload @@ -502,14 +522,13 @@ Return the index of the matching item, or nil if not found. (defun cl--position (cl-item cl-seq cl-start &optional cl-end cl-from-end) (if (listp cl-seq) - (let ((cl-p (nthcdr cl-start cl-seq))) - (or cl-end (setq cl-end 8000000)) - (let ((cl-res nil)) - (while (and cl-p (< cl-start cl-end) (or (not cl-res) cl-from-end)) + (let ((cl-p (nthcdr cl-start cl-seq)) + cl-res) + (while (and cl-p (or (null cl-end) (< cl-start cl-end)) (or (null cl-res) cl-from-end)) (if (cl--check-test cl-item (car cl-p)) (setq cl-res cl-start)) (setq cl-p (cdr cl-p) cl-start (1+ cl-start))) - cl-res)) + cl-res) (or cl-end (setq cl-end (length cl-seq))) (if cl-from-end (progn diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index a37faf99114..73eb9a4e866 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -154,7 +154,6 @@ every some mapcon - mapcan mapl maplist map @@ -259,30 +258,6 @@ copy-list ldiff list* - cddddr - cdddar - cddadr - cddaar - cdaddr - cdadar - cdaadr - cdaaar - cadddr - caddar - cadadr - cadaar - caaddr - caadar - caaadr - caaaar - cdddr - cddar - cdadr - cdaar - caddr - cadar - caadr - caaar tenth ninth eighth @@ -365,7 +340,7 @@ The two cases that are handled are: `(list 'lambda '(&rest --cl-rest--) ,@(cl-sublis sub (nreverse decls)) (list 'apply - (list 'quote + (list 'function #'(lambda ,(append new (cadr f)) ,@(cl-sublis sub body))) ,@(nconc (mapcar (lambda (x) `(list 'quote ,x)) diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index c969b8253fe..cb77148c285 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -274,13 +274,14 @@ That buffer should be current already." (let ((standard-output (current-buffer)) (print-escape-newlines t) (print-level 8) - (print-length 50)) - (backtrace)) + (print-length 50)) + ;; FIXME the debugger could pass a custom callback to mapbacktrace + ;; instead of manipulating printed results. + (mapbacktrace #'backtrace--print-frame 'debug)) (goto-char (point-min)) (delete-region (point) (progn - (search-forward "\n debug(") - (forward-line (if (eq (car args) 'debug) + (forward-line (if (eq (car args) 'debug) ;; Remove debug--implement-debug-on-entry ;; and the advice's `apply' frame. 3 @@ -304,6 +305,24 @@ That buffer should be current already." (delete-char 1) (insert ? ) (beginning-of-line)) + ;; Watchpoint triggered. + ((and `watchpoint (let `(,symbol ,newval . ,details) (cdr args))) + (insert + "--" + (pcase details + (`(makunbound nil) (format "making %s void" symbol)) + (`(makunbound ,buffer) (format "killing local value of %s in buffer %s" + symbol buffer)) + (`(defvaralias ,_) (format "aliasing %s to %s" symbol newval)) + (`(let ,_) (format "let-binding %s to %S" symbol newval)) + (`(unlet ,_) (format "ending let-binding of %s" symbol)) + (`(set nil) (format "setting %s to %S" symbol newval)) + (`(set ,buffer) (format "setting %s in buffer %s to %S" + symbol buffer newval)) + (_ (error "unrecognized watchpoint triggered %S" (cdr args)))) + ": ") + (setq pos (point)) + (insert ?\n)) ;; Debugger entered for an error. (`error (insert "--Lisp error: ") @@ -848,6 +867,79 @@ To specify a nil argument interactively, exit with an empty minibuffer." (princ "Note: if you have redefined a function, then it may no longer\n") (princ "be set to debug on entry, even if it is in the list.")))))) +(defun debug--implement-debug-watch (symbol newval op where) + "Conditionally call the debugger. +This function is called when SYMBOL's value is modified." + (if (or inhibit-debug-on-entry debugger-jumping-flag) + nil + (let ((inhibit-debug-on-entry t)) + (funcall debugger 'watchpoint symbol newval op where)))) + +;;;###autoload +(defun debug-on-variable-change (variable) + "Trigger a debugger invocation when VARIABLE is changed. + +When called interactively, prompt for VARIABLE in the minibuffer. + +This works by calling `add-variable-watch' on VARIABLE. If you +quit from the debugger, this will abort the change (unless the +change is caused by the termination of a let-binding). + +The watchpoint may be circumvented by C code that changes the +variable directly (i.e., not via `set'). Changing the value of +the variable (e.g., `setcar' on a list variable) will not trigger +watchpoint. + +Use \\[cancel-debug-on-variable-change] to cancel the effect of +this command. Uninterning VARIABLE or making it an alias of +another symbol also cancels it." + (interactive + (let* ((var-at-point (variable-at-point)) + (var (and (symbolp var-at-point) var-at-point)) + (val (completing-read + (concat "Debug when setting variable" + (if var (format " (default %s): " var) ": ")) + obarray #'boundp + t nil nil (and var (symbol-name var))))) + (list (if (equal val "") var (intern val))))) + (add-variable-watcher variable #'debug--implement-debug-watch)) + +;;;###autoload +(defalias 'debug-watch #'debug-on-variable-change) + + +(defun debug--variable-list () + "List of variables currently set for debug on set." + (let ((vars '())) + (mapatoms + (lambda (s) + (when (memq #'debug--implement-debug-watch + (get s 'watchers)) + (push s vars)))) + vars)) + +;;;###autoload +(defun cancel-debug-on-variable-change (&optional variable) + "Undo effect of \\[debug-on-variable-change] on VARIABLE. +If VARIABLE is nil, cancel debug-on-variable-change for all variables. +When called interactively, prompt for VARIABLE in the minibuffer. +To specify a nil argument interactively, exit with an empty minibuffer." + (interactive + (list (let ((name + (completing-read + "Cancel debug on set for variable (default all variables): " + (mapcar #'symbol-name (debug--variable-list)) nil t))) + (when name + (unless (string= name "") + (intern name)))))) + (if variable + (remove-variable-watcher variable #'debug--implement-debug-watch) + (message "Canceling debug-watch for all variables") + (mapc #'cancel-debug-watch (debug--variable-list)))) + +;;;###autoload +(defalias 'cancel-debug-watch #'cancel-debug-on-variable-change) + (provide 'debug) ;;; debug.el ends here diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index c73d2f0bf63..fffe972460c 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 @@ -211,17 +216,20 @@ No problems result if this variable is not bound. (purecopy ,(format "Keymap for `%s'." child)))) ,(if declare-syntax `(progn + (defvar ,syntax) (unless (boundp ',syntax) - (put ',syntax 'definition-name ',child)) - (defvar ,syntax (make-syntax-table)) + (put ',syntax 'definition-name ',child) + (defvar ,syntax (make-syntax-table))) (unless (get ',syntax 'variable-documentation) (put ',syntax 'variable-documentation (purecopy ,(format "Syntax table for `%s'." child)))))) ,(if declare-abbrev `(progn - (put ',abbrev 'definition-name ',child) - (defvar ,abbrev - (progn (define-abbrev-table ',abbrev nil) ,abbrev)) + (defvar ,abbrev) + (unless (boundp ',abbrev) + (put ',abbrev 'definition-name ',child) + (defvar ,abbrev + (progn (define-abbrev-table ',abbrev nil) ,abbrev))) (unless (get ',abbrev 'variable-documentation) (put ',abbrev 'variable-documentation (purecopy ,(format "Abbrev table for `%s'." child)))))) @@ -272,7 +280,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 +356,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/disass.el b/lisp/emacs-lisp/disass.el index 97e45e070d0..66673b4d26c 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -221,9 +221,21 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." ((memq op '(byte-constant byte-constant2)) ;; it's a constant (setq arg (car arg)) - ;; but if the value of the constant is compiled code, then - ;; recursively disassemble it. - (cond ((or (byte-code-function-p arg) + ;; if the succeeding op is byte-switch, display the jump table + ;; used + (cond ((eq (car-safe (car-safe (cdr lap))) 'byte-switch) + (insert (format "<jump-table-%s (" (hash-table-test arg))) + (let ((first-time t)) + (maphash #'(lambda (value tag) + (if first-time + (setq first-time nil) + (insert " ")) + (insert (format "%s %s" value (cadr tag)))) + arg)) + (insert ")>")) + ;; if the value of the constant is compiled code, then + ;; recursively disassemble it. + ((or (byte-code-function-p arg) (and (consp arg) (functionp arg) (assq 'byte-code arg)) (and (eq (car-safe arg) 'macro) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index df1f893288c..60133055623 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -112,6 +112,18 @@ and some not, use `def-edebug-spec' to specify an `edebug-form-spec'." :type 'boolean :group 'edebug) +(defcustom edebug-max-depth 150 + "Maximum recursion depth when instrumenting code. +This limit is intended to stop recursion if an Edebug specification +contains an infinite loop. When Edebug is instrumenting code +containing very large quoted lists, it may reach this limit and give +the error message \"Too deep - perhaps infinite loop in spec?\". +Make this limit larger to countermand that, but you may also need to +increase `max-lisp-eval-depth' and `max-specpdl-size'." + :type 'integer + :group 'edebug + :version "26.1") + (defcustom edebug-save-windows t "If non-nil, Edebug saves and restores the window configuration. That takes some time, so if your program does not care what happens to @@ -233,6 +245,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 "26.1") + ;;; Form spec utilities. (defun get-edebug-spec (symbol) @@ -380,31 +398,30 @@ Return the result of the last expression in BODY." (defun edebug-current-windows (which-windows) ;; Get either a full window configuration or some window information. (if (listp which-windows) - (mapcar (function (lambda (window) - (if (edebug-window-live-p window) - (list window - (window-buffer window) - (window-point window) - (window-start window) - (window-hscroll window))))) + (mapcar (lambda (window) + (if (edebug-window-live-p window) + (list window + (window-buffer window) + (window-point window) + (window-start window) + (window-hscroll window)))) which-windows) (current-window-configuration))) (defun edebug-set-windows (window-info) ;; Set either a full window configuration or some window information. (if (listp window-info) - (mapcar (function - (lambda (one-window-info) - (if one-window-info - (apply (function - (lambda (window buffer point start hscroll) - (if (edebug-window-live-p window) - (progn - (set-window-buffer window buffer) - (set-window-point window point) - (set-window-start window start) - (set-window-hscroll window hscroll))))) - one-window-info)))) + (mapcar (lambda (one-window-info) + (if one-window-info + (apply (function + (lambda (window buffer point start hscroll) + (if (edebug-window-live-p window) + (progn + (set-window-buffer window buffer) + (set-window-point window point) + (set-window-start window start) + (set-window-hscroll window hscroll))))) + one-window-info))) window-info) (set-window-configuration window-info))) @@ -640,7 +657,7 @@ Maybe clear the markers and delete the symbol's edebug property?" (progn ;; Instead of this, we could just find all contained forms. ;; (put (car entry) 'edebug nil) ; - ;; (mapcar 'edebug-clear-form-data-entry ; dangerous + ;; (mapcar #'edebug-clear-form-data-entry ; dangerous ;; (get (car entry) 'edebug-dependents)) ;; (set-marker (nth 1 entry) nil) ;; (set-marker (nth 2 entry) nil) @@ -737,6 +754,11 @@ Maybe clear the markers and delete the symbol's edebug property?" (defvar edebug-offsets-stack nil) (defvar edebug-current-offset nil) ; Top of the stack, for convenience. +;; The association list of objects read with the #n=object form. +;; Each member of the list has the form (n . object), and is used to +;; look up the object for the corresponding #n# construct. +(defvar edebug-read-objects nil) + ;; We must store whether we just read a list with a dotted form that ;; is itself a list. This structure will be condensed, so the offsets ;; must also be condensed. @@ -808,7 +830,7 @@ Maybe clear the markers and delete the symbol's edebug property?" (backquote . edebug-read-backquote) (comma . edebug-read-comma) (lbracket . edebug-read-vector) - (hash . edebug-read-function) + (hash . edebug-read-special) )) (defun edebug-read-storing-offsets (stream) @@ -854,19 +876,47 @@ Maybe clear the markers and delete the symbol's edebug property?" (edebug-storing-offsets opoint symbol) (edebug-read-storing-offsets stream))))) -(defun edebug-read-function (stream) - ;; Turn #'thing into (function thing) - (forward-char 1) - (cond ((eq ?\' (following-char)) - (forward-char 1) - (list - (edebug-storing-offsets (- (point) 2) 'function) - (edebug-read-storing-offsets stream))) - ((memq (following-char) '(?: ?B ?O ?X ?b ?o ?x ?1 ?2 ?3 ?4 ?5 ?6 - ?7 ?8 ?9 ?0)) - (backward-char 1) - (read stream)) - (t (edebug-syntax-error "Bad char after #")))) +(defun edebug-read-special (stream) + "Read from STREAM a Lisp object beginning with #. +Turn #'thing into (function thing) and handle the read syntax for +circular objects. Let `read' read everything else." + (catch 'return + (forward-char 1) + (let ((start (point))) + (cond + ((eq ?\' (following-char)) + (forward-char 1) + (throw 'return + (list + (edebug-storing-offsets (- (point) 2) 'function) + (edebug-read-storing-offsets stream)))) + ((and (>= (following-char) ?0) (<= (following-char) ?9)) + (while (and (>= (following-char) ?0) (<= (following-char) ?9)) + (forward-char 1)) + (let ((n (string-to-number (buffer-substring start (point))))) + (when (and read-circle + (<= n most-positive-fixnum)) + (cond + ((eq ?= (following-char)) + ;; Make a placeholder for #n# to use temporarily. + (let* ((placeholder (cons nil nil)) + (elem (cons n placeholder))) + (push elem edebug-read-objects) + ;; Read the object and then replace the placeholder + ;; with the object itself, wherever it occurs. + (forward-char 1) + (let ((obj (edebug-read-storing-offsets stream))) + (substitute-object-in-subtree obj placeholder) + (throw 'return (setf (cdr elem) obj))))) + ((eq ?# (following-char)) + ;; #n# returns a previously read object. + (let ((elem (assq n edebug-read-objects))) + (when (consp elem) + (forward-char 1) + (throw 'return (cdr elem)))))))))) + ;; Let read handle errors, radix notation, and anything else. + (goto-char (1- start)) + (read stream)))) (defun edebug-read-list (stream) (forward-char 1) ; skip \( @@ -894,7 +944,7 @@ Maybe clear the markers and delete the symbol's edebug property?" (let ((elements)) (while (not (eq 'rbracket (edebug-next-token-class))) (push (edebug-read-storing-offsets stream) elements)) - (apply 'vector (nreverse elements))) + (apply #'vector (nreverse elements))) (forward-char 1) ; skip \] )) @@ -937,7 +987,7 @@ Maybe clear the markers and delete the symbol's edebug property?" ;; Check if a dotted form is required. (if edebug-dotted-spec (edebug-no-match cursor "Dot expected.")) ;; Check if there is at least one more argument. - (if (edebug-empty-cursor cursor) (apply 'edebug-no-match cursor error)) + (if (edebug-empty-cursor cursor) (apply #'edebug-no-match cursor error)) ;; Return that top element. (edebug-top-element cursor)) @@ -1044,7 +1094,7 @@ Maybe clear the markers and delete the symbol's edebug property?" (setq result (edebug-read-and-maybe-wrap-form1)) nil))) (if no-match - (apply 'edebug-syntax-error no-match))) + (apply #'edebug-syntax-error no-match))) result)) @@ -1058,6 +1108,7 @@ Maybe clear the markers and delete the symbol's edebug property?" edebug-offsets edebug-offsets-stack edebug-current-offset ; reset to nil + edebug-read-objects ) (save-excursion (if (and (eq 'lparen (edebug-next-token-class)) @@ -1203,7 +1254,7 @@ expressions; a `progn' form will be returned enclosing these forms." (setq sexp new-sexp new-sexp (edebug-unwrap sexp))) (if (consp new-sexp) - (mapcar 'edebug-unwrap* new-sexp) + (mapcar #'edebug-unwrap* new-sexp) new-sexp))) @@ -1446,7 +1497,6 @@ expressions; a `progn' form will be returned enclosing these forms." (defvar edebug-after-dotted-spec nil) (defvar edebug-matching-depth 0) ;; initial value -(defconst edebug-max-depth 150) ;; maximum number of matching recursions. ;;; Failure to match @@ -1465,7 +1515,7 @@ expressions; a `progn' form will be returned enclosing these forms." (progn (if edebug-error-point (goto-char edebug-error-point)) - (apply 'edebug-syntax-error args)) + (apply #'edebug-syntax-error args)) (throw 'no-match args))) @@ -1661,7 +1711,7 @@ expressions; a `progn' form will be returned enclosing these forms." ;; Reset the cursor for the next match. (edebug-set-cursor cursor this-form this-offset)) ;; All failed. - (apply 'edebug-no-match cursor "Expected one of" original-specs)) + (apply #'edebug-no-match cursor "Expected one of" original-specs)) )) @@ -1687,9 +1737,9 @@ expressions; a `progn' form will be returned enclosing these forms." (edebug-match-&rest cursor (cons '&or - (mapcar (function (lambda (pair) - (vector (format ":%s" (car pair)) - (car (cdr pair))))) + (mapcar (lambda (pair) + (vector (format ":%s" (car pair)) + (car (cdr pair)))) specs)))) @@ -1734,7 +1784,7 @@ expressions; a `progn' form will be returned enclosing these forms." form (cdr (edebug-top-offset cursor))) (cdr specs)))) (edebug-move-cursor cursor) - (list (apply 'vector result))) + (list (apply #'vector result))) (edebug-no-match cursor "Expected" specs))) ((listp form) @@ -1761,7 +1811,7 @@ expressions; a `progn' form will be returned enclosing these forms." (edebug-match-specs cursor specs 'edebug-match-specs) (if (not (edebug-empty-cursor cursor)) (if edebug-best-error - (apply 'edebug-no-match cursor edebug-best-error) + (apply #'edebug-no-match cursor edebug-best-error) ;; A failed &rest or &optional spec may leave some args. (edebug-no-match cursor "Failed matching" specs) ))))) @@ -1927,6 +1977,7 @@ expressions; a `progn' form will be returned enclosing these forms." (def-edebug-spec defun (&define name lambda-list [&optional stringp] + [&optional ("declare" &rest sexp)] [&optional ("interactive" interactive)] def-body)) (def-edebug-spec defmacro @@ -2163,8 +2214,7 @@ The purpose of this function is so you can properly undo subsequent changes to the same binding, by passing the status cons cell to `edebug-restore-status'. The status cons cell has the form (LOCUS . VALUE), where LOCUS can be a buffer -\(for a buffer-local binding), a frame (for a frame-local binding), -or nil (if the default binding is current)." +\(for a buffer-local binding), or nil (if the default binding is current)." (cons (variable-binding-locus var) (symbol-value var))) @@ -2356,7 +2406,7 @@ MSG is printed after `::::} '." (defvar edebug-window-data) ; window and window-start for current function (defvar edebug-outside-windows) ; outside window configuration (defvar edebug-eval-buffer) ; for the evaluation list. -(defvar edebug-outside-d-c-i-n-s-w) ; outside default-cursor-in-non-selected-windows +(defvar edebug-outside-d-c-i-n-s-w) ; outside default cursor-in-non-selected-windows (defvar edebug-eval-list nil) ;; List of expressions to evaluate. @@ -2489,6 +2539,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))) @@ -3325,10 +3376,10 @@ Return the result of the last expression." (message "%s: %s" (or (get (car value) 'error-message) (format "peculiar error (%s)" (car value))) - (mapconcat (function (lambda (edebug-arg) - ;; continuing after an error may - ;; complain about edebug-arg. why?? - (prin1-to-string edebug-arg))) + (mapconcat (lambda (edebug-arg) + ;; continuing after an error may + ;; complain about edebug-arg. why?? + (prin1-to-string edebug-arg)) (cdr value) ", "))) (defvar print-readably) ; defined by lemacs @@ -3359,11 +3410,9 @@ Return the result of the last expression." ;;; Read, Eval and Print -(defalias 'edebug-prin1 'prin1) -(defalias 'edebug-print 'print) -(defalias 'edebug-prin1-to-string 'prin1-to-string) -(defalias 'edebug-format 'format-message) -(defalias 'edebug-message 'message) +(defalias 'edebug-prin1-to-string #'cl-prin1-to-string) +(defalias 'edebug-format #'format-message) +(defalias 'edebug-message #'message) (defun edebug-eval-expression (expr) "Evaluate an expression in the outside environment. @@ -3604,7 +3653,7 @@ Options: ;; Don't do any edebug things now. (let ((edebug-execution-mode 'Go-nonstop) (edebug-trace nil)) - (mapcar 'edebug-safe-eval edebug-eval-list))) + (mapcar #'edebug-safe-eval edebug-eval-list))) (defun edebug-eval-display-list (eval-result-list) ;; Assumes edebug-eval-buffer exists. @@ -3752,7 +3801,7 @@ Otherwise call `debug' normally." ;; Otherwise call debug normally. ;; Still need to remove extraneous edebug calls from stack. - (apply 'debug arg-mode args) + (apply #'debug arg-mode args) )) @@ -3790,7 +3839,9 @@ Otherwise call `debug' normally." (forward-line 1) (delete-region last-ok-point (point))) - ((looking-at "^ edebug") + ((looking-at (if debugger-stack-frame-as-list + "^ (edebug" + "^ edebug")) (forward-line 1) (delete-region last-ok-point (point)) ))) @@ -3816,7 +3867,7 @@ You must include newlines in FMT to break lines, but one newline is appended." (setq truncate-lines t) (setq buf-window (selected-window)) (goto-char (point-max)) - (insert (apply 'edebug-format fmt args) "\n") + (insert (apply #'edebug-format fmt args) "\n") ;; Make it visible. (vertical-motion (- 1 (window-height))) (set-window-start buf-window (point)) @@ -3831,7 +3882,7 @@ You must include newlines in FMT to break lines, but one newline is appended." (defun edebug-trace (fmt &rest args) "Convenience call to `edebug-trace-display' using `edebug-trace-buffer'." - (apply 'edebug-trace-display edebug-trace-buffer fmt args)) + (apply #'edebug-trace-display edebug-trace-buffer fmt args)) ;;; Frequency count and coverage diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el index 83409ef100b..888d85f6038 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 111fbca3aa0..5cc6d020eaf 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" "e91175056972ff549f07b83740ad04eb") -;;; 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 38670253325..e82eaa2b01f 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-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el index 624757f229a..8ef92df513e 100644 --- a/lisp/emacs-lisp/eieio-datadebug.el +++ b/lisp/emacs-lisp/eieio-datadebug.el @@ -59,7 +59,7 @@ PREFIX is the text that precedes the button. PREBUTTONTEXT is some text between PREFIX and the object button." (let* ((start (point)) (end nil) - (str (object-print object)) + (str (cl-prin1-to-string object)) (class (eieio-object-class object)) (tip (format "Object %s\nClass: %S\nParent(s): %S\n%d slots" (eieio-object-name-string object) diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index d614c71a32b..ba4331f126b 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 1a1ad88f975..1a6d5e9d7c1 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 "26.1") (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,20 @@ 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 "26.1")) ;; 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." + (declare (obsolete cl-print-object "26.1")) + (format "%S" this)) (cl-defmethod object-print ((this eieio-default-superclass) &rest strings) "Pretty printer for object THIS. Call function `object-name' with STRINGS. @@ -846,6 +842,12 @@ When passing in extra strings from child classes, always remember to prepend a space." (eieio-object-name this (apply #'concat strings))) + +(cl-defmethod cl-print-object ((object eieio-default-superclass) stream) + "Default printer for EIEIO objects." + ;; Fallback to the old `object-print'. + (princ (object-print object) stream)) + (defvar eieio-print-depth 0 "When printing, keep track of the current indentation depth.") @@ -938,73 +940,18 @@ 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 "26.1") ;; Hook ourselves into help system for describing classes and methods. ;; FIXME: This is not actually needed any more since we can click on the ;; hyperlink from the constructor's docstring to see the type definition. (add-hook 'help-fns-describe-function-functions 'eieio-help-constructor) -;;; Interfacing with edebug -;; -(defun eieio-edebug-prin1-to-string (print-function object &optional noescape) - "Display EIEIO OBJECT in fancy format. - -Used as advice around `edebug-prin1-to-string', held in the -variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to -`prin1-to-string' when appropriate." - (cond ((eieio--class-p object) (eieio--class-print-name object)) - ((eieio-object-p object) (object-print object)) - ((and (listp object) (or (eieio--class-p (car object)) - (eieio-object-p (car object)))) - (concat "(" (mapconcat - (lambda (x) (eieio-edebug-prin1-to-string print-function x)) - object " ") - ")")) - (t (funcall print-function object noescape)))) - -(advice-add 'edebug-prin1-to-string - :around #'eieio-edebug-prin1-to-string) - - -;;; Start of automatically extracted autoloads. - -;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "5a754881773067a24cfcfc6dcff91995") -;;; 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" "04b22dbeb00abbaba0b1ae17b1935a36") -;;; 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 87e90ac080d..6cb8e6ce480 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/elint.el b/lisp/emacs-lisp/elint.el index 64d96d9847e..cce9553ff6a 100644 --- a/lisp/emacs-lisp/elint.el +++ b/lisp/emacs-lisp/elint.el @@ -1,4 +1,4 @@ -;;; elint.el --- Lint Emacs Lisp +;;; elint.el --- Lint Emacs Lisp -*- lexical-binding: t -*- ;; Copyright (C) 1997, 2001-2017 Free Software Foundation, Inc. @@ -27,7 +27,7 @@ ;; misspellings and undefined variables, although it can also catch ;; function calls with the wrong number of arguments. -;; To use, call elint-current-buffer or elint-defun to lint a buffer +;; To use, call `elint-current-buffer' or `elint-defun' to lint a buffer ;; or defun. The first call runs `elint-initialize' to set up some ;; argument data, which may take a while. @@ -154,6 +154,9 @@ Set by `elint-initialize', if `elint-scan-preloaded' is non-nil.") "Regexp matching elements of `preloaded-file-list' to ignore. We ignore them because they contain no definitions of use to Elint.") +(defvar elint-running) +(defvar elint-current-pos) ; dynamically bound in elint-top-form + ;;; ;;; ADT: top-form ;;; @@ -372,7 +375,7 @@ Returns the forms." (let ((elint-current-pos (point))) ;; non-list check could be here too. errors may be out of seq. ;; quoted check cannot be elsewhere, since quotes skipped. - (if (looking-back "'" (1- (point))) + (if (= (preceding-char) ?\') ;; Eg cust-print.el uses ' as a comment syntax. (elint-warning "Skipping quoted form `%c%.20s...'" ?\' (read (current-buffer))) @@ -862,7 +865,7 @@ CODE can be a lambda expression, a macro, or byte-compiled code." (t (elint-error "Not a function object: %s" form) env)))) -(defun elint-check-quote-form (form env) +(defun elint-check-quote-form (_form env) "Lint the quote FORM in ENV." env) @@ -903,8 +906,7 @@ CODE can be a lambda expression, a macro, or byte-compiled code." "Check the when/unless/and/or FORM in ENV. Does basic handling of `featurep' tests." (let ((func (car form)) - (test (cadr form)) - sym) + (test (cadr form))) ;; Misses things like (and t (featurep 'xemacs)) ;; Check byte-compile-maybe-guarded. (cond ((and (memq func '(when and)) @@ -967,8 +969,6 @@ Does basic handling of `featurep' tests." ;;; Message functions ;;; -(defvar elint-current-pos) ; dynamically bound in elint-top-form - (defun elint-log (type string args) (elint-log-message (format "%s:%d:%s: %s" (let ((f (buffer-file-name))) @@ -1038,8 +1038,6 @@ Insert HEADER followed by a blank line if non-nil." (display-buffer (elint-get-log-buffer)) (sit-for 0))) -(defvar elint-running) - (defun elint-set-mode-line (&optional on) "Set the mode-line-process of the Elint log buffer." (with-current-buffer (elint-get-log-buffer) diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index 7d99cb30274..4cf9d9609e9 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -97,7 +97,7 @@ To be used in ERT tests. If BODY finishes successfully, the test buffer is killed; if there is an error, the test buffer is kept around on error for further inspection. Its name is derived from the name of the test and the result of NAME-FORM." - (declare (debug ((form) body)) + (declare (debug ((":name" form) body)) (indent 1)) `(ert--call-with-test-buffer ,name-form (lambda () ,@body))) @@ -285,6 +285,30 @@ BUFFER defaults to current buffer. Does not modify BUFFER." (kill-buffer clone))))))) +(defmacro ert-with-message-capture (var &rest body) + "Execute BODY while collecting anything written with `message' in VAR. + +Capture all messages produced by `message' when it is called from +Lisp, and concatenate them separated by newlines into one string. + +This is useful for separating the issuance of messages by the +code under test from the behavior of the *Messages* buffer." + (declare (debug (symbolp body)) + (indent 1)) + (let ((g-advice (cl-gensym))) + `(let* ((,var "") + (,g-advice (lambda (func &rest args) + (if (or (null args) (equal (car args) "")) + (apply func args) + (let ((msg (apply #'format-message args))) + (setq ,var (concat ,var msg "\n")) + (funcall func "%s" msg)))))) + (advice-add 'message :around ,g-advice) + (unwind-protect + (progn ,@body) + (advice-remove 'message ,g-advice))))) + + (provide 'ert-x) ;;; ert-x.el ends here diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 60916f4bed5..cadd66ca6ed 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -276,11 +276,12 @@ DATA is displayed to the user and should state the reason for skipping." (defun ert--expand-should-1 (whole form inner-expander) "Helper function for the `should' macro and its variants." (let ((form - (macroexpand form (cond - ((boundp 'macroexpand-all-environment) - macroexpand-all-environment) - ((boundp 'cl-macro-environment) - cl-macro-environment))))) + (macroexpand form (append byte-compile-macro-environment + (cond + ((boundp 'macroexpand-all-environment) + macroexpand-all-environment) + ((boundp 'cl-macro-environment) + cl-macro-environment)))))) (cond ((or (atom form) (ert--special-operator-p (car form))) (let ((value (cl-gensym "value-"))) @@ -1470,7 +1471,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 +1491,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 +1518,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))))) @@ -2057,14 +2079,23 @@ and how to display message." '("ERT Results" ["Re-run all tests" ert-results-rerun-all-tests] "--" - ["Re-run test" ert-results-rerun-test-at-point] - ["Debug test" ert-results-rerun-test-at-point-debugging-errors] - ["Show test definition" ert-results-find-test-at-point-other-window] + ;; FIXME? Why are there (at least) 3 different ways to decide if + ;; there is a test at point? + ["Re-run test" ert-results-rerun-test-at-point + :active (car (ert--results-test-at-point-allow-redefinition))] + ["Debug test" ert-results-rerun-test-at-point-debugging-errors + :active (car (ert--results-test-at-point-allow-redefinition))] + ["Show test definition" ert-results-find-test-at-point-other-window + :active (ert-test-at-point)] "--" - ["Show backtrace" ert-results-pop-to-backtrace-for-test-at-point] - ["Show messages" ert-results-pop-to-messages-for-test-at-point] - ["Show `should' forms" ert-results-pop-to-should-forms-for-test-at-point] - ["Describe test" ert-results-describe-test-at-point] + ["Show backtrace" ert-results-pop-to-backtrace-for-test-at-point + :active (ert--results-test-at-point-no-redefinition)] + ["Show messages" ert-results-pop-to-messages-for-test-at-point + :active (ert--results-test-at-point-no-redefinition)] + ["Show `should' forms" ert-results-pop-to-should-forms-for-test-at-point + :active (ert--results-test-at-point-no-redefinition)] + ["Describe test" ert-results-describe-test-at-point + :active (ert--results-test-at-point-no-redefinition)] "--" ["Delete test" ert-delete-test] "--" @@ -2215,22 +2246,24 @@ To be used in the ERT results buffer." (and (ert-test-boundp sym) sym)))) -(defun ert--results-test-at-point-no-redefinition () +(defun ert--results-test-at-point-no-redefinition (&optional error) "Return the test at point, or nil. - +If optional argument ERROR is non-nil, signal an error rather than return nil. To be used in the ERT results buffer." (cl-assert (eql major-mode 'ert-results-mode)) - (if (ert--results-test-node-or-null-at-point) - (let* ((node (ert--results-test-node-at-point)) - (test (ert--ewoc-entry-test (ewoc-data node)))) - test) - (let ((progress-bar-begin ert--results-progress-bar-button-begin)) - (when (and (<= progress-bar-begin (point)) - (< (point) (button-end (button-at progress-bar-begin)))) - (let* ((test-index (- (point) progress-bar-begin)) - (test (aref (ert--stats-tests ert--results-stats) + (or + (if (ert--results-test-node-or-null-at-point) + (let* ((node (ert--results-test-node-at-point)) + (test (ert--ewoc-entry-test (ewoc-data node)))) + test) + (let ((progress-bar-begin ert--results-progress-bar-button-begin)) + (when (and (<= progress-bar-begin (point)) + (< (point) (button-end (button-at progress-bar-begin)))) + (let* ((test-index (- (point) progress-bar-begin)) + (test (aref (ert--stats-tests ert--results-stats) test-index))) - test))))) + test)))) + (if error (user-error "No test at point")))) (defun ert--results-test-at-point-allow-redefinition () "Look up the test at point, and check whether it has been redefined. @@ -2355,7 +2388,7 @@ To be used in the ERT results buffer." To be used in the ERT results buffer." (interactive) - (let* ((test (ert--results-test-at-point-no-redefinition)) + (let* ((test (ert--results-test-at-point-no-redefinition t)) (stats ert--results-stats) (pos (ert--stats-test-pos stats test)) (result (aref (ert--stats-test-results stats) pos))) @@ -2384,7 +2417,7 @@ To be used in the ERT results buffer." To be used in the ERT results buffer." (interactive) - (let* ((test (ert--results-test-at-point-no-redefinition)) + (let* ((test (ert--results-test-at-point-no-redefinition t)) (stats ert--results-stats) (pos (ert--stats-test-pos stats test)) (result (aref (ert--stats-test-results stats) pos))) @@ -2405,7 +2438,7 @@ To be used in the ERT results buffer." To be used in the ERT results buffer." (interactive) - (let* ((test (ert--results-test-at-point-no-redefinition)) + (let* ((test (ert--results-test-at-point-no-redefinition t)) (stats ert--results-stats) (pos (ert--stats-test-pos stats test)) (result (aref (ert--stats-test-results stats) pos))) @@ -2460,7 +2493,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))))) @@ -2532,7 +2565,7 @@ To be used in the ERT results buffer." To be used in the ERT results buffer." (interactive) - (ert-describe-test (ert--results-test-at-point-no-redefinition))) + (ert-describe-test (ert--results-test-at-point-no-redefinition t))) ;;; Actions on load/unload. diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 82132f27ff6..6699e3fd2b1 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,15 +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 - (prog1 - (switch-to-buffer buf) - (run-hooks 'find-function-after-hook)) - (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 17bf7fb37fc..cf82fe3ec63 100644 --- a/lisp/emacs-lisp/let-alist.el +++ b/lisp/emacs-lisp/let-alist.el @@ -2,13 +2,16 @@ ;; Copyright (C) 2014-2017 Free Software Foundation, Inc. -;; Author: Artur Malabarba <bruce.connor.am@gmail.com> -;; Maintainer: Artur Malabarba <bruce.connor.am@gmail.com> -;; Version: 1.0.4 +;; Author: Artur Malabarba <emacs@endlessparentheses.com> +;; Package-Requires: ((emacs "24.1")) +;; Version: 1.0.5 ;; 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 @@ -73,6 +76,11 @@ symbol, and each cdr is the same symbol without the `.'." ;; with other results in the clause below. (list (cons data (intern (replace-match "" nil nil name))))))) ((not (consp data)) nil) + ((eq (car data) 'let-alist) + ;; For nested ‘let-alist’ forms, ignore symbols appearing in the + ;; inner body because they don’t refer to the alist currently + ;; being processed. See Bug#24641. + (let-alist--deep-dot-search (cadr data))) (t (append (let-alist--deep-dot-search (car data)) (let-alist--deep-dot-search (cdr data)))))) @@ -134,7 +142,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 24e9dc63ec3..eb07c18b03d 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. @@ -409,6 +411,19 @@ This will generate compile-time constants from BINDINGS." ;; Words inside \\[] tend to be for `substitute-command-keys'. (,(concat "\\\\\\\\\\[\\(" lisp-mode-symbol-regexp "\\)\\]") (1 font-lock-constant-face prepend)) + ;; Ineffective backslashes (typically in need of doubling). + ("\\(\\\\\\)\\([^\"\\]\\)" + (1 (let ((ppss (save-excursion (syntax-ppss (match-beginning 0))))) + (and (nth 3 ppss) ;Inside a string. + (not (nth 5 ppss)) ;The \ is not itself \-escaped. + (equal (ignore-errors + (car (read-from-string + (format "\"%s\"" + (match-string-no-properties 0))))) + (match-string-no-properties 2)) + `(face ,font-lock-warning-face + help-echo "This \\ has no effect"))) + prepend)) ;; Words inside ‘’ and `' tend to be symbol names. (,(concat "[`‘]\\(\\(?:\\sw\\|\\s_\\|\\\\.\\)" lisp-mode-symbol-regexp "\\)['’]") @@ -594,7 +609,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 +670,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 @@ -1057,103 +1069,83 @@ Lisp function does not specify a special indentation." If optional arg ENDPOS is given, indent each line, stopping when ENDPOS is encountered." (interactive) - (let ((indent-stack (list nil)) - (next-depth 0) - ;; If ENDPOS is non-nil, use nil as STARTING-POINT - ;; so that calculate-lisp-indent will find the beginning of - ;; the defun we are in. - ;; If ENDPOS is nil, it is safe not to scan before point - ;; since every line we indent is more deeply nested than point is. - (starting-point (if endpos nil (point))) - (last-point (point)) - last-depth bol outer-loop-done inner-loop-done state this-indent) - (or endpos - ;; Get error now if we don't have a complete sexp after point. - (save-excursion (forward-sexp 1))) + (let* ((indent-stack (list nil)) + ;; If ENDPOS is non-nil, use beginning of defun as STARTING-POINT. + ;; If ENDPOS is nil, it is safe not to scan before point + ;; since every line we indent is more deeply nested than point is. + (starting-point (save-excursion (if endpos (beginning-of-defun)) + (point))) + ;; Use `syntax-ppss' to get initial state so we don't get + ;; confused by starting inside a string. We don't use + ;; `syntax-ppss' in the loop, because this is measurably + ;; slower when we're called on a long list. + (state (syntax-ppss)) + (init-depth (car state)) + (next-depth init-depth) + (last-depth init-depth) + (last-syntax-point (point))) + (unless endpos + ;; Get error now if we don't have a complete sexp after point. + (save-excursion (forward-sexp 1) + ;; We need a marker because we modify the buffer + ;; text preceding endpos. + (setq endpos (point-marker)))) (save-excursion - (setq outer-loop-done nil) - (while (if endpos (< (point) endpos) - (not outer-loop-done)) - (setq last-depth next-depth - inner-loop-done nil) - ;; Parse this line so we can learn the state - ;; to indent the next line. - ;; This inner loop goes through only once - ;; unless a line ends inside a string. - (while (and (not inner-loop-done) - (not (setq outer-loop-done (eobp)))) - (setq state (parse-partial-sexp (point) (progn (end-of-line) (point)) - nil nil state)) - (setq next-depth (car state)) - ;; If the line contains a comment other than the sort - ;; that is indented like code, - ;; indent it now with indent-for-comment. - ;; Comments indented like code are right already. - ;; In any case clear the in-comment flag in the state - ;; because parse-partial-sexp never sees the newlines. - (if (car (nthcdr 4 state)) - (progn (indent-for-comment) - (end-of-line) - (setcar (nthcdr 4 state) nil))) - ;; If this line ends inside a string, - ;; go straight to next line, remaining within the inner loop, - ;; and turn off the \-flag. - (if (car (nthcdr 3 state)) - (progn - (forward-line 1) - (setcar (nthcdr 5 state) nil)) - (setq inner-loop-done t))) - (and endpos - (<= next-depth 0) - (progn - (setq indent-stack (nconc indent-stack - (make-list (- next-depth) nil)) - last-depth (- last-depth next-depth) - next-depth 0))) - (forward-line 1) - ;; Decide whether to exit. - (if endpos - ;; If we have already reached the specified end, - ;; give up and do not reindent this line. - (if (<= endpos (point)) - (setq outer-loop-done t)) - ;; If no specified end, we are done if we have finished one sexp. - (if (<= next-depth 0) - (setq outer-loop-done t))) - (unless outer-loop-done - (while (> last-depth next-depth) - (setq indent-stack (cdr indent-stack) - last-depth (1- last-depth))) - (while (< last-depth next-depth) - (setq indent-stack (cons nil indent-stack) - last-depth (1+ last-depth))) - ;; Now indent the next line according - ;; to what we learned from parsing the previous one. - (setq bol (point)) - (skip-chars-forward " \t") - ;; But not if the line is blank, or just a comment - ;; (except for double-semi comments; indent them as usual). - (if (or (eobp) (looking-at "\\s<\\|\n")) - nil - (if (and (car indent-stack) - (>= (car indent-stack) 0)) - (setq this-indent (car indent-stack)) - (let ((val (calculate-lisp-indent - (if (car indent-stack) (- (car indent-stack)) - starting-point)))) - (if (null val) - (setq this-indent val) - (if (integerp val) - (setcar indent-stack - (setq this-indent val)) - (setcar indent-stack (- (car (cdr val)))) - (setq this-indent (car val)))))) - (if (and this-indent (/= (current-column) this-indent)) - (progn (delete-region bol (point)) - (indent-to this-indent))))) - (or outer-loop-done - (setq outer-loop-done (= (point) last-point)) - (setq last-point (point))))))) + (while (< (point) endpos) + ;; Parse this line so we can learn the state to indent the + ;; next line. + (while (progn + (setq state (parse-partial-sexp + last-syntax-point (progn (end-of-line) (point)) + nil nil state)) + ;; Skip over newlines within strings. + (nth 3 state)) + (setq state (parse-partial-sexp (point) (point-max) + nil nil state 'syntax-table)) + (setq last-syntax-point (point))) + (setq next-depth (car state)) + ;; If the line contains a comment indent it now with + ;; `indent-for-comment'. + (when (nth 4 state) + (indent-for-comment) + (end-of-line)) + (setq last-syntax-point (point)) + (when (< next-depth init-depth) + (setq indent-stack (nconc indent-stack + (make-list (- init-depth next-depth) nil)) + last-depth (- last-depth next-depth) + next-depth init-depth)) + (forward-line 1) + (when (< (point) endpos) + (let ((depth-delta (- next-depth last-depth))) + (cond ((< depth-delta 0) + (setq indent-stack (nthcdr (- depth-delta) indent-stack))) + ((> depth-delta 0) + (setq indent-stack (nconc (make-list depth-delta nil) + indent-stack)))) + (setq last-depth next-depth)) + ;; Now indent the next line according + ;; to what we learned from parsing the previous one. + (skip-chars-forward " \t") + ;; But not if the line is blank, or just a comment (we + ;; already called `indent-for-comment' above). + (unless (or (eolp) (eq (char-syntax (char-after)) ?<)) + (let ((this-indent (car indent-stack))) + (when (listp this-indent) + (let ((val (calculate-lisp-indent + (or (car this-indent) starting-point)))) + (setq + this-indent + (cond ((integerp val) + (setf (car indent-stack) val)) + ((consp val) ; (COLUMN CONTAINING-SEXP-START) + (setf (car indent-stack) (cdr val)) + (car val)) + ;; `calculate-lisp-indent' only returns nil + ;; when we're in a string, but this won't + ;; happen because we skip strings above. + (t (error "This shouldn't happen!")))))) + (indent-line-to this-indent)))))))) (defun indent-pp-sexp (&optional arg) "Indent each line of the list starting just after point, or prettyprint it. @@ -1217,8 +1209,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/macroexp.el b/lisp/emacs-lisp/macroexp.el index 98bfff713a0..9bc194c478c 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -103,7 +103,7 @@ each clause." (defun macroexp--funcall-if-compiled (_form) "Pseudo function used internally by macroexp to delay warnings. The purpose is to delay warnings to bytecomp.el, so they can use things -like `byte-compile-log-warning' to get better file-and-line-number data +like `byte-compile-warn' to get better file-and-line-number data and also to avoid outputting the warning during normal execution." nil) (put 'macroexp--funcall-if-compiled 'byte-compile @@ -122,7 +122,7 @@ and also to avoid outputting the warning during normal execution." (defvar macroexp--warned (make-hash-table :test #'equal :weakness 'key)) (defun macroexp--warn-and-return (msg form &optional compile-only) - (let ((when-compiled (lambda () (byte-compile-log-warning msg t)))) + (let ((when-compiled (lambda () (byte-compile-warn "%s" msg)))) (cond ((null msg) form) ((macroexp--compiling-p) diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index d390a0d69a7..af7a9ee4abb 100644 --- a/lisp/emacs-lisp/map-ynp.el +++ b/lisp/emacs-lisp/map-ynp.el @@ -144,8 +144,7 @@ Returns the number of actions taken." (cons prompt map)) 'quit)) ;; Prompt in the echo area. - (let ((cursor-in-echo-area (not no-cursor-in-echo-area)) - (message-log-max nil)) + (let ((cursor-in-echo-area (not no-cursor-in-echo-area))) (message (apply 'propertize "%s(y, n, !, ., q, %sor %s) " minibuffer-prompt-properties) prompt user-keys diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index 6371ec37906..a89457e877d 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. @@ -78,14 +79,14 @@ MAP can be a list, hash-table or array." (eval-when-compile (defmacro map--dispatch (map-var &rest args) - "Evaluate one of the forms specified by ARGS based on the type of MAP. + "Evaluate one of the forms specified by ARGS based on the type of MAP-VAR. The following keyword types are meaningful: `:list', `:hash-table' and `:array'. -An error is thrown if MAP is neither a list, hash-table nor array. +An error is thrown if MAP-VAR is neither a list, hash-table nor array. -Return RESULT if non-nil or the result of evaluation of the form." +Returns the result of evaluating the form associated with MAP-VAR's type." (declare (debug t) (indent 1)) `(cond ((listp ,map-var) ,(plist-get args :list)) ((hash-table-p ,map-var) ,(plist-get args :hash-table)) @@ -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/nadvice.el b/lisp/emacs-lisp/nadvice.el index 5a100b790f1..fd1cd2c7aaf 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -72,6 +72,13 @@ Each element has the form (WHERE BYTECODE STACK) where: (setq f (advice--cdr f))) f) +(defun advice--where (f) + (let ((bytecode (aref f 1)) + (where nil)) + (dolist (elem advice--where-alist) + (if (eq bytecode (cadr elem)) (setq where (car elem)))) + where)) + (defun advice--make-docstring (function) "Build the raw docstring for FUNCTION, presumably advised." (let* ((flist (indirect-function function)) @@ -79,16 +86,13 @@ Each element has the form (WHERE BYTECODE STACK) where: (docstring nil)) (if (eq 'macro (car-safe flist)) (setq flist (cdr flist))) (while (advice--p flist) - (let ((bytecode (aref flist 1)) - (doc (aref flist 4)) - (where nil)) + (let ((doc (aref flist 4)) + (where (advice--where flist))) ;; Hack attack! For advices installed before calling ;; Snarf-documentation, the integer offset into the DOC file will not ;; be installed in the "core unadvised function" but in the advice ;; object instead! So here we try to undo the damage. (if (integerp doc) (setq docfun flist)) - (dolist (elem advice--where-alist) - (if (eq bytecode (cadr elem)) (setq where (car elem)))) (setq docstring (concat docstring @@ -502,6 +506,10 @@ of the piece of advice." (setq frame2 (backtrace-frame i #'called-interactively-p)) ;; (message "Advice Frame %d = %S" i frame2) (setq i (1+ i))))) + ;; FIXME: Adjust this for the new :filter advices, since they use `funcall' + ;; rather than `apply'. + ;; FIXME: Somehow this doesn't work on (advice-add :before + ;; 'call-interactively #'ignore), see bug#3984. (when (and (eq (nth 1 frame2) 'apply) (progn (funcall get-next-frame) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 32200227de9..8d5fac96cfb 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) @@ -791,7 +792,7 @@ untar into a directory named DIR; otherwise, signal an error." (tar-mode) ;; Make sure everything extracts into DIR. (let ((regexp (concat "\\`" (regexp-quote (expand-file-name dir)) "/")) - (case-fold-search (memq system-type '(windows-nt ms-dos cygwin)))) + (case-fold-search (file-name-case-insensitive-p dir))) (dolist (tar-data tar-parse-info) (let ((name (expand-file-name (tar-header-name tar-data)))) (or (string-match regexp name) @@ -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) @@ -1077,6 +1081,8 @@ The return result is a `package-desc'." (setq files nil) ;; set the 'dir kind, (setf (package-desc-kind info) 'dir)))) + (unless info + (error "No .el files with package headers in `%s'" default-directory)) ;; and return the info. info)))) @@ -1439,13 +1445,13 @@ individual packages after calling `package-initialize' -- this is taken care of by `package-initialize'." (interactive) (setq package-alist nil) - (if (equal user-init-file load-file-name) - ;; If `package-initialize' is being called as part of loading - ;; the init file, it's obvious we don't need to ensure-init. - (setq package--init-file-ensured t - ;; And likely we don't need to run it again after init. - package-enable-at-startup nil) - (package--ensure-init-file)) + (if after-init-time + (package--ensure-init-file) + ;; If `package-initialize' is before we finished loading the init + ;; file, it's obvious we don't need to ensure-init. + (setq package--init-file-ensured t + ;; And likely we don't need to run it again after init. + package-enable-at-startup nil)) (package-load-all-descriptors) (package-read-all-archive-contents) (unless no-activate @@ -2304,7 +2310,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 379b3ca69ba..289265abf27 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -89,7 +89,8 @@ (functionp &rest form) sexp)) -(def-edebug-spec pcase-MACRO pcase--edebug-match-macro) +;; See bug#24717 +(put 'pcase-MACRO 'edebug-form-spec 'pcase--edebug-match-macro) ;; Only called from edebug. (declare-function get-edebug-spec "edebug" (symbol)) @@ -298,6 +299,8 @@ any kind of error." ;;;###autoload (defmacro pcase-dolist (spec &rest body) + "Like `dolist' but where the binding can be a `pcase' pattern. +\n(fn (PATTERN LIST) BODY...)" (declare (indent 1) (debug ((pcase-PAT form) body))) (if (pcase--trivial-upat-p (car spec)) `(dolist ,spec ,@body) @@ -434,8 +437,10 @@ to this macro." ;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding ;; let* which might prevent the setcar/setcdr in pcase--expand's fancy ;; codegen from later metamorphosing this let into a funcall. - `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars) - ,@code)) + (if vars + `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars) + ,@code) + `(progn ,@code))) (defun pcase--small-branch-p (code) (and (= 1 (length code)) @@ -509,6 +514,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/pp.el b/lisp/emacs-lisp/pp.el index 2938c37e8a8..7ef46a48bde 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -1,4 +1,4 @@ -;;; pp.el --- pretty printer for Emacs Lisp +;;; pp.el --- pretty printer for Emacs Lisp -*- lexical-binding: t -*- ;; Copyright (C) 1989, 1993, 2001-2017 Free Software Foundation, Inc. @@ -67,8 +67,7 @@ to make output that `read' can handle, whenever this is possible." (progn (skip-chars-backward " \t\n") (point))) (insert "\n")))) ((ignore-errors (up-list 1) t) - (while (looking-at-p "\\s)") - (forward-char 1)) + (skip-syntax-forward ")") (delete-region (point) (progn (skip-chars-forward " \t\n") (point))) @@ -129,7 +128,7 @@ Also add the value to the front of the list in the variable `values'." (interactive (list (read--expression "Eval: "))) (message "Evaluating...") - (setq values (cons (eval expression lexical-binding) values)) + (push (eval expression lexical-binding) values) (pp-display-expression (car values) "*Pp Eval Output*")) ;;;###autoload @@ -141,22 +140,21 @@ Also add the value to the front of the list in the variable `values'." (defun pp-last-sexp () "Read sexp before point. Ignores leading comment characters." - (let ((stab (syntax-table)) (pt (point)) start exp) - (set-syntax-table emacs-lisp-mode-syntax-table) - (save-excursion - (forward-sexp -1) - ;; If first line is commented, ignore all leading comments: - (if (save-excursion (beginning-of-line) (looking-at-p "[ \t]*;")) - (progn - (setq exp (buffer-substring (point) pt)) - (while (string-match "\n[ \t]*;+" exp start) - (setq start (1+ (match-beginning 0)) - exp (concat (substring exp 0 start) - (substring exp (match-end 0))))) - (setq exp (read exp))) - (setq exp (read (current-buffer))))) - (set-syntax-table stab) - exp)) + (with-syntax-table emacs-lisp-mode-syntax-table + (let ((pt (point))) + (save-excursion + (forward-sexp -1) + (read + ;; If first line is commented, ignore all leading comments: + (if (save-excursion (beginning-of-line) (looking-at-p "[ \t]*;")) + (let ((exp (buffer-substring (point) pt)) + (start nil)) + (while (string-match "\n[ \t]*;+" exp start) + (setq start (1+ (match-beginning 0)) + exp (concat (substring exp 0 start) + (substring exp (match-end 0))))) + exp) + (current-buffer))))))) ;;;###autoload (defun pp-eval-last-sexp (arg) @@ -178,19 +176,6 @@ Ignores leading comment characters." (insert (pp-to-string (macroexpand-1 (pp-last-sexp)))) (pp-macroexpand-expression (pp-last-sexp)))) -;;; Test cases for quote -;; (pp-eval-expression ''(quote quote)) -;; (pp-eval-expression ''((quote a) (quote b))) -;; (pp-eval-expression ''('a 'b)) ; same as above -;; (pp-eval-expression ''((quote (quote quote)) (quote quote))) -;; These do not satisfy the quote test. -;; (pp-eval-expression ''quote) -;; (pp-eval-expression ''(quote)) -;; (pp-eval-expression ''(quote . quote)) -;; (pp-eval-expression ''(quote a b)) -;; (pp-eval-expression ''(quotefoo)) -;; (pp-eval-expression ''(a b)) - (provide 'pp) ; so (require 'pp) works ;;; pp.el ends here diff --git a/lisp/emacs-lisp/radix-tree.el b/lisp/emacs-lisp/radix-tree.el new file mode 100644 index 00000000000..b5e7589b951 --- /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-2017 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/re-builder.el b/lisp/emacs-lisp/re-builder.el index 5264dae52ae..f60d723a883 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -488,10 +488,10 @@ If the optional PAUSE is non-nil then pause at the end in any case." Optional argument SYNTAX must be specified if called non-interactively." (interactive (list (intern - (completing-read "Select syntax: " - (mapcar (lambda (el) (cons (symbol-name el) 1)) - '(read string sregex rx)) - nil t (symbol-name reb-re-syntax))))) + (completing-read + (format "Select syntax (default %s): " reb-re-syntax) + '(read string sregex rx) + nil t nil nil (symbol-name reb-re-syntax))))) (if (memq syntax '(read string sregex rx)) (let ((buffer (get-buffer reb-buffer))) diff --git a/lisp/emacs-lisp/regexp-opt.el b/lisp/emacs-lisp/regexp-opt.el index 8b91668c8c2..5feaad88c7b 100644 --- a/lisp/emacs-lisp/regexp-opt.el +++ b/lisp/emacs-lisp/regexp-opt.el @@ -1,4 +1,4 @@ -;;; regexp-opt.el --- generate efficient regexps to match strings +;;; regexp-opt.el --- generate efficient regexps to match strings -*- lexical-binding: t -*- ;; Copyright (C) 1994-2017 Free Software Foundation, Inc. @@ -262,7 +262,7 @@ CHARS should be a list of characters." ;; The basic idea is to find character ranges. Also we take care in the ;; position of character set meta characters in the character set regexp. ;; - (let* ((charmap (make-char-table 'case-table)) + (let* ((charmap (make-char-table 'regexp-opt-charset)) (start -1) (end -2) (charset "") (bracket "") (dash "") (caret "")) diff --git a/lisp/emacs-lisp/ring.el b/lisp/emacs-lisp/ring.el index 371723fa0b5..b0ec3bcbe01 100644 --- a/lisp/emacs-lisp/ring.el +++ b/lisp/emacs-lisp/ring.el @@ -1,4 +1,4 @@ -;;; ring.el --- handle rings of items +;;; ring.el --- handle rings of items -*- lexical-binding: t; -*- ;; Copyright (C) 1992, 2001-2017 Free Software Foundation, Inc. @@ -160,14 +160,15 @@ will be performed." (size (ring-size ring)) (vect (cddr ring)) lst) - (dotimes (var (cadr ring) lst) - (push (aref vect (mod (+ start var) size)) lst)))) + (dotimes (var (cadr ring)) + (push (aref vect (mod (+ start var) size)) lst)) + lst)) (defun ring-member (ring item) "Return index of ITEM if on RING, else nil. Comparison is done via `equal'. The index is 0-based." (catch 'found - (dotimes (ind (ring-length ring) nil) + (dotimes (ind (ring-length ring)) (when (equal item (ring-ref ring ind)) (throw 'found ind))))) diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index a2927117342..386232c6eef 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -521,7 +521,7 @@ ARG is optional." (setq args (nconc (delq ?- args) (list ?-)))) ((setq m (assq ?- args)) ;; next to the bracket's range, make the second range - (setcdr args (cons m (delq m args)))))) + (setcdr args (cons m (delq m (cdr args))))))) ;; bracket in the end range ;; => "[]...-]" ((setq m (rassq ?\] args)) diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index d12025cf0c4..41187646624 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.19 ;; Package: seq ;; Maintainer: emacs-devel@gnu.org @@ -87,7 +87,7 @@ given, and the match does not fail." ARGS can also include the `&rest' marker followed by a variable name to be bound to the rest of SEQUENCE." - (declare (indent 2) (debug t)) + (declare (indent 2) (debug (sexp form body))) `(pcase-let ((,(seq--make-pcase-patterns args) ,sequence)) ,@body)) @@ -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)) @@ -156,7 +178,8 @@ Return a list of the results. \(fn FUNCTION SEQUENCES...)" (let ((result nil) - (sequences (seq-map (lambda (s) (seq-into s 'list)) + (sequences (seq-map (lambda (s) + (seq-into s 'list)) (cons sequence sequences)))) (while (not (memq nil sequences)) (push (apply function (seq-map #'car sequences)) result) @@ -206,6 +229,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 '())) @@ -240,9 +273,9 @@ of sequence." TYPE can be one of the following symbols: vector, string or list." (pcase type - (`vector (vconcat sequence)) - (`string (concat sequence)) - (`list (append sequence nil)) + (`vector (seq--into-vector sequence)) + (`string (seq--into-string sequence)) + (`list (seq--into-list sequence)) (_ (error "Not a sequence type name: %S" type)))) (cl-defgeneric seq-filter (pred sequence) @@ -284,7 +317,8 @@ If SEQUENCE is empty, return INITIAL-VALUE and FUNCTION is not called." t)) (cl-defgeneric seq-some (pred sequence) - "Return the first value for which if (PRED element) is non-nil for in SEQUENCE." + "Return non-nil if PRED is satisfied for at least one element of SEQUENCE. +If so, return the first non-nil value returned by PRED." (catch 'seq--break (seq-doseq (elt sequence) (let ((result (funcall pred elt))) @@ -317,7 +351,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) @@ -443,16 +478,20 @@ SEQUENCE must be a sequence of numbers or markers." "Return element of SEQUENCE at the index N. If no element is found, return nil." (ignore-errors (seq-elt sequence n))) + +(cl-defgeneric seq-random-elt (sequence) + "Return a random element from SEQUENCE. +Signal an error if SEQUENCE is empty." + (if (seq-empty-p sequence) + (error "Sequence cannot be empty") + (seq-elt sequence (random (seq-length sequence))))) ;;; Optimized implementations for lists (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." @@ -473,6 +512,24 @@ If no element is found, return nil." (null list)) +(defun seq--into-list (sequence) + "Concatenate the elements of SEQUENCE into a list." + (if (listp sequence) + sequence + (append sequence nil))) + +(defun seq--into-vector (sequence) + "Concatenate the elements of SEQUENCE into a vector." + (if (vectorp sequence) + sequence + (vconcat sequence))) + +(defun seq--into-string (sequence) + "Concatenate the elements of SEQUENCE into a string." + (if (stringp sequence) + sequence + (concat sequence))) + (defun seq--activate-font-lock-keywords () "Activate font-lock keywords for some symbols defined in seq." (font-lock-add-keywords 'emacs-lisp-mode diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 4548d749fe8..1d729f94092 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -33,6 +33,7 @@ ;;; Code: (require 'pcase) +(eval-when-compile (require 'cl-lib)) (defmacro internal--thread-argument (first? &rest forms) @@ -114,14 +115,19 @@ threading." binding)) bindings))) -(defmacro if-let (bindings then &rest else) - "Process BINDINGS and if all values are non-nil eval THEN, else ELSE. -Argument BINDINGS is a list of tuples whose car is a symbol to be -bound and (optionally) used in THEN, and its cadr is a sexp to be -evalled to set symbol's value. In the special case you only want -to bind a single value, BINDINGS can just be a plain tuple." +(defmacro if-let* (bindings then &rest else) + "Bind variables according to VARLIST and eval THEN or ELSE. +Each binding is evaluated in turn with `let*', and evaluation +stops if a binding value is nil. If all are non-nil, the value +of THEN is returned, or the last form in ELSE is returned. +Each element of VARLIST is a symbol (which is bound to nil) +or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM). +In the special case you only want to bind a single value, +VARLIST can just be a plain tuple. +\n(fn VARLIST THEN ELSE...)" (declare (indent 2) - (debug ([&or (&rest (symbolp form)) (symbolp form)] form body))) + (debug ([&or (&rest [&or symbolp (symbolp form)]) (symbolp form)] + form body))) (when (and (<= (length bindings) 2) (not (listp (car bindings)))) ;; Adjust the single binding case @@ -131,30 +137,34 @@ to bind a single value, BINDINGS can just be a plain tuple." ,then ,@else))) -(defmacro when-let (bindings &rest body) - "Process BINDINGS and if all values are non-nil eval BODY. -Argument BINDINGS is a list of tuples whose car is a symbol to be -bound and (optionally) used in BODY, and its cadr is a sexp to be -evalled to set symbol's value. In the special case you only want -to bind a single value, BINDINGS can just be a plain tuple." +(defmacro when-let* (bindings &rest body) + "Bind variables according to VARLIST and conditionally eval BODY. +Each binding is evaluated in turn with `let*', and evaluation +stops if a binding value is nil. If all are non-nil, the value +of the last form in BODY is returned. +Each element of VARLIST is a symbol (which is bound to nil) +or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM). +In the special case you only want to bind a single value, +VARLIST can just be a plain tuple. +\n(fn VARLIST BODY...)" (declare (indent 1) (debug if-let)) (list 'if-let bindings (macroexp-progn body))) +(defalias 'if-let 'if-let*) +(defalias 'when-let 'when-let*) +(defalias 'and-let* 'when-let*) + (defsubst hash-table-empty-p (hash-table) "Check whether HASH-TABLE is empty (has 0 elements)." (zerop (hash-table-count hash-table))) (defsubst hash-table-keys (hash-table) "Return a list of keys in HASH-TABLE." - (let ((keys '())) - (maphash (lambda (k _v) (push k keys)) hash-table) - keys)) + (cl-loop for k being the hash-keys of hash-table collect k)) (defsubst hash-table-values (hash-table) "Return a list of values in HASH-TABLE." - (let ((values '())) - (maphash (lambda (_k v) (push v values)) hash-table) - values)) + (cl-loop for v being the hash-values of hash-table collect v)) (defsubst string-empty-p (string) "Check whether STRING is empty." @@ -198,6 +208,176 @@ 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. + +When `use-dialog-box' is t (the default), this function can pop +up a dialog window to collect the user input. That functionality +requires `display-popup-menus-p' to return t. Otherwise, a text +dialog will be used. + +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 58158150b08..d1d5176944c 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/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 415c22553df..b6b49b1bfa2 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -102,6 +102,8 @@ It is called with two arguments, ID and COLS. ID is a Lisp object identifying the entry, and COLS is a vector of column descriptors, as documented in `tabulated-list-entries'.") +(defvar tabulated-list--near-rows) + (defvar-local tabulated-list-sort-key nil "Sort key for the current Tabulated List mode buffer. If nil, no additional sorting is performed. @@ -257,6 +259,12 @@ Do nothing if `tabulated-list--header-string' is nil." (make-overlay (point-min) (point)))) (overlay-put tabulated-list--header-overlay 'face 'underline)))) +(defsubst tabulated-list-header-overlay-p (&optional pos) + "Return non-nil if there is a fake header. +Optional arg POS is a buffer position where to look for a fake header; +defaults to `point-min'." + (overlays-at (or pos (point-min)))) + (defun tabulated-list-revert (&rest ignored) "The `revert-buffer-function' for `tabulated-list-mode'. It runs `tabulated-list-revert-hook', then calls `tabulated-list-print'." @@ -298,6 +306,14 @@ column. Negate the predicate that would be returned if (lambda (a b) (not (funcall sorter a b))) sorter)))) +(defsubst tabulated-list--col-local-max-widths (col) + "Return maximum entry widths at column COL around current row. +Check the current row, the previous one and the next row." + (apply #'max (mapcar (lambda (x) + (let ((nt (elt x col))) + (string-width (if (stringp nt) nt (car nt))))) + tabulated-list--near-rows))) + (defun tabulated-list-print (&optional remember-pos update) "Populate the current Tabulated List mode buffer. This sorts the `tabulated-list-entries' list if sorting is @@ -340,8 +356,14 @@ changing `tabulated-list-sort-key'." (unless tabulated-list-use-header-line (tabulated-list-print-fake-header))) ;; Finally, print the resulting list. - (dolist (elt entries) - (let ((id (car elt))) + (while entries + (let* ((elt (car entries)) + (tabulated-list--near-rows + (list + (or (tabulated-list-get-entry (point-at-bol 0)) (cadr elt)) + (cadr elt) + (or (cadr (cadr entries)) (cadr elt)))) + (id (car elt))) (and entry-id (equal entry-id id) (setq entry-id nil @@ -368,7 +390,8 @@ changing `tabulated-list-sort-key'." (t t))) (let ((old (point))) (forward-line 1) - (delete-region old (point))))))) + (delete-region old (point)))))) + (setq entries (cdr entries))) (set-buffer-modified-p nil) ;; If REMEMBER-POS was specified, move to the "old" location. (if saved-pt @@ -389,8 +412,13 @@ of column descriptors." (inhibit-read-only t)) (if (> tabulated-list-padding 0) (insert (make-string x ?\s))) - (dotimes (n ncols) - (setq x (tabulated-list-print-col n (aref cols n) x))) + (let ((tabulated-list--near-rows ; Bind it if not bound yet (Bug#25506). + (or (bound-and-true-p tabulated-list--near-rows) + (list (or (tabulated-list-get-entry (point-at-bol 0)) + cols) + cols)))) + (dotimes (n ncols) + (setq x (tabulated-list-print-col n (aref cols n) x)))) (insert ?\n) ;; Ever so slightly faster than calling `put-text-property' twice. (add-text-properties @@ -402,8 +430,6 @@ of column descriptors." N is the column number, COL-DESC is a column descriptor (see `tabulated-list-entries'), and X is the column number at point. Return the column number after insertion." - ;; TODO: don't truncate to `width' if the next column is align-right - ;; and has some space left. (let* ((format (aref tabulated-list-format n)) (name (nth 0 format)) (width (nth 1 format)) @@ -414,12 +440,29 @@ Return the column number after insertion." (label-width (string-width label)) (help-echo (concat (car format) ": " label)) (opoint (point)) - (not-last-col (< (1+ n) (length tabulated-list-format)))) + (not-last-col (< (1+ n) (length tabulated-list-format))) + available-space) + (when not-last-col + (let* ((next-col-format (aref tabulated-list-format (1+ n))) + (next-col-right-align (plist-get (nthcdr 3 next-col-format) + :right-align)) + (next-col-width (nth 1 next-col-format))) + (setq available-space + (if (and (not right-align) + next-col-right-align) + (- + (+ width next-col-width) + (min next-col-width + (tabulated-list--col-local-max-widths (1+ n)))) + width)))) ;; Truncate labels if necessary (except last column). - (and not-last-col - (> label-width width) - (setq label (truncate-string-to-width label width nil nil t) - label-width width)) + ;; Don't truncate to `width' if the next column is align-right + ;; and has some space left, truncate to `available-space' instead. + (when (and not-last-col + (> label-width available-space) + (setq label (truncate-string-to-width + label available-space nil nil t) + label-width available-space))) (setq label (bidi-string-mark-left-to-right label)) (when (and right-align (> width label-width)) (let ((shift (- width label-width))) @@ -437,7 +480,7 @@ Return the column number after insertion." (when not-last-col (when (> pad-right 0) (insert (make-string pad-right ?\s))) (insert (propertize - (make-string (- next-x x label-width pad-right) ?\s) + (make-string (- width (min width label-width)) ?\s) 'display `(space :align-to ,next-x)))) (put-text-property opoint (point) 'tabulated-list-column-name name) next-x))) @@ -494,7 +537,12 @@ this is the vector stored within it." (when (< pos eol) (delete-region pos (next-single-property-change pos prop nil eol)) (goto-char pos) - (tabulated-list-print-col col desc (current-column)) + (let ((tabulated-list--near-rows + (list + (tabulated-list-get-entry (point-at-bol 0)) + entry + (or (tabulated-list-get-entry (point-at-bol 2)) entry)))) + (tabulated-list-print-col col desc (current-column))) (if change-entry-data (aset entry col desc)) (put-text-property pos (point) 'tabulated-list-id id) diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el index 34dc4b8d6b3..433ad38a147 100644 --- a/lisp/emacs-lisp/testcover.el +++ b/lisp/emacs-lisp/testcover.el @@ -184,6 +184,7 @@ call to one of the `testcover-1value-functions'." ;;; Add instrumentation to your module ;;;========================================================================= +;;;###autoload (defun testcover-start (filename &optional byte-compile) "Uses edebug to instrument all macros and functions in FILENAME, then changes the instrumentation from edebug to testcover--much faster, no diff --git a/lisp/emacs-lisp/timer-list.el b/lisp/emacs-lisp/timer-list.el new file mode 100644 index 00000000000..1a38254bcba --- /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-2017 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 diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index ba87543f5b0..d872256dad4 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -1,4 +1,4 @@ -;;; timer.el --- run a function with args at some time in future +;;; timer.el --- run a function with args at some time in future -*- lexical-binding: t -*- ;; Copyright (C) 1996, 2001-2017 Free Software Foundation, Inc. |