From 84f59f75853704520323fb37edee4fe03d2f3021 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 12 Mar 2022 18:53:36 +0100 Subject: Make find-function-regexp also find cl-defun/defmethod * lisp/emacs-lisp/find-func.el (find-function-regexp): Also find cl-defun and cl-defmethod (bug#54343). --- lisp/emacs-lisp/find-func.el | 1 + 1 file changed, 1 insertion(+) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 571087c963d..777334a7a70 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -61,6 +61,7 @@ "^\\s-*(\\(def\\(ine-skeleton\\|ine-generic-mode\\|ine-derived-mode\\|\ ine\\(?:-global\\)?-minor-mode\\|ine-compilation-mode\\|un-cvs-mode\\|\ foo\\|\\(?:[^icfgv]\\|g[^r]\\)\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\ +cl-\\(?:defun\\|defmethod\\)\\|\ menu-bar-make-toggle\\|menu-bar-make-toggle-command\\)" find-function-space-re "\\('\\|(quote \\)?%s\\(\\s-\\|$\\|[()]\\)") -- cgit v1.2.3 From 466a7e44d729683277dab41dba7395b36802a8cf Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 13 Mar 2022 15:07:59 +0100 Subject: Add cl-defgeneric to find-func, too * lisp/emacs-lisp/find-func.el (find-function-regexp): Add cl-defgeneric, too (bug#54343). --- lisp/emacs-lisp/find-func.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 777334a7a70..208d68d1ab9 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -61,7 +61,7 @@ "^\\s-*(\\(def\\(ine-skeleton\\|ine-generic-mode\\|ine-derived-mode\\|\ ine\\(?:-global\\)?-minor-mode\\|ine-compilation-mode\\|un-cvs-mode\\|\ foo\\|\\(?:[^icfgv]\\|g[^r]\\)\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\ -cl-\\(?:defun\\|defmethod\\)\\|\ +cl-\\(?:defun\\|defmethod\\|generic\\)\\|\ menu-bar-make-toggle\\|menu-bar-make-toggle-command\\)" find-function-space-re "\\('\\|(quote \\)?%s\\(\\s-\\|$\\|[()]\\)") -- cgit v1.2.3 From 525c01c43a75b6190243530a70cd4943abe980a7 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 13 Mar 2022 21:13:49 +0100 Subject: Make vtable sorting stable * lisp/emacs-lisp/vtable.el (vtable--sort): Make the sorting stable. --- lisp/emacs-lisp/vtable.el | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index d8577c19762..8d777335315 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -456,22 +456,26 @@ This also updates the displayed table." (pcase-dolist (`(,index . ,direction) (vtable-sort-by table)) (let ((cache (vtable--cache table)) (numerical (vtable-column--numerical - (elt (vtable-columns table) index)))) + (elt (vtable-columns table) index))) + (numcomp (if (eq direction 'descend) + #'> #'<)) + (stringcomp (if (eq direction 'descend) + #'string> #'string<))) (setcar cache (sort (car cache) (lambda (e1 e2) (let ((c1 (elt e1 (1+ index))) (c2 (elt e2 (1+ index)))) (if numerical - (< (car c1) (car c2)) - (string< (if (stringp (car c1)) - (car c1) - (format "%s" (car c1))) - (if (stringp (car c2)) - (car c2) - (format "%s" (car c2))))))))) - (when (eq direction 'descend) - (setcar cache (nreverse (car cache))))))) + (funcall numcomp (car c1) (car c2)) + (funcall + stringcomp + (if (stringp (car c1)) + (car c1) + (format "%s" (car c1))) + (if (stringp (car c2)) + (car c2) + (format "%s" (car c2)))))))))))) (defun vtable--indicator (table index) (let ((order (car (last (vtable-sort-by table))))) -- cgit v1.2.3 From 510f1f2e72a467cdaae25c4354e5ce3579ca1ca9 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 13 Mar 2022 21:15:35 +0100 Subject: Really fix find-func for defgeneric * lisp/emacs-lisp/find-func.el (find-function-regexp): Really add defgeneric. --- lisp/emacs-lisp/find-func.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 208d68d1ab9..96eaf1ab642 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -61,7 +61,7 @@ "^\\s-*(\\(def\\(ine-skeleton\\|ine-generic-mode\\|ine-derived-mode\\|\ ine\\(?:-global\\)?-minor-mode\\|ine-compilation-mode\\|un-cvs-mode\\|\ foo\\|\\(?:[^icfgv]\\|g[^r]\\)\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\ -cl-\\(?:defun\\|defmethod\\|generic\\)\\|\ +cl-\\(?:defun\\|defmethod\\|defgeneric\\)\\|\ menu-bar-make-toggle\\|menu-bar-make-toggle-command\\)" find-function-space-re "\\('\\|(quote \\)?%s\\(\\s-\\|$\\|[()]\\)") -- cgit v1.2.3 From f3df7916b2b342380930082cf35bad6cb488a4dc Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Mon, 14 Mar 2022 10:59:03 +0100 Subject: Make Edebug specification for 'cl-defstruct' more lenient. For example, 'xref-item' uses the list form of ':noinline'. * lisp/emacs-lisp/cl-macs.el (cl-defstruct): Accept ':noinline' and ':named' with an argument. * test/lisp/emacs-lisp/cl-macs-tests.el (cl-defstruct/edebug): New unit test. --- lisp/emacs-lisp/cl-macs.el | 3 ++- test/lisp/emacs-lisp/cl-macs-tests.el | 18 ++++++++++++++++++ 2 files changed, 20 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 4b231d81496..9fd3350ddd7 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2911,7 +2911,8 @@ To see the documentation for a defined struct type, use [":include" symbolp &rest sexp] ;; Not finished. [":print-function" sexp] [":type" symbolp] - [":named"] + [":noinline" &optional sexp] + [":named" &optional sexp] [":initial-offset" natnump])])] [&optional stringp] ;; All the above is for the following def-form. diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index 036ee30966b..19ede627a13 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -709,4 +709,22 @@ collection clause." ;; Just make sure the forms can be instrumented. (eval-buffer)))) +(ert-deftest cl-defstruct/edebug () + "Check that we can instrument `cl-defstruct' forms." + (with-temp-buffer + (dolist (form '((cl-defstruct cl-defstruct/edebug/1) + (cl-defstruct (cl-defstruct/edebug/2 + :noinline)) + (cl-defstruct (cl-defstruct/edebug/3 + (:noinline t))) + (cl-defstruct (cl-defstruct/edebug/4 + :named)) + (cl-defstruct (cl-defstruct/edebug/5 + (:named t))))) + (print form (current-buffer))) + (let ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop)) + ;; Just make sure the forms can be instrumented. + (eval-buffer)))) + ;;; cl-macs-tests.el ends here -- cgit v1.2.3 From 5d33f815422e8203297779c6ebedfff922e4ffc7 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 14 Mar 2022 09:28:18 -0400 Subject: * lisp/emacs-lisp/cl-macs.el (cl-defstruct): Simplify Edebug spec --- lisp/emacs-lisp/cl-macs.el | 15 +++------------ 1 file changed, 3 insertions(+), 12 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 9fd3350ddd7..0d0b5b51587 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2901,19 +2901,10 @@ To see the documentation for a defined struct type, use (debug (&define ;Makes top-level form not be wrapped. [&or symbolp - (gate + (gate ;; FIXME: Why? symbolp &rest - [&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] - [":noinline" &optional sexp] - [":named" &optional sexp] - [":initial-offset" natnump])])] + [&or (":constructor" &define name &optional cl-lambda-list) + sexp])] [&optional stringp] ;; All the above is for the following def-form. &rest &or symbolp (symbolp &optional def-form &rest sexp)))) -- cgit v1.2.3 From 31a2428d6f2ca792af18b43ceca5cec1ecce862f Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Wed, 16 Mar 2022 19:23:24 +0000 Subject: Strip positions from symbols before the eval in eval-{when,and}-compile. This fixes bug #54079. * lisp/emacs-lisp/bytecomp.el (byte-compile-initial-macro-environment): Change the position of 'byte-run-strip-symbol-positions' in the eval-when-compile entry. Add a call to `byte-run-strip-symbol-positions' in the eval-and-compile entry. --- lisp/emacs-lisp/bytecomp.el | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 9be44a8d5af..c680437f324 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -500,8 +500,9 @@ Return the compile-time value of FORM." byte-compile-new-defuns)) (setf result (byte-compile-eval + (byte-run-strip-symbol-positions (byte-compile-top-level - (byte-compile-preprocess form))))))) + (byte-compile-preprocess form)))))))) (list 'quote result)))) (eval-and-compile . ,(lambda (&rest body) (byte-compile-recurse-toplevel @@ -512,9 +513,10 @@ Return the compile-time value of FORM." ;; or byte-compile-file-form. (let* ((print-symbols-bare t) ; Possibly redundant binding. (expanded - (macroexpand--all-toplevel - form - macroexpand-all-environment))) + (byte-run-strip-symbol-positions + (macroexpand--all-toplevel + form + macroexpand-all-environment)))) (eval expanded lexical-binding) expanded))))) (with-suppressed-warnings -- cgit v1.2.3 From 6bbd1cc5c9cd3db40dcb1ce82f478473b1f78131 Mon Sep 17 00:00:00 2001 From: Felician Nemeth Date: Thu, 17 Mar 2022 12:44:43 +0100 Subject: Format long help texts better in read-multiple-choice * lisp/emacs-lisp/rmc.el (rmc--show-help): Format long help texts better (bug#54430). --- lisp/emacs-lisp/rmc.el | 12 +++++++++--- test/lisp/emacs-lisp/rmc-tests.el | 24 +++++++++++++++++++++++- 2 files changed, 32 insertions(+), 4 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/rmc.el b/lisp/emacs-lisp/rmc.el index e635c7f200c..c450505dfd9 100644 --- a/lisp/emacs-lisp/rmc.el +++ b/lisp/emacs-lisp/rmc.el @@ -112,9 +112,15 @@ (goto-char start) (dolist (line (split-string text "\n")) (end-of-line) - (if (bolp) - (insert line "\n") - (insert line)) + (if (not (bolp)) + (insert line) + (insert (make-string + (max (- (* (mod (1- times) columns) + (+ fill-column 4)) + (current-column)) + 0) + ?\s)) + (insert line "\n")) (forward-line 1)))))))) buf)) diff --git a/test/lisp/emacs-lisp/rmc-tests.el b/test/lisp/emacs-lisp/rmc-tests.el index c1c46d6400e..ed30d82c3b8 100644 --- a/test/lisp/emacs-lisp/rmc-tests.el +++ b/test/lisp/emacs-lisp/rmc-tests.el @@ -66,5 +66,27 @@ (should (equal (list char str) (read-multiple-choice "Do it? " '((?y "yes") (?n "no")))))))) -(provide 'rmc-tests) +(ert-deftest test-read-multiple-choice-help () + (let ((chars '(?o ?a)) + help) + (cl-letf* (((symbol-function #'read-event) + (lambda () + (message "chars %S" chars) + (when (= 1 (length chars)) + (with-current-buffer "*Multiple Choice Help*" + (setq help (buffer-string)))) + (pop chars)))) + (read-multiple-choice + "Choose:" + '((?a "aaa") + (?b "bbb") + (?c "ccc" "a really long description of ccc"))) + (should (equal help "Choose: + +a: [A]aa b: [B]bb c: [C]cc + a really long + description of ccc + \n?: [?] +"))))) + ;;; rmc-tests.el ends here -- cgit v1.2.3 From 06488ded6b9d8b4971e2e6c5b98b4fab6fe2d167 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 17 Mar 2022 12:55:24 +0100 Subject: Make `?' work again in read-multiple-choice * lisp/emacs-lisp/rmc.el (read-multiple-choice): Make the `?' key work again to show the help text. --- lisp/emacs-lisp/rmc.el | 11 ++++++----- test/lisp/emacs-lisp/rmc-tests.el | 3 +-- 2 files changed, 7 insertions(+), 7 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/rmc.el b/lisp/emacs-lisp/rmc.el index c450505dfd9..195035e6be9 100644 --- a/lisp/emacs-lisp/rmc.el +++ b/lisp/emacs-lisp/rmc.el @@ -169,8 +169,9 @@ Usage example: \\='((?a \"always\") (?s \"session only\") (?n \"no\")))" - (let* ((choices (if show-help choices (append choices '((?? "?"))))) - (altered-names (mapcar #'rmc--add-key-description choices)) + (let* ((prompt-choices + (if show-help choices (append choices '((?? "?"))))) + (altered-names (mapcar #'rmc--add-key-description prompt-choices)) (full-prompt (format "%s (%s): " @@ -181,7 +182,7 @@ Usage example: (save-excursion (if show-help (setq buf (rmc--show-help prompt help-string show-help - choices altered-names))) + choices altered-names))) (while (not tchar) (message "%s%s" (if wrong-char @@ -200,7 +201,7 @@ Usage example: (lambda (elem) (cons (capitalize (cadr elem)) (car elem))) - choices))) + prompt-choices))) (condition-case nil (let ((cursor-in-echo-area t)) (read-event)) @@ -238,7 +239,7 @@ Usage example: (when wrong-char (ding)) (setq buf (rmc--show-help prompt help-string show-help - choices altered-names)))))) + choices altered-names)))))) (when (buffer-live-p buf) (kill-buffer buf)) (assq tchar choices))) diff --git a/test/lisp/emacs-lisp/rmc-tests.el b/test/lisp/emacs-lisp/rmc-tests.el index ed30d82c3b8..385b0fe44a5 100644 --- a/test/lisp/emacs-lisp/rmc-tests.el +++ b/test/lisp/emacs-lisp/rmc-tests.el @@ -86,7 +86,6 @@ a: [A]aa b: [B]bb c: [C]cc a really long description of ccc - \n?: [?] -"))))) + \n"))))) ;;; rmc-tests.el ends here -- cgit v1.2.3 From 81bcad03e93854087ab239f4e8b7c062fb069ca5 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 17 Mar 2022 09:54:41 -0400 Subject: (seq-contains-p): Refine the non-nil returned value * lisp/emacs-lisp/seq.el (seq-contains-p): Like `cl-some` return the value returned by the test function rather than t. --- lisp/emacs-lisp/seq.el | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 5ea9fae2e9b..1bcb844d8e9 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -418,8 +418,9 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil." Equality is defined by TESTFN if non-nil or by `equal' if nil." (catch 'seq--break (seq-doseq (e sequence) - (when (funcall (or testfn #'equal) e elt) - (throw 'seq--break t))) + (let ((r (funcall (or testfn #'equal) e elt))) + (when r + (throw 'seq--break r)))) nil)) (cl-defgeneric seq-set-equal-p (sequence1 sequence2 &optional testfn) -- cgit v1.2.3 From 693484d36b1326aebd895314570167ca8da87d69 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 17 Mar 2022 10:07:35 -0400 Subject: * lisp/emacs-lisp/cl-generic.el (cl-defgeneric): Warn suspicious args --- lisp/emacs-lisp/cl-generic.el | 11 +++++++++++ 1 file changed, 11 insertions(+) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index b44dda6f9d4..7b11c0c8159 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -262,6 +262,16 @@ DEFAULT-BODY, if present, is used as the body of a default method. (declarations nil) (methods ()) (options ()) + (warnings + (let ((nonsymargs + (delq nil (mapcar (lambda (arg) (unless (symbolp arg) arg)) + args)))) + (when nonsymargs + (list + (macroexp-warn-and-return + (format "Non-symbol arguments to cl-defgeneric: %s" + (mapconcat #'prin1-to-string nonsymargs "")) + nil nil nil nonsymargs))))) next-head) (while (progn (setq next-head (car-safe (car options-and-methods))) (or (keywordp next-head) @@ -284,6 +294,7 @@ DEFAULT-BODY, if present, is used as the body of a default method. (setq name (gv-setter (cadr name)))) `(prog1 (progn + ,@warnings (defalias ',name (cl-generic-define ',name ',args ',(nreverse options)) ,(if (consp doc) ;An expression rather than a constant. -- cgit v1.2.3 From 06ea82e4e3b9c419a632082ddbce7ec5fe933c9c Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 17 Mar 2022 19:07:59 -0400 Subject: Remove some early-bootstrap dependencies for `advice` The dependencies between `advice`, cl-generic`, `bytecomp`, `cl-lib`, `simple`, `help`, ... were becoming unmanageable. Break the reliance on `advice` (which includes making sure the compiler is not needed during the early bootstrap). * lisp/simple.el (pre-redisplay-function): Set without using `add-function`. * lisp/loadup.el (advice, simple): Move to after `cl-generic`. * lisp/help.el (command-error-function): Set without using `add-function`. (help-command-error-confusable-suggestions): Explicitly call `command-error-default-function` instead. * lisp/emacs-lisp/cl-macs.el (pcase--mutually-exclusive-p): Don't optimize during early-bootstrap. * lisp/emacs-lisp/cl-generic.el (cl--generic-lambda): Tiny simplification. (cl-defmethod): Label the obsolescence warning as it should. (cl--generic-compiler): New variable. (cl--generic-get-dispatcher): Use it. (cl--generic-prefill-dispatchers): Make freshly made dispatchers. --- lisp/emacs-lisp/cl-generic.el | 36 +++++++++++++++++++++++++++--------- lisp/emacs-lisp/cl-macs.el | 5 +++-- lisp/help.el | 15 +++++++++++---- lisp/loadup.el | 4 ++-- lisp/simple.el | 8 +++++--- 5 files changed, 48 insertions(+), 20 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 7b11c0c8159..295512d51ef 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -392,9 +392,9 @@ the specializer used will be the one returned by BODY." . ,(lambda () spec-args)) macroexpand-all-environment))) (require 'cl-lib) ;Needed to expand `cl-flet' and `cl-function'. - (when (assq 'interactive (cadr fun)) + (when (assq 'interactive body) (message "Interactive forms not supported in generic functions: %S" - (assq 'interactive (cadr fun)))) + (assq 'interactive body))) ;; First macroexpand away the cl-function stuff (e.g. &key and ;; destructuring args, `declare' and whatnot). (pcase (macroexpand fun macroenv) @@ -526,7 +526,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (let* ((obsolete (get name 'byte-obsolete-info))) (macroexp-warn-and-return (macroexp--obsolete-warning name obsolete "generic function") - nil nil nil orig-name))) + nil (list 'obsolete name) nil orig-name))) ;; You could argue that `defmethod' modifies rather than defines the ;; function, so warnings like "not known to be defined" are fair game. ;; But in practice, it's common to use `cl-defmethod' @@ -614,6 +614,14 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (defvar cl--generic-dispatchers (make-hash-table :test #'equal)) +(defvar cl--generic-compiler + ;; Don't byte-compile the dispatchers if cl-generic itself is not + ;; compiled. Otherwise the byte-compiler and all the code on + ;; which it depends needs to be usable before cl-generic is loaded, + ;; which imposes a significant burden on the bootstrap. + (if (consp (lambda (x) (+ x 1))) + (lambda (exp) (eval exp t)) #'byte-compile)) + (defun cl--generic-get-dispatcher (dispatch) (with-memoization ;; We need `copy-sequence` here because this `dispatch' object might be @@ -658,7 +666,8 @@ The set of acceptable TYPEs (also called \"specializers\") is defined ;; FIXME: For generic functions with a single method (or with 2 methods, ;; one of which always matches), using a tagcode + hash-table is ;; overkill: better just use a `cl-typep' test. - (byte-compile + (funcall + cl--generic-compiler `(lambda (generic dispatches-left methods) ;; FIXME: We should find a way to expand `with-memoize' once ;; and forall so we don't need `subr-x' when we get here. @@ -886,11 +895,20 @@ those methods.") (setq arg-or-context `(&context . ,arg-or-context))) (unless (fboundp 'cl--generic-get-dispatcher) (require 'cl-generic)) - (let ((fun (cl--generic-get-dispatcher - `(,arg-or-context - ,@(apply #'append - (mapcar #'cl-generic-generalizers specializers)) - ,cl--generic-t-generalizer)))) + (let ((fun + ;; Let-bind cl--generic-dispatchers so we *re*compute the function + ;; from scratch, since the one in the cache may be non-compiled! + (let ((cl--generic-dispatchers (make-hash-table)) + ;; When compiling `cl-generic' during bootstrap, make sure + ;; we prefill with compiled dispatchers even though the loaded + ;; `cl-generic' is still interpreted. + (cl--generic-compiler + (if (featurep 'bytecomp) #'byte-compile cl--generic-compiler))) + (cl--generic-get-dispatcher + `(,arg-or-context + ,@(apply #'append + (mapcar #'cl-generic-generalizers specializers)) + ,cl--generic-t-generalizer))))) ;; Recompute dispatch at run-time, since the generalizers may be slightly ;; different (e.g. byte-compiled rather than interpreted). ;; FIXME: There is a risk that the run-time generalizer is not equivalent diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 0d0b5b51587..5d2a7c03ac4 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3279,8 +3279,9 @@ the form NAME which is a shorthand for (NAME NAME)." (funcall orig pred1 (cl--defstruct-predicate t2)))) (funcall orig pred1 pred2)))) -(advice-add 'pcase--mutually-exclusive-p - :around #'cl--pcase-mutually-exclusive-p) +(when (fboundp 'advice-add) ;Not available during bootstrap. + (advice-add 'pcase--mutually-exclusive-p + :around #'cl--pcase-mutually-exclusive-p)) (defun cl-struct-sequence-type (struct-type) diff --git a/lisp/help.el b/lisp/help.el index f1a617f8500..780f5daac73 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -621,7 +621,7 @@ If INSERT (the prefix arg) is non-nil, insert the message in the buffer." (enable-recursive-minibuffers t) val) (setq val (completing-read (format-prompt "Where is command" fn) - obarray 'commandp t nil nil + obarray #'commandp t nil nil (and fn (symbol-name fn)))) (list (unless (equal val "") (intern val)) current-prefix-arg))) @@ -2147,7 +2147,10 @@ the suggested string to use instead. See confusables ", ") string)))) -(defun help-command-error-confusable-suggestions (data _context _signal) +(defun help-command-error-confusable-suggestions (data context signal) + ;; Delegate most of the work to the original default value of + ;; `command-error-function' implemented in C. + (command-error-default-function data context signal) (pcase data (`(void-variable ,var) (let ((suggestions (help-uni-confusable-suggestions @@ -2156,8 +2159,12 @@ the suggested string to use instead. See (princ (concat "\n " suggestions) t)))) (_ nil))) -(add-function :after command-error-function - #'help-command-error-confusable-suggestions) +(when (eq command-error-function #'command-error-default-function) + ;; Override the default set in the C code. + ;; This is not done using `add-function' so as to loosen the bootstrap + ;; dependencies. + (setq command-error-function + #'help-command-error-confusable-suggestions)) (define-obsolete-function-alias 'help-for-help-internal #'help-for-help "28.1") diff --git a/lisp/loadup.el b/lisp/loadup.el index 81172c584d7..faeb9188e49 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -196,11 +196,9 @@ (setq definition-prefixes new)) (load "button") ;After loaddefs, because of define-minor-mode! -(load "emacs-lisp/nadvice") (load "emacs-lisp/cl-preloaded") (load "obarray") ;abbrev.el is implemented in terms of obarrays. (load "abbrev") ;lisp-mode.el and simple.el use define-abbrev-table. -(load "simple") (load "help") @@ -251,6 +249,8 @@ (let ((max-specpdl-size (max max-specpdl-size 1800))) ;; A particularly demanding file to load; 1600 does not seem to be enough. (load "emacs-lisp/cl-generic")) +(load "simple") +(load "emacs-lisp/nadvice") (load "minibuffer") ;Needs cl-generic (and define-minor-mode). (load "frame") (load "startup") diff --git a/lisp/simple.el b/lisp/simple.el index accc119e2b3..83f27e0dbb4 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -6545,9 +6545,11 @@ is set to the buffer displayed in that window.") (with-current-buffer (window-buffer win) (run-hook-with-args 'pre-redisplay-functions win)))))) -(add-function :before pre-redisplay-function - #'redisplay--pre-redisplay-functions) - +(when (eq pre-redisplay-function #'ignore) + ;; Override the default set in the C code. + ;; This is not done using `add-function' so as to loosen the bootstrap + ;; dependencies. + (setq pre-redisplay-function #'redisplay--pre-redisplay-functions)) (defvar-local mark-ring nil "The list of former marks of the current buffer, most recent first.") -- cgit v1.2.3 From ab8a34ce8a54539cc9f66892145153312fa2a7fa Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 18 Mar 2022 16:07:42 -0400 Subject: * lisp/emacs-lisp/bytecomp.el (byte-compile-make-closure): Minor optimization --- lisp/emacs-lisp/bytecomp.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index c680437f324..c39d931517e 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3924,7 +3924,7 @@ discarding." docstring-exp)) ;Otherwise, we don't need a closure. (cl-assert (byte-code-function-p fun)) (byte-compile-form - (if (or (not docstring-exp) (stringp docstring-exp)) + (if (macroexp-const-p docstring-exp) ;; Use symbols V0, V1 ... as placeholders for closure variables: ;; they should be short (to save space in the .elc file), yet ;; distinct when disassembled. @@ -3940,7 +3940,7 @@ discarding." (vconcat dummy-vars (aref fun 2)) (aref fun 3) (if docstring-exp - (cons docstring-exp (cdr opt-args)) + (cons (eval docstring-exp t) (cdr opt-args)) opt-args)))) `(make-closure ,proto-fun ,@env)) ;; Nontrivial doc string expression: create a bytecode object -- cgit v1.2.3 From 71b8f1fc635d9bbe00ca89457065e0c83456ac43 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 19 Mar 2022 15:11:15 +0100 Subject: Make `command-modes' work for (native-compiled) subrs, too * lisp/emacs-lisp/comp.el (comp-func): Add a command-modes slot. (comp-spill-lap-function, comp-intern-func-in-ctxt): Fill it. (comp-emit-for-top-level, comp-emit-lambda-for-top-level): Use it. * src/alloc.c (mark_object): Mark the command_modes slot. * src/comp.c (make_subr): Add a command_modes parameter. (Fcomp__register_lambda): Use it. (Fcomp__register_subr): Ditto. * src/data.c (Fcommand_modes): Output the command_modes data for subrs (bug#54437). * src/lisp.h (GCALIGNED_STRUCT): Add a command_modes slot. * src/pdumper.c (dump_subr): Update hash. (dump_subr): Dump the command_modes slot. --- lisp/emacs-lisp/comp.el | 12 ++++++++++-- src/alloc.c | 1 + src/comp.c | 16 +++++++++++++--- src/data.c | 6 +++++- src/lisp.h | 1 + src/pdumper.c | 4 +++- 6 files changed, 33 insertions(+), 7 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 122638077ce..00efedd71f3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -898,6 +898,8 @@ non local exit (ends with an `unreachable' insn).")) :documentation "Doc string.") (int-spec nil :type list :documentation "Interactive form.") + (command-modes nil :type list + :documentation "Command modes.") (lap () :type list :documentation "LAP assembly representation.") (ssa-status nil :type symbol @@ -1243,6 +1245,7 @@ clashes." :c-name c-name :doc (documentation f t) :int-spec (interactive-form f) + :command-modes (command-modes f) :speed (comp-spill-speed function-name) :pure (comp-spill-decl-spec function-name 'pure)))) @@ -1282,10 +1285,12 @@ clashes." (make-comp-func-l :c-name c-name :doc (documentation form t) :int-spec (interactive-form form) + :command-modes (command-modes form) :speed (comp-ctxt-speed comp-ctxt)) (make-comp-func-d :c-name c-name :doc (documentation form t) :int-spec (interactive-form form) + :command-modes (command-modes form) :speed (comp-ctxt-speed comp-ctxt))))) (let ((lap (byte-to-native-lambda-lap (gethash (aref byte-code 1) @@ -1327,6 +1332,7 @@ clashes." (comp-func-byte-func func) byte-func (comp-func-doc func) (documentation byte-func t) (comp-func-int-spec func) (interactive-form byte-func) + (comp-func-command-modes func) (command-modes byte-func) (comp-func-c-name func) c-name (comp-func-lap func) lap (comp-func-frame-size func) (comp-byte-frame-size byte-func) @@ -2079,7 +2085,8 @@ and the annotation emission." (i (hash-table-count h))) (puthash i (comp-func-doc f) h) i) - (comp-func-int-spec f))) + (comp-func-int-spec f) + (comp-func-command-modes f))) ;; This is the compilation unit it-self passed as ;; parameter. (make-comp-mvar :slot 0)))))) @@ -2122,7 +2129,8 @@ These are stored in the reloc data array." (i (hash-table-count h))) (puthash i (comp-func-doc func) h) i) - (comp-func-int-spec func))) + (comp-func-int-spec func) + (comp-func-command-modes func))) ;; This is the compilation unit it-self passed as ;; parameter. (make-comp-mvar :slot 0))))) diff --git a/src/alloc.c b/src/alloc.c index c19e3dabb6e..b0fbc91fe50 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6844,6 +6844,7 @@ mark_object (Lisp_Object arg) set_vector_marked (ptr); struct Lisp_Subr *subr = XSUBR (obj); mark_object (subr->native_intspec); + mark_object (subr->command_modes); mark_object (subr->native_comp_u); mark_object (subr->lambda_list); mark_object (subr->type); diff --git a/src/comp.c b/src/comp.c index 6449eedb278..499eee7e709 100644 --- a/src/comp.c +++ b/src/comp.c @@ -5411,7 +5411,7 @@ native_function_doc (Lisp_Object function) static Lisp_Object make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg, Lisp_Object c_name, Lisp_Object type, Lisp_Object doc_idx, - Lisp_Object intspec, Lisp_Object comp_u) + Lisp_Object intspec, Lisp_Object command_modes, Lisp_Object comp_u) { struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u); dynlib_handle_ptr handle = cu->handle; @@ -5445,6 +5445,7 @@ make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg, x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; x->s.symbol_name = xstrdup (SSDATA (symbol_name)); x->s.native_intspec = intspec; + x->s.command_modes = command_modes; x->s.doc = XFIXNUM (doc_idx); #ifdef HAVE_NATIVE_COMP x->s.native_comp_u = comp_u; @@ -5467,12 +5468,17 @@ This gets called by top_level_run during the load phase. */) { Lisp_Object doc_idx = FIRST (rest); Lisp_Object intspec = SECOND (rest); + Lisp_Object command_modes = Qnil; + if (!NILP (XCDR (XCDR (rest)))) + command_modes = THIRD (rest); + struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u); if (cu->loaded_once) return Qnil; Lisp_Object tem = - make_subr (c_name, minarg, maxarg, c_name, type, doc_idx, intspec, comp_u); + make_subr (c_name, minarg, maxarg, c_name, type, doc_idx, intspec, + command_modes, comp_u); /* We must protect it against GC because the function is not reachable through symbols. */ @@ -5497,9 +5503,13 @@ This gets called by top_level_run during the load phase. */) { Lisp_Object doc_idx = FIRST (rest); Lisp_Object intspec = SECOND (rest); + Lisp_Object command_modes = Qnil; + if (!NILP (XCDR (XCDR (rest)))) + command_modes = THIRD (rest); + Lisp_Object tem = make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, type, doc_idx, - intspec, comp_u); + intspec, command_modes, comp_u); defalias (name, tem); diff --git a/src/data.c b/src/data.c index 23b0e7c29d9..5894340aba3 100644 --- a/src/data.c +++ b/src/data.c @@ -1167,7 +1167,11 @@ The value, if non-nil, is a list of mode name symbols. */) fun = Fsymbol_function (fun); } - if (COMPILEDP (fun)) + if (SUBRP (fun)) + { + return XSUBR (fun)->command_modes; + } + else if (COMPILEDP (fun)) { if (PVSIZE (fun) <= COMPILED_INTERACTIVE) return Qnil; diff --git a/src/lisp.h b/src/lisp.h index e4d156c0f45..b558d311a80 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2154,6 +2154,7 @@ struct Lisp_Subr const char *intspec; Lisp_Object native_intspec; }; + Lisp_Object command_modes; EMACS_INT doc; #ifdef HAVE_NATIVE_COMP Lisp_Object native_comp_u; diff --git a/src/pdumper.c b/src/pdumper.c index f14239f863a..11831023622 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2854,7 +2854,7 @@ dump_bool_vector (struct dump_context *ctx, const struct Lisp_Vector *v) static dump_off dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) { -#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_F09D8E8E19) +#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_A212A8F82A) # error "Lisp_Subr changed. See CHECK_STRUCTS comment in config.h." #endif struct Lisp_Subr out; @@ -2878,11 +2878,13 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) COLD_OP_NATIVE_SUBR, make_lisp_ptr ((void *) subr, Lisp_Vectorlike)); dump_field_lv (ctx, &out, subr, &subr->native_intspec, WEIGHT_NORMAL); + dump_field_lv (ctx, &out, subr, &subr->command_modes, WEIGHT_NORMAL); } else { dump_field_emacs_ptr (ctx, &out, subr, &subr->symbol_name); dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec); + dump_field_emacs_ptr (ctx, &out, subr, &subr->command_modes); } DUMP_FIELD_COPY (&out, subr, doc); #ifdef HAVE_NATIVE_COMP -- cgit v1.2.3 From fd5fe11211a469c42fb7142f5a26f577e8ff0010 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Mon, 21 Mar 2022 19:15:55 +0100 Subject: Don't break autoload generation of `left-margin' isn't zero * lisp/emacs-lisp/autoload.el (make-directory-autoloads): Fix autoload generation breakage is left-margin isn't zero (bug#54491). --- lisp/emacs-lisp/autoload.el | 3 +++ 1 file changed, 3 insertions(+) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index d0bf342b842..1e4b2c14a01 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -1108,6 +1108,9 @@ directory or directories specified." ;; Files with no autoload cookies or whose autoloads go to other ;; files because of file-local autoload-generated-file settings. (no-autoloads nil) + ;; Ensure that we don't do odd things when putting the doc + ;; strings into the autoloads file. + (left-margin 0) (autoload-modified-buffers nil) (output-time (and (file-exists-p output-file) -- cgit v1.2.3 From 45978f97be89ae989ecf9e7129b88592e70a1f24 Mon Sep 17 00:00:00 2001 From: Augusto Stoffel Date: Thu, 24 Mar 2022 15:05:39 +0000 Subject: Handle invisible text in Eldoc when calculating size MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: João Távora * lisp/emacs-lisp/eldoc.el (eldoc--echo-area-substring, eldoc-display-in-echo-area): Take invisible text into consideration when counting lines to crop an echo-area message. (Version): Bump. --- lisp/emacs-lisp/eldoc.el | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 73713a3dec9..74ffeb166d4 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -5,7 +5,7 @@ ;; Author: Noah Friedman ;; Keywords: extensions ;; Created: 1995-10-06 -;; Version: 1.11.0 +;; Version: 1.11.1 ;; Package-Requires: ((emacs "26.3")) ;; This is a GNU ELPA :core package. Avoid functionality that is not @@ -102,7 +102,7 @@ put in the echo area. If a positive integer, the number is used directly, while a float specifies the number of lines as a proportion of the echo area frame's height. -If value is the symbol `truncate-sym-name-if-fit' t, the part of +If value is the symbol `truncate-sym-name-if-fit', the part of the doc string that represents a symbol's name may be truncated if it will enable the rest of the doc string to fit on a single line, without resizing the echo area. @@ -525,7 +525,8 @@ Helper for `eldoc-display-in-echo-area'." (goto-char (point-min)) (skip-chars-forward " \t\n") (point)) - (goto-char (line-end-position available)) + (forward-visible-line (1- available)) + (end-of-visible-line) (skip-chars-backward " \t\n"))) (truncated (save-excursion (skip-chars-forward " \t\n") @@ -535,7 +536,8 @@ Helper for `eldoc-display-in-echo-area'." ((and truncated (> available 1) eldoc-echo-area-display-truncation-message) - (goto-char (line-end-position 0)) + (forward-visible-line -1) + (end-of-visible-line) (concat (buffer-substring start (point)) (format "\n(Documentation truncated. Use `%s' to see rest)" @@ -610,7 +612,8 @@ Honor `eldoc-echo-area-use-multiline-p' and (let ((string (with-current-buffer (eldoc--format-doc-buffer docs) (buffer-substring (goto-char (point-min)) - (line-end-position 1))))) + (progn (end-of-visible-line) + (point)))))) (if (> (length string) width) ; truncation to happen (unless (eldoc--echo-area-prefer-doc-buffer-p t) (truncate-string-to-width string width)) -- cgit v1.2.3 From 3e7257c3ed3e7f5451d4dab0b222f93a2d1b2aa3 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 25 Mar 2022 16:44:01 +0100 Subject: Improve pp-last-sexp ergonomics * lisp/emacs-lisp/pp.el (pp-last-sexp): Ignore ,@? before a sexp, because eval-ing that will always lead to an error (bug#54537). --- lisp/emacs-lisp/pp.el | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index e782cdb1dab..ad693fa5a61 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -177,6 +177,10 @@ Also add the value to the front of the list in the variable `values'." (let ((pt (point))) (save-excursion (forward-sexp -1) + ;; Make `pp-eval-last-sexp' work the same way `eval-last-sexp' + ;; does. + (when (looking-at ",@?") + (goto-char (match-end 0))) (read ;; If first line is commented, ignore all leading comments: (if (save-excursion (beginning-of-line) (looking-at-p "[ \t]*;")) -- cgit v1.2.3 From 52d5771e0a803f57b8cdd7675bf15f2f9b946039 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 28 Mar 2022 10:53:14 -0400 Subject: Add OClosures, a cross between functions and structs We here just add the new type. It is not fully self-contained. It requires cooperation from `cconv.el` on the one hand, and it hijacks the docstring info to hold the type of OClosure objects. This does imply that OClosures can't have docstrings, tho this limitation will be lifted in subsequent patches. * lisp/emacs-lisp/oclosure.el: New file. * test/lisp/emacs-lisp/oclosure-tests.el: New file. * doc/lispref/functions.texi (OClosures): New section. * src/eval.c (Ffunction): Accept symbols instead of strings for docstrings. * src/doc.c (store_function_docstring): Avoid overwriting an OClosure type. * lisp/emacs-lisp/cconv.el (cconv--convert-function): Tweak ordering of captured variables. (cconv-convert): Add case for `oclosure--fix-type`. --- doc/lispref/functions.texi | 111 +++++++ etc/NEWS | 5 + lisp/emacs-lisp/cconv.el | 18 +- lisp/emacs-lisp/oclosure.el | 522 +++++++++++++++++++++++++++++++++ src/doc.c | 12 +- src/eval.c | 4 + test/lisp/emacs-lisp/oclosure-tests.el | 113 +++++++ 7 files changed, 781 insertions(+), 4 deletions(-) create mode 100644 lisp/emacs-lisp/oclosure.el create mode 100644 test/lisp/emacs-lisp/oclosure-tests.el (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi index 207919ea645..70337d4c4a8 100644 --- a/doc/lispref/functions.texi +++ b/doc/lispref/functions.texi @@ -22,6 +22,7 @@ define them. * Function Cells:: Accessing or setting the function definition of a symbol. * Closures:: Functions that enclose a lexical environment. +* OClosures:: Function objects * Advising Functions:: Adding to the definition of a function. * Obsolete Functions:: Declaring functions obsolete. * Inline Functions:: Functions that the compiler will expand inline. @@ -1509,6 +1510,116 @@ exposed to the rest of the Lisp world is considered an internal implementation detail. For this reason, we recommend against directly examining or altering the structure of closure objects. +@node OClosures +@section Open Closures + +Traditionally, functions are opaque objects which offer no other +functionality but to call them. Emacs Lisp functions aren't fully +opaque since you can extract some info out of them such as their +docstring, their arglist, or their interactive spec, but they are +mostly opaque. This is usually what we want, but occasionally we need +functions to expose a bit more information about themselves. + +OClosures are functions which carry additional type information, +and expose some information in the form of slots which you can access +via accessor functions. + +They are defined in two steps: first @code{oclosure-define} is used to +define new OClosure types by specifying the slots carried by those +OClosures, and then @code{oclosure-lambda} is used to create an +OClosure object of a given type. + +Say we want to define keyboard macros, i.e. interactive functions +which re-execute a sequence of key events. You could do it with +a plain function as follows: +@example +(defun kbd-macro (key-sequence) + (lambda (&optional arg) + (interactive "P") + (execute-kbd-macro key-sequence arg))) +@end example +But with such a definition there is no easy way to extract the +@var{key-sequence} from that function, for example to print it. + +We can solve this problem using OClosures as follows. First we define +the type of our keyboard macros (to which we decided to add +a @code{counter} slot while at it): +@example +(oclosure-define kbd-macro + "Keyboard macro." + keys (counter :mutable t)) +@end example +After which we can rewrite our @code{kbd-macro} function: +@example +(defun kbd-macro (key-sequence) + (oclosure-lambda (kbd-macro (keys key-sequence) (counter 0)) + (&optional arg) + (interactive "p") + (execute-kbd-macro keys arg) + (setq counter (1+ counter)))) +@end example +As you can see, the @code{keys} and @code{counter} slots of the +OClosure can be accessed as local variables from within the body +of the OClosure. But we can now also access them from outside of the +body of the OClosure, for example to describe a keyboard macro: +@example +(defun describe-kbd-macro (km) + (if (not (eq 'kbd-macro (oclosure-type km))) + (message "Not a keyboard macro") + (let ((keys (kbd-macro--keys km)) + (counter (kbd-macro--counter km))) + (message "Keys=%S, called %d times" keys counter)))) +@end example +Where @code{kbd-macro--keys} and @code{kbd-macro--counter} are +accessor functions generated by the @code{oclosure-define} macro. + +@defmac oclosure-define name &optional docstring &rest slots +This macro defines a new OClosure type along with accessor functions +for its slots. @var{name} can be a symbol (the name of +the new type), or a list of the form @code{(@var{name} . @var{type-props})} in +which case @var{type-props} is a list of additional properties. +@var{slots} is a list of slot descriptions where each slot can be +either a symbol (the name of the slot) or it can be of the form +@code{(@var{slot-name} . @var{slot-props})} where @var{slot-props} is +a property list. + +For each slot, the macro creates an accessor function named +@code{@var{name}--@var{slot-name}}. By default slots are immutable. +If you need a slot to be mutable, you need to specify it with the +@code{:mutable} slot property, after which it can be mutated for +example with @code{setf}. + +Beside slot accessors, the macro can create a predicate and +functional update functions according to @var{type-props}: +a @code{(:predicate @var{pred-name})} in the @var{type-props} causes +the definition of a predicate function under the name @var{pred-name}, +and @code{(:copier @var{copier-name} @var{copier-arglist})} causes the +definition of a functional update function which takes an OClosure of +type @var{name} as first argument and returns a copy of it with the +slots named in @var{copier-arglist} modified to the value passed in the +corresponding argument. +@end defmac + +@defmac oclosure-lambda (type . slots) arglist &rest body +This macro creates an anonymous OClosure of type @var{type}. +@var{slots} should be a list of elements of the form @code{(@var{slot-name} +@var{exp})}. +At run time, each @var{exp} is evaluated, in order, after which +the OClosure is created with its slots initialized with the +resulting values. + +When called as a function, the OClosure will accept arguments +according to @var{arglist} and will execute the code in @var{body}. +@var{body} can refer to the value of any of its slot directly as if it +were a local variable that had been captured by static scoping. +@end defmac + +@defun oclosure-type object +This function returns the OClosure type (a symbol) of @var{object} if it is an +OClosure, and nil otherwise. +@end defun + + @node Advising Functions @section Advising Emacs Lisp Functions @cindex advising functions diff --git a/etc/NEWS b/etc/NEWS index b6ae8bb9cf6..e684ee30f0e 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1156,6 +1156,11 @@ It is believed to no longer be useful. * New Modes and Packages in Emacs 29.1 ++++ +** New package 'oclosure'. +Allows the creation of "functions with slots" or "function objects" +via the macros `oclosure-define` and `oclosure-lambda`. + --- ** New theme 'leuven-dark'. This is a dark version of the 'leuven' theme. diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index c16619bc45d..be4fea7be14 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -201,7 +201,10 @@ Returns a form where all lambdas don't have any free variables." (i 0) (new-env ())) ;; Build the "formal and actual envs" for the closure-converted function. - (dolist (fv fvs) + ;; Hack for OClosure: `nreverse' here intends to put the captured vars + ;; in the closure such that the first one is the one that is bound + ;; most closely. + (dolist (fv (nreverse fvs)) (let ((exp (or (cdr (assq fv env)) fv))) (pcase exp ;; If `fv' is a variable that's wrapped in a cons-cell, @@ -240,7 +243,7 @@ Returns a form where all lambdas don't have any free variables." ;; 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)) + (if (not (eq (cadr mapping) #'apply-partially)) mapping (cl-assert (eq (car mapping) (nth 2 mapping))) `(,(car mapping) @@ -449,6 +452,9 @@ places where they originally did not directly appear." (let ((var-def (cconv--lifted-arg var env)) (closedsym (make-symbol (format "closed-%s" var)))) (setq new-env (cconv--remap-llv new-env var closedsym)) + ;; FIXME: `closedsym' doesn't need to be added to `extend' + ;; but adding it makes it easier to write the assertion at + ;; the beginning of this function. (setq new-extend (cons closedsym (remq var new-extend))) (push `(,closedsym ,var-def) binders-new))) @@ -604,6 +610,14 @@ places where they originally did not directly appear." (`(declare . ,_) form) ;The args don't contain code. + (`(oclosure--fix-type (ignore . ,vars) ,exp) + (dolist (var vars) + (let ((x (assq var env))) + (pcase (cdr x) + (`(car-safe . ,_) (error "Slot %S should not be mutated" var)) + (_ (cl-assert (null (cdr x))))))) + (cconv-convert exp env extend)) + (`(,func . ,forms) ;; First element is function or whatever function-like forms are: or, and, ;; if, catch, progn, prog1, while, until diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el new file mode 100644 index 00000000000..3d17c6c668c --- /dev/null +++ b/lisp/emacs-lisp/oclosure.el @@ -0,0 +1,522 @@ +;;; oclosure.el --- Open Closures -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2022 Free Software Foundation, Inc. + +;; Author: Stefan Monnier + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; An OClosure is an object that combines the properties of records +;; with those of a function. More specifically it is a function extended +;; with a notion of type (e.g. for defmethod dispatch) as well as the +;; ability to have some fields that are accessible from the outside. + +;; See "Open closures", ELS'2022 (https://zenodo.org/record/6228797). + +;; Here are some cases of "callable objects" where OClosures have found use: +;; - nadvice.el (the original motivation) +;; - kmacros (for cl-print and for `kmacro-extract-lambda') +;; - cl-generic: turn `cl--generic-isnot-nnm-p' into a mere type test +;; (by putting the no-next-methods into their own class). +;; - Slot accessor functions, where the type-dispatch can be used to +;; dynamically compute the docstring, and also to pretty print them. +;; - `save-some-buffers-function' +;; Here are other cases of "callable objects" where OClosures could be used: +;; - Use the type to distinguish macros from functions. +;; - Use a `name' and `depth' property from the function passed to +;; `add-function' (or `add-hook') instead of passing it via "props". +;; - iterators (generator.el), thunks (thunk.el), streams (stream.el). +;; - PEG rules: they're currently just functions, but they should carry +;; their original (macro-expanded) definition (and should be printed +;; differently from functions)! +;; - auto-generate docstrings for cl-defstruct slot accessors instead of +;; storing them in the accessor itself? +;; - SRFI-17's `setter'. +;; - coercion wrappers, as in "Threesomes, with and without blame" +;; https://dl.acm.org/doi/10.1145/1706299.1706342, or +;; "On the Runtime Complexity of Type-Directed Unboxing" +;; http://sv.c.titech.ac.jp/minamide/papers.html +;; - An efficient `negate' operation such that +;; (negate (negate f)) returns just `f' and (negate #'<) returns #'>=. +;; - Autoloads (tho currently our bytecode functions (and hence OClosures) +;; are too fat for that). + +;; Related constructs: +;; - `funcallable-standard-object' (FSO) in Common-Lisp. These are different +;; from OClosures in that they involve an additional indirection to get +;; to the actual code, and that they offer the possibility of +;; changing (via mutation) the code associated with +;; an FSO. Also the FSO's function can't directly access the FSO's +;; other fields, contrary to the case with OClosures where those are directly +;; available as local variables. +;; - Function objects in Javascript. +;; - Function objects in Python. +;; - Callable/Applicable classes in OO languages, i.e. classes with +;; a single method called `apply' or `call'. The most obvious +;; difference with OClosures (beside the fact that Callable can be +;; extended with additional methods) is that all instances of +;; a given Callable class have to use the same method, whereas every +;; OClosure object comes with its own code, so two OClosure objects of the +;; same type can have different code. Of course, you can get the +;; same result by turning every `oclosure-lambda' into its own class +;; declaration creating an ad-hoc subclass of the specified type. +;; In this sense, OClosures are just a generalization of `lambda' which brings +;; some of the extra feature of Callable objects. +;; - Apply hooks and "entities" in MIT Scheme +;; https://www.gnu.org/software/mit-scheme/documentation/stable/mit-scheme-ref/Application-Hooks.html +;; Apply hooks are basically the same as Common-Lisp's FSOs, and "entities" +;; are a variant of it where the inner function gets the FSO itself as +;; additional argument (a kind of "self" arg), thus making it easier +;; for the code to get data from the object's extra info, tho still +;; not as easy as with OClosures. +;; - "entities" in Lisp Machine Lisp (LML) +;; https://hanshuebner.github.io/lmman/fd-clo.xml +;; These are arguably identical to OClosures, modulo the fact that LML doesn't +;; have lexically-scoped closures and uses a form of closures based on +;; capturing (and reinstating) dynamically scoped bindings instead. + +;; Naming: OClosures were originally named FunCallableRecords (FCR), but +;; that name suggested these were fundamentally records that happened +;; to be called, whereas OClosures are really just closures that happen +;; to enjoy some characteristics of records. +;; The "O" comes from "Open" because OClosures aren't completely opaque +;; (for that same reason, an alternative name suggested at the time was +;; "disclosures"). +;; The "O" can also be understood to mean "Object" since you have notions +;; of inheritance, and the ability to associate methods with particular +;; OClosure types, just as is the case for OO classes. + +;;; Code: + +;; TODO: +;; - `oclosure-(cl-)defun', `oclosure-(cl-)defsubst', `oclosure-define-inline'? +;; - Use accessor in cl-defstruct. +;; - Add pcase patterns for OClosures. +;; - anonymous OClosure types. +;; - copiers for mixins +;; - class-allocated slots? +;; - code-allocated slots? +;; The `where' slot of `advice' would like to be code-allocated, and the +;; interactive-spec of commands is currently code-allocated but would like +;; to be instance-allocated. Their scoping rules are a bit odd, so maybe +;; it's best to avoid them. + +(eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'subr-x)) ;For `named-let'. + +(defun oclosure--index-table (slotdescs) + (let ((i -1) + (it (make-hash-table :test #'eq))) + (dolist (desc slotdescs) + (let* ((slot (cl--slot-descriptor-name desc))) + (cl-incf i) + (when (gethash slot it) + (error "Duplicate slot name: %S" slot)) + (setf (gethash slot it) i))) + it)) + +(cl-defstruct (oclosure--class + (:constructor nil) + (:constructor oclosure--class-make + ( name docstring slots parents + &aux (index-table (oclosure--index-table slots)))) + (:include cl--class) + (:copier nil)) + "Metaclass for OClosure classes.") + +(setf (cl--find-class 'oclosure) + (oclosure--class-make 'oclosure + "The root parent of all OClosure classes" + nil nil)) +(defun oclosure--p (oclosure) + (not (not (oclosure-type oclosure)))) + +(cl-deftype oclosure () '(satisfies oclosure--p)) + +(defun oclosure--slot-mutable-p (slotdesc) + (not (alist-get :read-only (cl--slot-descriptor-props slotdesc)))) + +(defun oclosure--defstruct-make-copiers (copiers slotdescs name) + (require 'cl-macs) ;`cl--arglist-args' is not autoloaded. + (let* ((mutables '()) + (slots (mapcar + (lambda (desc) + (let ((name (cl--slot-descriptor-name desc))) + (when (oclosure--slot-mutable-p desc) + (push name mutables)) + name)) + slotdescs))) + (mapcar + (lambda (copier) + (pcase-let* + ((cname (pop copier)) + (args (or (pop copier) `(&key ,@slots))) + (inline (and (eq :inline (car copier)) (pop copier))) + (doc (or (pop copier) + (format "Copier for objects of type `%s'." name))) + (obj (make-symbol "obj")) + (absent (make-symbol "absent")) + (anames (cl--arglist-args args)) + (mnames + (let ((res '()) + (tmp args)) + (while (and tmp + (not (memq (car tmp) + cl--lambda-list-keywords))) + (push (pop tmp) res)) + res)) + (index -1) + (mutlist '()) + (argvals + (mapcar + (lambda (slot) + (setq index (1+ index)) + (let* ((mutable (memq slot mutables)) + (get `(oclosure--get ,obj ,index ,(not (not mutable))))) + (push mutable mutlist) + (cond + ((not (memq slot anames)) get) + ((memq slot mnames) slot) + (t + `(if (eq ',absent ,slot) + ,get + ,slot))))) + slots))) + `(,(if inline 'cl-defsubst 'cl-defun) ,cname + (&cl-defs (',absent) ,obj ,@args) + ,doc + (declare (side-effect-free t)) + (oclosure--copy ,obj ',(if (remq nil mutlist) (nreverse mutlist)) + ,@argvals)))) + copiers))) + + +(defmacro oclosure-define (name &optional docstring &rest slots) + "Define a new OClosure type. +NAME should be a symbol which is the name of the new type. +It can also be of the form (NAME . PROPS) in which case PROPS +is a list of additional properties among the following: + (:predicate PRED): asks to create a predicate function named PRED. + (:parent TYPE): make TYPE (another OClosure type) be a parent of NAME. + (:copier COPIER ARGS): asks to create a \"copier\" (i.e. functional update + function) named COPIER. It will take an object of type NAME as first + argument followed by ARGS. ARGS lists the names of the slots that will + be updated with the value of the corresponding argument. +SLOTS is a list if slot descriptions. Each slot can be a single symbol +which is the name of the slot, or it can be of the form (SLOT-NAME . SPROPS) +where SLOT-NAME is then the name of the slot and SPROPS is a property +list of slot properties. The currently known properties are the following: + `:mutable': A non-nil value mean the slot can be mutated. + `:type': Specifies the type of the values expected to appear in the slot." + (declare (doc-string 2) (indent 1)) + (unless (stringp docstring) + (push docstring slots) + (setq docstring nil)) + (let* ((options (when (consp name) + (prog1 (copy-sequence (cdr name)) + (setq name (car name))))) + (get-opt (lambda (opt &optional all) + (let ((val (assq opt options)) + tmp) + (when val (setq options (delq val options))) + (if (not all) + (cdr val) + (when val + (setq val (list (cdr val))) + (while (setq tmp (assq opt options)) + (push (cdr tmp) val) + (setq options (delq tmp options))) + (nreverse val)))))) + (predicate (car (funcall get-opt :predicate))) + (parent-names (or (funcall get-opt :parent) + (funcall get-opt :include))) + (copiers (funcall get-opt :copier 'all))) + `(progn + ,(when options (macroexp-warn-and-return name + (format "Ignored options: %S" options) + nil)) + (eval-and-compile + (oclosure--define ',name ,docstring ',parent-names ',slots + ,@(when predicate `(:predicate ',predicate)))) + (oclosure--define-functions ,name ,copiers)))) + +(defun oclosure--build-class (name docstring parent-names slots) + (cl-assert (null (cdr parent-names))) + (let* ((parent-class (let ((name (or (car parent-names) 'oclosure))) + (or (cl--find-class name) + (error "Unknown class: %S" name)))) + (slotdescs + (append + (oclosure--class-slots parent-class) + (mapcar (lambda (field) + (if (not (consp field)) + (cl--make-slot-descriptor field nil nil + '((:read-only . t))) + (let ((name (pop field)) + (type nil) + (read-only t) + (props '())) + (while field + (pcase (pop field) + (:mutable (setq read-only (not (car field)))) + (:type (setq type (car field))) + (p (message "Unknown property: %S" p) + (push (cons p (car field)) props))) + (setq field (cdr field))) + (cl--make-slot-descriptor name nil type + `((:read-only . ,read-only) + ,@props))))) + slots)))) + (oclosure--class-make name docstring slotdescs + (if (cdr parent-names) + (oclosure--class-parents parent-class) + (list parent-class))))) + +(defmacro oclosure--define-functions (name copiers) + (let* ((class (cl--find-class name)) + (slotdescs (oclosure--class-slots class))) + `(progn + ,@(let ((i -1)) + (mapcar (lambda (desc) + (let* ((slot (cl--slot-descriptor-name desc)) + (mutable (oclosure--slot-mutable-p desc)) + ;; Always use a double hyphen: if users wants to + ;; make it public, they can do so with an alias. + (aname (intern (format "%S--%S" name slot)))) + (cl-incf i) + (if (not mutable) + `(defalias ',aname + ;; We use `oclosure--copy' instead of + ;; `oclosure--accessor-copy' here to circumvent + ;; bootstrapping problems. + (oclosure--copy + oclosure--accessor-prototype + nil ',name ',slot ,i)) + (require 'gv) ;For `gv-setter'. + `(progn + (defalias ',aname + (oclosure--accessor-copy + oclosure--mut-getter-prototype + ',name ',slot ,i)) + (defalias ',(gv-setter aname) + (oclosure--accessor-copy + oclosure--mut-setter-prototype + ',name ',slot ,i)))))) + slotdescs)) + ,@(oclosure--defstruct-make-copiers + copiers slotdescs name)))) + +(defun oclosure--define (name docstring parent-names slots + &rest props) + (let* ((class (oclosure--build-class name docstring parent-names slots)) + (pred (lambda (oclosure) + (eq name (oclosure-type oclosure)))) + (predname (or (plist-get props :predicate) + (intern (format "%s--internal-p" name))))) + (setf (cl--find-class name) class) + (dolist (slot (oclosure--class-slots class)) + (put (cl--slot-descriptor-name slot) 'slot-name t)) + (defalias predname pred) + (put name 'cl-deftype-satisfies predname))) + +(defmacro oclosure--lambda (type bindings mutables args &rest body) + "Low level construction of an OClosure object. +TYPE should be a form returning an OClosure type (a symbol) +BINDINGS should list all the slots expected by this type, in the proper order. +MUTABLE is a list of symbols indicating which of the BINDINGS +should be mutable. +No checking is performed," + (declare (indent 3) (debug (sexp (&rest (sexp form)) sexp def-body))) + ;; FIXME: Fundamentally `oclosure-lambda' should be a special form. + ;; We define it here as a macro which expands to something that + ;; looks like "normal code" in order to avoid backward compatibility + ;; issues with third party macros that do "code walks" and would + ;; likely mishandle such a new special form (e.g. `generator.el'). + ;; But don't be fooled: this macro is tightly bound to `cconv.el'. + (pcase-let* + ((`(,prebody . ,body) (macroexp-parse-body body)) + (rovars (mapcar #'car bindings))) + (dolist (mutable mutables) + (setq rovars (delq mutable rovars))) + `(let ,(mapcar (lambda (bind) + (if (cdr bind) bind + ;; Bind to something that doesn't look + ;; like a value to avoid the "Variable + ;; ‘foo’ left uninitialized" warning. + `(,(car bind) (progn nil)))) + (reverse bindings)) + ;; FIXME: Make sure the slotbinds whose value is duplicable aren't + ;; just value/variable-propagated by the optimizer (tho I think our + ;; optimizer is too naive to be a problem currently). + (oclosure--fix-type + ;; This `oclosure--fix-type' + `ignore' call is used by the compiler (in + ;; `cconv.el') to detect and signal an error in case of + ;; store-conversion (i.e. if a variable/slot is mutated). + (ignore ,@rovars) + (lambda ,args + (:documentation ,type) + ,@prebody + ;; Add dummy code which accesses the field's vars to make sure + ;; they're captured in the closure. + (if t nil ,@rovars ,@(mapcar (lambda (m) `(setq ,m ,m)) mutables)) + ,@body))))) + +(defmacro oclosure-lambda (type-and-slots args &rest body) + "Define anonymous OClosure function. +TYPE-AND-SLOTS should be of the form (TYPE . SLOTS) +where TYPE is an OClosure type name (defined by `oclosure-define') +and SLOTS is a let-style list of bindings for the various slots of TYPE. +ARGS and BODY are the same as for `lambda'." + (declare (indent 2) (debug ((sexp &rest (sexp form)) sexp def-body))) + ;; FIXME: Should `oclosure-define' distinguish "optional" from + ;; "mandatory" slots, and/or provide default values for slots missing + ;; from `fields'? + (pcase-let* + ((`(,type . ,fields) type-and-slots) + (class (or (cl--find-class type) + (error "Unknown class: %S" type))) + (slots (oclosure--class-slots class)) + (mutables '()) + (slotbinds (mapcar (lambda (slot) + (let ((name (cl--slot-descriptor-name slot))) + (when (oclosure--slot-mutable-p slot) + (push name mutables)) + (list name))) + slots)) + (tempbinds (mapcar + (lambda (field) + (let* ((name (car field)) + (bind (assq name slotbinds))) + (cond + ;; FIXME: Should we also warn about missing slots? + ((not bind) + (error "Unknown slot: %S" name)) + ((cdr bind) + (error "Duplicate slot: %S" name)) + (t + (let ((temp (gensym "temp"))) + (setcdr bind (list temp)) + (cons temp (cdr field))))))) + fields))) + ;; FIXME: Optimize temps away when they're provided in the right order? + `(let ,tempbinds + (oclosure--lambda ',type ,slotbinds ,mutables ,args ,@body)))) + +(defun oclosure--fix-type (_ignore oclosure) + "Helper function to implement `oclosure-lambda' via a macro. +This has 2 uses: +- For interpreted code, this converts the representation of type information + by moving it from the docstring to the environment. +- For compiled code, this is used as a marker which cconv uses to check that + immutable fields are indeed not mutated." + (if (byte-code-function-p oclosure) + ;; Actually, this should never happen since the `cconv.el' should have + ;; optimized away the call to this function. + oclosure + ;; For byte-coded functions, we store the type as a symbol in the docstring + ;; slot. For interpreted functions, there's no specific docstring slot + ;; so `Ffunction' turns the symbol into a string. + ;; We thus have convert it back into a symbol (via `intern') and then + ;; stuff it into the environment part of the closure with a special + ;; marker so we can distinguish this entry from actual variables. + (cl-assert (eq 'closure (car-safe oclosure))) + (let ((typename (nth 3 oclosure))) ;; The "docstring". + (cl-assert (stringp typename)) + (push (cons :type (intern typename)) + (cadr oclosure)) + oclosure))) + +(defun oclosure--copy (oclosure mutlist &rest args) + (if (byte-code-function-p oclosure) + (apply #'make-closure oclosure + (if (null mutlist) + args + (mapcar (lambda (arg) (if (pop mutlist) (list arg) arg)) args))) + (cl-assert (eq 'closure (car-safe oclosure)) + nil "oclosure not closure: %S" oclosure) + (cl-assert (eq :type (caar (cadr oclosure)))) + (let ((env (cadr oclosure))) + `(closure + (,(car env) + ,@(named-let loop ((env (cdr env)) (args args)) + (when args + (cons (cons (caar env) (car args)) + (loop (cdr env) (cdr args))))) + ,@(nthcdr (1+ (length args)) env)) + ,@(nthcdr 2 oclosure))))) + +(defun oclosure--get (oclosure index mutable) + (if (byte-code-function-p oclosure) + (let* ((csts (aref oclosure 2)) + (v (aref csts index))) + (if mutable (car v) v)) + (cl-assert (eq 'closure (car-safe oclosure))) + (cl-assert (eq :type (caar (cadr oclosure)))) + (cdr (nth (1+ index) (cadr oclosure))))) + +(defun oclosure--set (v oclosure index) + (if (byte-code-function-p oclosure) + (let* ((csts (aref oclosure 2)) + (cell (aref csts index))) + (setcar cell v)) + (cl-assert (eq 'closure (car-safe oclosure))) + (cl-assert (eq :type (caar (cadr oclosure)))) + (setcdr (nth (1+ index) (cadr oclosure)) v))) + +(defun oclosure-type (oclosure) + "Return the type of OCLOSURE, or nil if the arg is not a OClosure." + (if (byte-code-function-p oclosure) + (let ((type (and (> (length oclosure) 4) (aref oclosure 4)))) + (if (symbolp type) type)) + (and (eq 'closure (car-safe oclosure)) + (let* ((env (car-safe (cdr oclosure))) + (first-var (car-safe env))) + (and (eq :type (car-safe first-var)) + (cdr first-var)))))) + +(defconst oclosure--accessor-prototype + ;; Use `oclosure--lambda' to circumvent a bootstrapping problem: + ;; `oclosure-accessor' is not yet defined at this point but + ;; `oclosure--accessor-prototype' is needed when defining `oclosure-accessor'. + (oclosure--lambda 'oclosure-accessor ((type) (slot) (index)) nil + (oclosure) (oclosure--get oclosure index nil))) + +(oclosure-define accessor + "OClosure function to access a specific slot of an object." + type slot) + +(oclosure-define (oclosure-accessor + (:parent accessor) + (:copier oclosure--accessor-copy (type slot index))) + "OClosure function to access a specific slot of an OClosure function." + index) + +(defconst oclosure--mut-getter-prototype + (oclosure-lambda (oclosure-accessor (type) (slot) (index)) (oclosure) + (oclosure--get oclosure index t))) +(defconst oclosure--mut-setter-prototype + ;; FIXME: The generated docstring is wrong. + (oclosure-lambda (oclosure-accessor (type) (slot) (index)) (val oclosure) + (oclosure--set val oclosure index))) + +;; Ideally, this should be in `files.el', but that file is loaded +;; before `oclosure.el'. +(oclosure-define (save-some-buffers-function + (:predicate save-some-buffers-function--p))) + + +(provide 'oclosure) +;;; oclosure.el ends here diff --git a/src/doc.c b/src/doc.c index a9f77b25bfa..e361a86c1a1 100644 --- a/src/doc.c +++ b/src/doc.c @@ -514,11 +514,19 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset) { /* This bytecode object must have a slot for the docstring, since we've found a docstring for it. */ - if (PVSIZE (fun) > COMPILED_DOC_STRING) + if (PVSIZE (fun) > COMPILED_DOC_STRING + /* Don't overwrite a non-docstring value placed there, + * such as the symbols used for Oclosures. */ + && (FIXNUMP (AREF (fun, COMPILED_DOC_STRING)) + || STRINGP (AREF (fun, COMPILED_DOC_STRING)) + || CONSP (AREF (fun, COMPILED_DOC_STRING)))) ASET (fun, COMPILED_DOC_STRING, make_fixnum (offset)); else { - AUTO_STRING (format, "No docstring slot for %s"); + AUTO_STRING (format, + (PVSIZE (fun) > COMPILED_DOC_STRING + ? "Docstring slot busy for %s" + : "No docstring slot for %s")); CALLN (Fmessage, format, (SYMBOLP (obj) ? SYMBOL_NAME (obj) diff --git a/src/eval.c b/src/eval.c index 39c328ea1fa..a4449b18f9b 100644 --- a/src/eval.c +++ b/src/eval.c @@ -559,6 +559,10 @@ usage: (function ARG) */) { /* Handle the special (:documentation
) to build the docstring dynamically. */ Lisp_Object docstring = eval_sub (Fcar (XCDR (tmp))); + if (SYMBOLP (docstring) && !NILP (docstring)) + /* Hack for OClosures: Allow the docstring to be a symbol + * (the OClosure's type). */ + docstring = Fsymbol_name (docstring); CHECK_STRING (docstring); cdr = Fcons (XCAR (cdr), Fcons (docstring, XCDR (XCDR (cdr)))); } diff --git a/test/lisp/emacs-lisp/oclosure-tests.el b/test/lisp/emacs-lisp/oclosure-tests.el new file mode 100644 index 00000000000..e7e76fa4bda --- /dev/null +++ b/test/lisp/emacs-lisp/oclosure-tests.el @@ -0,0 +1,113 @@ +;;; oclosure-tests.e; --- Tests for Open Closures -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2022 Free Software Foundation, Inc. + +;; 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 . + +;;; Code: + +(require 'ert) +(require 'oclosure) +(require 'cl-lib) + +(oclosure-define (oclosure-test + (:copier oclosure-test-copy) + (:copier oclosure-test-copy1 (fst))) + "Simple OClosure." + fst snd name) + +(ert-deftest oclosure-test () + (let* ((i 42) + (ocl1 (oclosure-lambda (oclosure-test (fst 1) (snd 2) (name "hi")) + () + (list fst snd i))) + (ocl2 (oclosure-lambda (oclosure-test (name (cl-incf i)) (fst (cl-incf i))) + () + (list fst snd 152 i)))) + (should (equal (list (oclosure-test--fst ocl1) + (oclosure-test--snd ocl1) + (oclosure-test--name ocl1)) + '(1 2 "hi"))) + (should (equal (list (oclosure-test--fst ocl2) + (oclosure-test--snd ocl2) + (oclosure-test--name ocl2)) + '(44 nil 43))) + (should (equal (funcall ocl1) '(1 2 44))) + (should (equal (funcall ocl2) '(44 nil 152 44))) + (should (equal (funcall (oclosure-test-copy ocl1 :fst 7)) '(7 2 44))) + (should (equal (funcall (oclosure-test-copy1 ocl1 9)) '(9 2 44))) + (should (cl-typep ocl1 'oclosure-test)) + (should (cl-typep ocl1 'oclosure)) + )) + +(ert-deftest oclosure-test-limits () + (should + (condition-case err + (let ((lexical-binding t) + (byte-compile-debug t)) + (byte-compile '(lambda () + (let ((inc-fst nil)) + (oclosure-lambda (oclosure-test (fst 'foo)) () + (setq inc-fst (lambda () (setq fst (1+ fst)))) + fst)))) + nil) + (error + (and (eq 'error (car err)) + (string-match "fst.*mutated" (cadr err)))))) + (should + (condition-case err + (progn (macroexpand-all '(oclosure-define oclosure--foo a a)) + nil) + (error + (and (eq 'error (car err)) + (string-match "Duplicate slot name: a$" (cadr err)))))) + (should + (condition-case err + (progn (macroexpand-all + '(oclosure-define (oclosure--foo (:parent oclosure-test)) fst)) + nil) + (error + (and (eq 'error (car err)) + (string-match "Duplicate slot name: fst$" (cadr err)))))) + (should + (condition-case err + (progn (macroexpand '(oclosure-lambda (oclosure-test (fst 1) (fst 2)) + () fst)) + nil) + (error + (and (eq 'error (car err)) + (string-match "Duplicate slot: fst$" (cadr err))))))) + +(oclosure-define (oclosure-test-mut + (:parent oclosure-test) + (:copier oclosure-test-mut-copy)) + "Simple OClosure with a mutable field." + (mut :mutable t)) + +(ert-deftest oclosure-test-mutate () + (let* ((f (oclosure-lambda (oclosure-test-mut (fst 0) (mut 3)) + (x) + (+ x fst mut))) + (f2 (oclosure-test-mut-copy f :fst 50))) + (should (equal (oclosure-test-mut--mut f) 3)) + (should (equal (funcall f 5) 8)) + (should (equal (funcall f2 5) 58)) + (cl-incf (oclosure-test-mut--mut f) 7) + (should (equal (oclosure-test-mut--mut f) 10)) + (should (equal (funcall f 5) 15)) + (should (equal (funcall f2 15) 68)))) + +;;; oclosure-tests.el ends here. -- cgit v1.2.3 From 55932a65ed719d4277e0e781ca5e323b189d7f63 Mon Sep 17 00:00:00 2001 From: Po Lu Date: Tue, 29 Mar 2022 13:58:40 +0800 Subject: Temporarily fix the oclosure bootstrap * lisp/emacs-lisp/oclosure.el (oclosure-define): Load oclosure from source if `oclosure--define' is not defined during byte compilation. --- lisp/emacs-lisp/oclosure.el | 2 ++ 1 file changed, 2 insertions(+) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index 3d17c6c668c..0c504e5d821 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -248,6 +248,8 @@ list of slot properties. The currently known properties are the following: ,(when options (macroexp-warn-and-return name (format "Ignored options: %S" options) nil)) + (eval-when-compile (unless (fboundp 'oclosure--define) + (load "oclosure.el"))) (eval-and-compile (oclosure--define ',name ,docstring ',parent-names ',slots ,@(when predicate `(:predicate ',predicate)))) -- cgit v1.2.3 From 2b5ea36ce9659ee16ebff36e2642927691c391ee Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 29 Mar 2022 03:23:38 -0400 Subject: * lisp/emacs-lisp/oclosure.el (oclosure--define): Autoload --- lisp/emacs-lisp/oclosure.el | 1 + 1 file changed, 1 insertion(+) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index 0c504e5d821..f5a21151f13 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -321,6 +321,7 @@ list of slot properties. The currently known properties are the following: ,@(oclosure--defstruct-make-copiers copiers slotdescs name)))) +;;;###autoload (defun oclosure--define (name docstring parent-names slots &rest props) (let* ((class (oclosure--build-class name docstring parent-names slots)) -- cgit v1.2.3 From b12ad270ebffb2b048f01d2992b472503b78dc33 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 30 Mar 2022 13:49:31 -0400 Subject: EIEIO tests: Fix failure when `eieio-core.el` is interpreted * lisp/emacs-lisp/eieio-core.el (eieio--validate-slot-value) (eieio--slot-name-index): Use the `cl--class` accessor functions. --- lisp/emacs-lisp/eieio-core.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 19aa20fa086..ed1a28a24fb 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -704,7 +704,7 @@ an error." nil ;; Trim off object IDX junk added in for the object index. (setq slot-idx (- slot-idx (eval-when-compile eieio--object-num-slots))) - (let* ((sd (aref (eieio--class-slots class) + (let* ((sd (aref (cl--class-slots class) slot-idx)) (st (cl--slot-descriptor-type sd))) (cond @@ -712,7 +712,7 @@ an error." (signal 'invalid-slot-type (list (eieio--class-name class) slot st value))) ((alist-get :read-only (cl--slot-descriptor-props sd)) - (signal 'eieio-read-only (list (eieio--class-name class) slot))))))) + (signal 'eieio-read-only (list (cl--class-name class) slot))))))) (defun eieio--validate-class-slot-value (class slot-idx value slot) "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. @@ -896,7 +896,7 @@ The slot is a symbol which is installed in CLASS by the `defclass' call. If SLOT is the value created with :initarg instead, reverse-lookup that name, and recurse with the associated slot value." ;; Removed checks to outside this call - (let* ((fsi (gethash slot (eieio--class-index-table class)))) + (let* ((fsi (gethash slot (cl--class-index-table class)))) (if (integerp fsi) fsi (let ((fn (eieio--initarg-to-attribute class slot))) -- cgit v1.2.3 From 6f973faa912a5ac1ba643c6f5deb0c02baa0ba6d Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 30 Mar 2022 13:54:56 -0400 Subject: cl-generic: Use OClosures for `cl--generic-isnot-nnm-p` Rewrite the handling of `cl-no-next-method` to get rid of the hideous hack used in `cl--generic-isnot-nnm-p` and also to try and move some of the cost to the construction of the effective method rather than its invocation. This speeds up method calls measurably when there's a `cl-call-next-method` in the body. * lisp/loadup.el ("emacs-lisp/oclosure"): Load. * lisp/emacs-lisp/oclosure.el (oclosure-define): Remove workaround now that we're preloaded. * lisp/emacs-lisp/cl-generic.el (cl--generic-method): Rename `uses-cnm` to `call-con` to reflect it's not a boolean any more. (cl-defmethod): Adjust to the new name and new values. (cl-generic-define-method): Adjust to the new name. (cl--generic-lambda): Use the new `curried` calling convention. (cl--generic-no-next-method-function): Delete function. (cl--generic-nnm): New type. (cl-generic-call-method): Rewrite to support the various calling conventions. (cl--generic-nnm-sample, cl--generic-cnm-sample): Delete consts. (cl--generic-isnot-nnm-p): Rewrite using `oclosure-type`. (cl--generic-method-info): Add support for new calling convention. --- lisp/emacs-lisp/cl-generic.el | 162 ++++++++++++++++++++++++------------------ lisp/emacs-lisp/oclosure.el | 2 - lisp/loadup.el | 1 + 3 files changed, 95 insertions(+), 70 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 295512d51ef..279f73f36a2 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -144,13 +144,20 @@ SPECIALIZERS-FUNCTION takes as first argument a tag value TAG (cl-defstruct (cl--generic-method (:constructor nil) (:constructor cl--generic-make-method - (specializers qualifiers uses-cnm function)) + (specializers qualifiers call-con function)) (:predicate nil)) (specializers nil :read-only t :type list) (qualifiers nil :read-only t :type (list-of atom)) - ;; USES-CNM is a boolean indicating if FUNCTION expects an extra argument - ;; holding the next-method. - (uses-cnm nil :read-only t :type boolean) + ;; CALL-CON indicates the calling convention expected by FUNCTION: + ;; - nil: FUNCTION is just a normal function with no extra arguments for + ;; `call-next-method' or `next-method-p' (which it hence can't use). + ;; - `curried': FUNCTION is a curried function that first takes the + ;; "next combined method" and return the resulting combined method. + ;; It can distinguish `next-method-p' by checking if that next method + ;; is `cl--generic-isnot-nnm-p'. + ;; - t: FUNCTION takes the `call-next-method' function as its first (extra) + ;; argument. + (call-con nil :read-only t :type symbol) (function nil :read-only t :type function)) (cl-defstruct (cl--generic @@ -400,6 +407,8 @@ the specializer used will be the one returned by BODY." (pcase (macroexpand fun macroenv) (`#'(lambda ,args . ,body) (let* ((parsed-body (macroexp-parse-body body)) + (nm (make-symbol "cl--nm")) + (arglist (make-symbol "cl--args")) (cnm (make-symbol "cl--cnm")) (nmp (make-symbol "cl--nmp")) (nbody (macroexpand-all @@ -412,15 +421,49 @@ the specializer used will be the one returned by BODY." ;; is used. ;; FIXME: Also, optimize the case where call-next-method is ;; only called with explicit arguments. - (uses-cnm (macroexp--fgrep `((,cnm) (,nmp)) nbody))) - (cons (not (not uses-cnm)) - `#'(lambda (,@(if uses-cnm (list cnm)) ,@args) - ,@(car parsed-body) - ,(if (not (assq nmp uses-cnm)) - nbody - `(let ((,nmp (lambda () - (cl--generic-isnot-nnm-p ,cnm)))) - ,nbody)))))) + (uses-cnm (macroexp--fgrep `((,cnm) (,nmp)) nbody)) + (λ-lift (mapcar #'car uses-cnm))) + (if (not uses-cnm) + (cons nil + `#'(lambda (,@args) + ,@(car parsed-body) + ,nbody)) + (cons 'curried + `#'(lambda (,nm) ;Called when constructing the effective method. + (let ((,nmp (if (cl--generic-isnot-nnm-p ,nm) + #'always #'ignore))) + ;; This `(λ (&rest x) .. (apply (λ (args) ..) x))' + ;; dance is needed because we need to get the original + ;; args as a list when `cl-call-next-method' is + ;; called with no arguments. It's important to + ;; capture it as a list since it needs to distinguish + ;; the nil case from the absent case in optional + ;; arguments and it needs to properly remember the + ;; original value if `nbody' mutates some of its + ;; formal args. + ;; FIXME: This `(λ (&rest ,arglist)' could be skipped + ;; when we know `cnm' is always called with args, and + ;; it could be implemented more efficiently if `cnm' + ;; is always called directly and there are no + ;; `&optional' args. + (lambda (&rest ,arglist) + ,@(let* ((prebody (car parsed-body)) + (ds (if (stringp (car prebody)) + prebody + (setq prebody (cons nil prebody)))) + (usage (help-split-fundoc (car ds) nil))) + (unless usage + (setcar ds (help-add-fundoc-usage (car ds) + args))) + prebody) + (let ((,cnm (lambda (&rest args) + (apply ,nm (or args ,arglist))))) + ;; This `apply+lambda' basically parses + ;; `arglist' according to `args'. + ;; A destructuring-bind would do the trick + ;; as well when/if it's more efficient. + (apply (lambda (,@λ-lift ,@args) ,nbody) + ,@λ-lift ,arglist))))))))) (f (error "Unexpected macroexpansion result: %S" f)))))) (put 'cl-defmethod 'function-documentation @@ -518,11 +561,9 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (require 'gv) (declare-function gv-setter "gv" (name)) (setq name (gv-setter (cadr name)))) - (pcase-let* ((`(,uses-cnm . ,fun) (cl--generic-lambda args body))) + (pcase-let* ((`(,call-con . ,fun) (cl--generic-lambda args body))) `(progn ,(and (get name 'byte-obsolete-info) - (or (not (fboundp 'byte-compile-warning-enabled-p)) - (byte-compile-warning-enabled-p 'obsolete name)) (let* ((obsolete (get name 'byte-obsolete-info))) (macroexp-warn-and-return (macroexp--obsolete-warning name obsolete "generic function") @@ -534,7 +575,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined ;; The ",'" is a no-op that pacifies check-declare. (,'declare-function ,name "") (cl-generic-define-method ',name ',(nreverse qualifiers) ',args - ,uses-cnm ,fun))))) + ',call-con ,fun))))) (defun cl--generic-member-method (specializers qualifiers methods) (while @@ -552,7 +593,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined `(,name ,qualifiers . ,specializers)) ;;;###autoload -(defun cl-generic-define-method (name qualifiers args uses-cnm function) +(defun cl-generic-define-method (name qualifiers args call-con function) (pcase-let* ((generic (cl-generic-ensure-function name)) (`(,spec-args . ,_) (cl--generic-split-args args)) @@ -561,7 +602,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined spec-arg (cdr spec-arg))) spec-args)) (method (cl--generic-make-method - specializers qualifiers uses-cnm function)) + specializers qualifiers call-con function)) (mt (cl--generic-method-table generic)) (me (cl--generic-member-method specializers qualifiers mt)) (dispatches (cl--generic-dispatches generic)) @@ -738,29 +779,38 @@ for all those different tags in the method-cache.") (list (cl--generic-name generic))) f)))) -(defun cl--generic-no-next-method-function (generic method) - (lambda (&rest args) - (apply #'cl-no-next-method generic method args))) +(oclosure-define (cl--generic-nnm) + "Special type for `call-next-method's that just call `no-next-method'.") (defun cl-generic-call-method (generic method &optional fun) "Return a function that calls METHOD. FUN is the function that should be called when METHOD calls `call-next-method'." - (if (not (cl--generic-method-uses-cnm method)) - (cl--generic-method-function method) - (let ((met-fun (cl--generic-method-function method)) - (next (or fun (cl--generic-no-next-method-function - generic method)))) - (lambda (&rest args) - (apply met-fun - ;; FIXME: This sucks: passing just `next' would - ;; be a lot more efficient than the lambda+apply - ;; quasi-η, but we need this to implement the - ;; "if call-next-method is called with no - ;; arguments, then use the previous arguments". - (lambda (&rest cnm-args) - (apply next (or cnm-args args))) - args))))) + (let ((met-fun (cl--generic-method-function method))) + (pcase (cl--generic-method-call-con method) + ('nil met-fun) + ('curried + (funcall met-fun (or fun + (oclosure-lambda (cl--generic-nnm) (&rest args) + (apply #'cl-no-next-method generic method + args))))) + ;; FIXME: backward compatibility with old convention for `.elc' files + ;; compiled before the `curried' convention. + (_ + (lambda (&rest args) + (apply met-fun + (if fun + ;; FIXME: This sucks: passing just `next' would + ;; be a lot more efficient than the lambda+apply + ;; quasi-η, but we need this to implement the + ;; "if call-next-method is called with no + ;; arguments, then use the previous arguments". + (lambda (&rest cnm-args) + (apply fun (or cnm-args args))) + (oclosure-lambda (cl--generic-nnm) (&rest cnm-args) + (apply #'cl-no-next-method generic method + (or cnm-args args)))) + args)))))) ;; Standard CLOS name. (defalias 'cl-method-qualifiers #'cl--generic-method-qualifiers) @@ -926,36 +976,9 @@ those methods.") "Standard support for :after, :before, :around, and `:extra NAME' qualifiers." (cl--generic-standard-method-combination generic methods)) -(defconst cl--generic-nnm-sample (cl--generic-no-next-method-function t t)) -(defconst cl--generic-cnm-sample - (funcall (cl--generic-build-combined-method - nil (list (cl--generic-make-method () () t #'identity))))) - (defun cl--generic-isnot-nnm-p (cnm) "Return non-nil if CNM is the function that calls `cl-no-next-method'." - ;; ¡Big Gross Ugly Hack! - ;; `next-method-p' just sucks, we should let it die. But EIEIO did support - ;; it, and some packages use it, so we need to support it. - (catch 'found - (cl-assert (function-equal cnm cl--generic-cnm-sample)) - (if (byte-code-function-p cnm) - (let ((cnm-constants (aref cnm 2)) - (sample-constants (aref cl--generic-cnm-sample 2))) - (dotimes (i (length sample-constants)) - (when (function-equal (aref sample-constants i) - cl--generic-nnm-sample) - (throw 'found - (not (function-equal (aref cnm-constants i) - cl--generic-nnm-sample)))))) - (cl-assert (eq 'closure (car-safe cl--generic-cnm-sample))) - (let ((cnm-env (cadr cnm))) - (dolist (vb (cadr cl--generic-cnm-sample)) - (when (function-equal (cdr vb) cl--generic-nnm-sample) - (throw 'found - (not (function-equal (cdar cnm-env) - cl--generic-nnm-sample)))) - (setq cnm-env (cdr cnm-env))))) - (error "Haven't found no-next-method-sample in cnm-sample"))) + (not (eq (oclosure-type cnm) 'cl--generic-nnm))) ;;; Define some pre-defined generic functions, used internally. @@ -1031,9 +1054,12 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (defun cl--generic-method-info (method) (let* ((specializers (cl--generic-method-specializers method)) (qualifiers (cl--generic-method-qualifiers method)) - (uses-cnm (cl--generic-method-uses-cnm method)) + (call-con (cl--generic-method-call-con method)) (function (cl--generic-method-function method)) - (args (help-function-arglist function 'names)) + (args (help-function-arglist (if (not (eq call-con 'curried)) + function + (funcall function #'ignore)) + 'names)) (docstring (documentation function)) (qual-string (if (null qualifiers) "" @@ -1044,7 +1070,7 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (let ((split (help-split-fundoc docstring nil))) (if split (cdr split) docstring)))) (combined-args ())) - (if uses-cnm (setq args (cdr args))) + (if (eq t call-con) (setq args (cdr args))) (dolist (specializer specializers) (let ((arg (if (eq '&rest (car args)) (intern (format "arg%d" (length combined-args))) diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index f5a21151f13..db108bd7bee 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -248,8 +248,6 @@ list of slot properties. The currently known properties are the following: ,(when options (macroexp-warn-and-return name (format "Ignored options: %S" options) nil)) - (eval-when-compile (unless (fboundp 'oclosure--define) - (load "oclosure.el"))) (eval-and-compile (oclosure--define ',name ,docstring ',parent-names ',slots ,@(when predicate `(:predicate ',predicate)))) diff --git a/lisp/loadup.el b/lisp/loadup.el index faeb9188e49..6ca699f9016 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -197,6 +197,7 @@ (load "button") ;After loaddefs, because of define-minor-mode! (load "emacs-lisp/cl-preloaded") +(load "emacs-lisp/oclosure") ;Used by cl-generic (load "obarray") ;abbrev.el is implemented in terms of obarrays. (load "abbrev") ;lisp-mode.el and simple.el use define-abbrev-table. -- cgit v1.2.3 From af0ea35ea00725d2700a5215b56b725dc0d88d0d Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 31 Mar 2022 13:36:40 +0200 Subject: Tweak how functions are formatted in Implementation in *Help* * lisp/emacs-lisp/cl-generic.el (cl--generic-describe): Include the function name in the implementations (bug#54628). This clarifies what we're talking about here, and avoids getting (function ...) translated into #'... --- lisp/emacs-lisp/cl-generic.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 279f73f36a2..5cbdb9523ac 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -1098,7 +1098,7 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (dolist (method (cl--generic-method-table generic)) (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))) + (insert (format "%s%S" (nth 0 info) (cons function (nth 1 info)))) (let* ((met-name (cl--generic-load-hist-format function (cl--generic-method-qualifiers method) -- cgit v1.2.3 From ff067408e460c02e69c5b7fd06a03c9b12a5744b Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 1 Apr 2022 08:54:55 -0400 Subject: OClosure: Add support for defmethod dispatch * lisp/emacs-lisp/oclosure.el (oclosure--class): Add slot `allparents`. (oclosure--class-make): Add corresponding arg `allparents`. (oclosure, oclosure--build-class): Pass the new arg to the constructor. (oclosure--define): Make the predicate function understand subtyping. * lisp/emacs-lisp/cl-preloaded.el (cl--class-allparents): Move from `cl-generic.el`. * lisp/emacs-lisp/cl-generic.el (cl--generic-class-parents): Move to `cl-preloaded.el` and rename to `cl--class-allparents`. Adjust all callers. (cl--generic-oclosure-tag, cl-generic--oclosure-specializers): New functions. (cl-generic-generalizers) : New generalizer. * test/lisp/emacs-lisp/oclosure-tests.el (oclosure-test-gen): New generic function. (oclosure-test): Add test for dispatch on oclosure types. --- lisp/emacs-lisp/cl-generic.el | 51 +++++++++++++++++++++++++--------- lisp/emacs-lisp/cl-preloaded.el | 11 ++++++++ lisp/emacs-lisp/oclosure.el | 16 +++++++---- test/lisp/emacs-lisp/oclosure-tests.el | 13 +++++++++ 4 files changed, 73 insertions(+), 18 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 5cbdb9523ac..32a5fe5e54b 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -1126,7 +1126,7 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (let ((sclass (cl--find-class specializer)) (tclass (cl--find-class type))) (when (and sclass tclass) - (member specializer (cl--generic-class-parents tclass)))))) + (member specializer (cl--class-allparents tclass)))))) (setq applies t))) applies)) @@ -1255,22 +1255,11 @@ These match if the argument is `eql' to VAL." ;; Use exactly the same code as for `typeof'. `(if ,name (type-of ,name) 'null)) -(defun cl--generic-class-parents (class) - (let ((parents ()) - (classes (list class))) - ;; BFS precedence. FIXME: Use a topological sort. - (while (let ((class (pop classes))) - (cl-pushnew (cl--class-name class) parents) - (setq classes - (append classes - (cl--class-parents class))))) - (nreverse parents))) - (defun cl--generic-struct-specializers (tag &rest _) (and (symbolp tag) (let ((class (get tag 'cl--class))) (when (cl-typep class 'cl-structure-class) - (cl--generic-class-parents class))))) + (cl--class-allparents class))))) (cl-generic-define-generalizer cl--generic-struct-generalizer 50 #'cl--generic-struct-tag @@ -1353,6 +1342,42 @@ Used internally for the (major-mode MODE) context specializers." (progn (cl-assert (null modes)) mode) `(derived-mode ,mode . ,modes)))) +;;; Dispatch on OClosure type + +;; It would make sense to put this into `oclosure.el' except that when +;; `oclosure.el' is loaded `cl-defmethod' is not available yet. + +(defun cl--generic-oclosure-tag (name &rest _) + `(oclosure-type ,name)) + +(defun cl-generic--oclosure-specializers (tag &rest _) + (and (symbolp tag) + (let ((class (cl--find-class tag))) + (when (cl-typep class 'oclosure--class) + (oclosure--class-allparents class))))) + +(cl-generic-define-generalizer cl-generic--oclosure-generalizer + ;; Give slightly higher priority than the struct specializer, so that + ;; for a generic function with methods dispatching structs and on OClosures, + ;; we first try `oclosure-type' before `type-of' since `type-of' will return + ;; non-nil for an OClosure as well. + 51 #'cl--generic-oclosure-tag + #'cl-generic--oclosure-specializers) + +(cl-defmethod cl-generic-generalizers :extra "oclosure-struct" (type) + "Support for dispatch on types defined by `oclosure-define'." + (or + (when (symbolp type) + ;; Use the "cl--struct-class*" (inlinable) functions/macros rather than + ;; the "cl-struct-*" variants which aren't inlined, so that dispatch can + ;; take place without requiring cl-lib. + (let ((class (cl--find-class type))) + (and (cl-typep class 'oclosure--class) + (list cl-generic--oclosure-generalizer)))) + (cl-call-next-method))) + +(cl--generic-prefill-dispatchers 0 oclosure) + ;;; Support for unloading. (cl-defmethod loadhist-unload-element ((x (head cl-defmethod))) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 6aa45526d84..93713f506d2 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -305,6 +305,17 @@ supertypes from the most specific to least specific.") (cl-assert (cl--class-p (cl--find-class 'cl-structure-class))) (cl-assert (cl--class-p (cl--find-class 'cl-structure-object))) +(defun cl--class-allparents (class) + (let ((parents ()) + (classes (list class))) + ;; BFS precedence. FIXME: Use a topological sort. + (while (let ((class (pop classes))) + (cl-pushnew (cl--class-name class) parents) + (setq classes + (append classes + (cl--class-parents class))))) + (nreverse parents))) + ;; Make sure functions defined with cl-defsubst can be inlined even in ;; packages which do not require CL. We don't put an autoload cookie ;; directly on that function, since those cookies only go to cl-loaddefs. diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index db108bd7bee..c37a5352a3a 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -131,16 +131,17 @@ (cl-defstruct (oclosure--class (:constructor nil) (:constructor oclosure--class-make - ( name docstring slots parents + ( name docstring slots parents allparents &aux (index-table (oclosure--index-table slots)))) (:include cl--class) (:copier nil)) - "Metaclass for OClosure classes.") + "Metaclass for OClosure classes." + (allparents nil :read-only t :type (list-of symbol))) (setf (cl--find-class 'oclosure) (oclosure--class-make 'oclosure "The root parent of all OClosure classes" - nil nil)) + nil nil '(oclosure))) (defun oclosure--p (oclosure) (not (not (oclosure-type oclosure)))) @@ -283,7 +284,9 @@ list of slot properties. The currently known properties are the following: (oclosure--class-make name docstring slotdescs (if (cdr parent-names) (oclosure--class-parents parent-class) - (list parent-class))))) + (list parent-class)) + (cons name (oclosure--class-allparents + parent-class))))) (defmacro oclosure--define-functions (name copiers) (let* ((class (cl--find-class name)) @@ -324,7 +327,10 @@ list of slot properties. The currently known properties are the following: &rest props) (let* ((class (oclosure--build-class name docstring parent-names slots)) (pred (lambda (oclosure) - (eq name (oclosure-type oclosure)))) + (let ((type (oclosure-type oclosure))) + (when type + (memq name (oclosure--class-allparents + (cl--find-class type))))))) (predname (or (plist-get props :predicate) (intern (format "%s--internal-p" name))))) (setf (cl--find-class name) class) diff --git a/test/lisp/emacs-lisp/oclosure-tests.el b/test/lisp/emacs-lisp/oclosure-tests.el index e7e76fa4bda..c72a9dbd7ad 100644 --- a/test/lisp/emacs-lisp/oclosure-tests.el +++ b/test/lisp/emacs-lisp/oclosure-tests.el @@ -29,6 +29,16 @@ "Simple OClosure." fst snd name) +(cl-defmethod oclosure-test-gen ((_x compiled-function)) "#") + +(cl-defmethod oclosure-test-gen ((_x cons)) "#") + +(cl-defmethod oclosure-test-gen ((_x oclosure)) + (format "#" (cl-call-next-method))) + +(cl-defmethod oclosure-test-gen ((_x oclosure-test)) + (format "#" (cl-call-next-method))) + (ert-deftest oclosure-test () (let* ((i 42) (ocl1 (oclosure-lambda (oclosure-test (fst 1) (snd 2) (name "hi")) @@ -51,6 +61,9 @@ (should (equal (funcall (oclosure-test-copy1 ocl1 9)) '(9 2 44))) (should (cl-typep ocl1 'oclosure-test)) (should (cl-typep ocl1 'oclosure)) + (should (member (oclosure-test-gen ocl1) + '("#>>" + "#>>"))) )) (ert-deftest oclosure-test-limits () -- cgit v1.2.3 From 6cb688684065ca74b14263fcc22036cededa2bbe Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 1 Apr 2022 10:02:32 -0400 Subject: cl-generic: Rework obsolescence checks for defmethod * lisp/emacs-lisp/cl-generic.el (cl-defgeneric): Silence obsolescence warnings in the included methods. (cl-defmethod): Reuse standard obsolescence checks. * lisp/emacs-lisp/seq.el (seq-contains): Remove redundant `with-suppressed-warnings`. --- lisp/emacs-lisp/cl-generic.el | 18 ++++++++---------- lisp/emacs-lisp/seq.el | 15 +++++++-------- 2 files changed, 15 insertions(+), 18 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 32a5fe5e54b..1e820adaff6 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -308,8 +308,10 @@ DEFAULT-BODY, if present, is used as the body of a default method. `(help-add-fundoc-usage ,doc ',args) (help-add-fundoc-usage doc args))) :autoload-end - ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method)) - (nreverse methods))) + ,(when methods + `(with-suppressed-warnings ((obsolete ,name)) + ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method)) + (nreverse methods))))) ,@(mapcar (lambda (declaration) (let ((f (cdr (assq (car declaration) defun-declarations-alist)))) @@ -552,8 +554,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined cl--generic-edebug-make-name nil] lambda-doc ; documentation string def-body))) ; part to be debugged - (let ((qualifiers nil) - (orig-name name)) + (let ((qualifiers nil)) (while (cl-generic--method-qualifier-p args) (push args qualifiers) (setq args (pop body))) @@ -563,18 +564,15 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (setq name (gv-setter (cadr name)))) (pcase-let* ((`(,call-con . ,fun) (cl--generic-lambda args body))) `(progn - ,(and (get name 'byte-obsolete-info) - (let* ((obsolete (get name 'byte-obsolete-info))) - (macroexp-warn-and-return - (macroexp--obsolete-warning name obsolete "generic function") - nil (list 'obsolete name) nil orig-name))) ;; You could argue that `defmethod' modifies rather than defines the ;; 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'. ;; The ",'" is a no-op that pacifies check-declare. (,'declare-function ,name "") - (cl-generic-define-method ',name ',(nreverse qualifiers) ',args + ;; We use #' to quote `name' so as to trigger an + ;; obsolescence warning when applicable. + (cl-generic-define-method #',name ',(nreverse qualifiers) ',args ',call-con ,fun))))) (defun cl--generic-member-method (specializers qualifiers methods) diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 1bcb844d8e9..133d3c9e118 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -403,15 +403,14 @@ found or not." (setq count (+ 1 count)))) count)) -(with-suppressed-warnings ((obsolete seq-contains)) - (cl-defgeneric seq-contains (sequence elt &optional testfn) - "Return the first element in SEQUENCE that is equal to ELT. +(cl-defgeneric seq-contains (sequence elt &optional testfn) + "Return the first element in SEQUENCE that is equal to ELT. Equality is defined by TESTFN if non-nil or by `equal' if nil." - (declare (obsolete seq-contains-p "27.1")) - (seq-some (lambda (e) - (when (funcall (or testfn #'equal) elt e) - e)) - sequence))) + (declare (obsolete seq-contains-p "27.1")) + (seq-some (lambda (e) + (when (funcall (or testfn #'equal) elt e) + e)) + sequence)) (cl-defgeneric seq-contains-p (sequence elt &optional testfn) "Return non-nil if SEQUENCE contains an element equal to ELT. -- cgit v1.2.3 From 338f5667f46282f9b40c25bbf9704566069ec950 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 2 Apr 2022 15:19:05 +0200 Subject: Further tweaks to cl--generic-describe * lisp/emacs-lisp/cl-generic.el (cl--generic-describe): Further tweak the look of the implementation output. --- lisp/emacs-lisp/cl-generic.el | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 1e820adaff6..2ca84b019fc 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -1096,7 +1096,13 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (dolist (method (cl--generic-method-table generic)) (let* ((info (cl--generic-method-info method))) ;; FIXME: Add hyperlinks for the types as well. - (insert (format "%s%S" (nth 0 info) (cons function (nth 1 info)))) + (if (length> (nth 0 info) 0) + (insert (format "%s%S" (nth 0 info) + (let ((print-quoted nil)) + (nth 1 info)))) + ;; Make the non-":extra" bits look more like `C-h f' + ;; output. + (insert (format "%S" (cons function (nth 1 info))))) (let* ((met-name (cl--generic-load-hist-format function (cl--generic-method-qualifiers method) -- cgit v1.2.3 From ec464789dfc5179c72e6929ea99a72f508c562b6 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 2 Apr 2022 15:55:29 +0200 Subject: Put the define-minor-mode boilerplate at the end of the doc strings * lisp/emacs-lisp/easy-mmode.el (easy-mmode--mode-docstring): Put the boilerplate at the end of the doc string. --- lisp/emacs-lisp/easy-mmode.el | 66 +++++++++++++++++++++++++++---------------- 1 file changed, 42 insertions(+), 24 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 688c76e0c54..6827faab208 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -82,9 +82,7 @@ replacing its case-insensitive matches with the literal string in LIGHTER." (replace-regexp-in-string (regexp-quote lighter) lighter name t t)))) (defconst easy-mmode--arg-docstring - " - -This is a minor mode. If called interactively, toggle the `%s' + "This is a minor mode. If called interactively, toggle the `%s' mode. If the prefix argument is positive, enable the mode, and if it is zero or negative, disable the mode. @@ -100,27 +98,47 @@ it is disabled.") (defun easy-mmode--mode-docstring (doc mode-pretty-name keymap-sym getter) - (let ((doc (or doc (format "Toggle %s on or off. - -\\{%s}" mode-pretty-name keymap-sym)))) - (if (string-match-p "\\bARG\\b" doc) - doc - (let* ((fill-prefix nil) - (docs-fc (bound-and-true-p emacs-lisp-docstring-fill-column)) - (fill-column (if (integerp docs-fc) docs-fc 65)) - (argdoc (format easy-mmode--arg-docstring mode-pretty-name - ;; Avoid having quotes turn into pretty quotes. - (string-replace "'" "\\\\='" - (format "%S" getter)))) - (filled (if (fboundp 'fill-region) - (with-temp-buffer - (insert argdoc) - (fill-region (point-min) (point-max) 'left t) - (buffer-string)) - argdoc))) - (replace-regexp-in-string "\\(\n\n\\|\\'\\)\\(.\\|\n\\)*\\'" - (concat filled "\\1") - doc nil nil 1))))) + ;; If we have a doc string, and it's already complete (which we + ;; guess at with the simple heuristic below), then just return that + ;; as is. + (if (and doc (string-match-p "\\bARG\\b" doc)) + doc + ;; Compose a new doc string. + (with-temp-buffer + (let ((lines (if doc + (string-lines doc) + (list (format "Toggle %s on or off." mode-pretty-name))))) + ;; Insert the first line from the doc string. + (insert (pop lines)) + ;; Ensure that we have (only) one blank line after the first + ;; line. + (ensure-empty-lines) + (while (and lines + (string-empty-p (car lines))) + (pop lines)) + ;; Insert the doc string. + (dolist (line lines) + (insert line "\n")) + (ensure-empty-lines) + ;; Insert the boilerplate. + (let* ((fill-prefix nil) + (docs-fc (bound-and-true-p emacs-lisp-docstring-fill-column)) + (fill-column (if (integerp docs-fc) docs-fc 65)) + (argdoc (format easy-mmode--arg-docstring mode-pretty-name + ;; Avoid having quotes turn into pretty quotes. + (string-replace "'" "\\\\='" + (format "%S" getter))))) + (let ((start (point))) + (insert argdoc) + (when (fboundp 'fill-region) + (fill-region start (point) 'left t)))) + ;; Finally, insert the keymap. + (when (and (boundp keymap-sym) + (or (not doc) + (not (string-search "\\{" doc)))) + (ensure-empty-lines) + (insert (format "\\{%s}" keymap-sym))) + (buffer-string))))) ;;;###autoload (defalias 'easy-mmode-define-minor-mode #'define-minor-mode) -- cgit v1.2.3 From 781c43de3d017323b945088cdb39031d51a5e6ef Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 2 Apr 2022 16:53:24 +0200 Subject: Fix bootstrap errors after previous easy-mmode change * lisp/subr.el (ensure-empty-lines, string-lines): Moved from subr-x so that they can be used in early bootstrap files. * lisp/emacs-lisp/easy-mmode.el (easy-mmode--mode-docstring): Don't use string-empty-p because of bootstrap issues. --- lisp/emacs-lisp/easy-mmode.el | 2 +- lisp/emacs-lisp/subr-x.el | 32 -------------------------------- lisp/subr.el | 31 +++++++++++++++++++++++++++++++ 3 files changed, 32 insertions(+), 33 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 6827faab208..21a29a722c3 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -114,7 +114,7 @@ it is disabled.") ;; line. (ensure-empty-lines) (while (and lines - (string-empty-p (car lines))) + (equal (car lines) "")) (pop lines)) ;; Insert the doc string. (dolist (line lines) diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 7ad4e9ba2ab..abf85ab6c67 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -320,12 +320,6 @@ than this function." (end (substring string (- (length string) length))) (t (substring string 0 length))))) -;;;###autoload -(defun string-lines (string &optional omit-nulls) - "Split STRING into a list of lines. -If OMIT-NULLS, empty lines will be removed from the results." - (split-string string "\n" omit-nulls)) - (defun string-pad (string length &optional padding start) "Pad STRING to LENGTH using PADDING. If PADDING is nil, the space character is used. If not nil, it @@ -414,32 +408,6 @@ and return the value found in PLACE instead." ,(funcall setter val) ,val))))) -;;;###autoload -(defun ensure-empty-lines (&optional lines) - "Ensure that there are LINES number of empty lines before point. -If LINES is nil or omitted, ensure that there is a single empty -line before point. - -If called interactively, LINES is given by the prefix argument. - -If there are more than LINES empty lines before point, the number -of empty lines is reduced to LINES. - -If point is not at the beginning of a line, a newline character -is inserted before adjusting the number of empty lines." - (interactive "p") - (unless (bolp) - (insert "\n")) - (let ((lines (or lines 1)) - (start (save-excursion - (if (re-search-backward "[^\n]" nil t) - (+ (point) 2) - (point-min))))) - (cond - ((> (- (point) start) lines) - (delete-region (point) (- (point) (- (point) start lines)))) - ((< (- (point) start) lines) - (insert (make-string (- lines (- (point) start)) ?\n)))))) ;;;###autoload (defun string-pixel-width (string) diff --git a/lisp/subr.el b/lisp/subr.el index 603acffea7a..34f7bb6888a 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -6619,4 +6619,35 @@ OBJECT if it is readable." (forward-line 1) (point)))) +(defun ensure-empty-lines (&optional lines) + "Ensure that there are LINES number of empty lines before point. +If LINES is nil or omitted, ensure that there is a single empty +line before point. + +If called interactively, LINES is given by the prefix argument. + +If there are more than LINES empty lines before point, the number +of empty lines is reduced to LINES. + +If point is not at the beginning of a line, a newline character +is inserted before adjusting the number of empty lines." + (interactive "p") + (unless (bolp) + (insert "\n")) + (let ((lines (or lines 1)) + (start (save-excursion + (if (re-search-backward "[^\n]" nil t) + (+ (point) 2) + (point-min))))) + (cond + ((> (- (point) start) lines) + (delete-region (point) (- (point) (- (point) start lines)))) + ((< (- (point) start) lines) + (insert (make-string (- lines (- (point) start)) ?\n)))))) + +(defun string-lines (string &optional omit-nulls) + "Split STRING into a list of lines. +If OMIT-NULLS, empty lines will be removed from the results." + (split-string string "\n" omit-nulls)) + ;;; subr.el ends here -- cgit v1.2.3 From 5e429e21d9ae7e217c4c2b5b6d78f932c8f6ae39 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 3 Apr 2022 14:07:55 +0200 Subject: Have global minor modes say so in the doc string * lisp/emacs-lisp/easy-mmode.el (easy-mmode--arg-docstring): Allow saying whether it's a global minor mode or not. (easy-mmode--mode-docstring): Use it. (define-minor-mode): Pass in the data. --- lisp/emacs-lisp/easy-mmode.el | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 21a29a722c3..b2302624b1a 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -82,9 +82,9 @@ replacing its case-insensitive matches with the literal string in LIGHTER." (replace-regexp-in-string (regexp-quote lighter) lighter name t t)))) (defconst easy-mmode--arg-docstring - "This is a minor mode. If called interactively, toggle the `%s' -mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. + "This is a %sminor mode. If called interactively, toggle the +`%s' mode. If the prefix argument is positive, enable the mode, +and if it is zero or negative, disable the mode. If called from Lisp, toggle the mode if ARG is `toggle'. Enable the mode if ARG is nil, omitted, or is a positive number. @@ -97,7 +97,7 @@ The mode's hook is called both when the mode is enabled and when it is disabled.") (defun easy-mmode--mode-docstring (doc mode-pretty-name keymap-sym - getter) + getter global) ;; If we have a doc string, and it's already complete (which we ;; guess at with the simple heuristic below), then just return that ;; as is. @@ -124,10 +124,12 @@ it is disabled.") (let* ((fill-prefix nil) (docs-fc (bound-and-true-p emacs-lisp-docstring-fill-column)) (fill-column (if (integerp docs-fc) docs-fc 65)) - (argdoc (format easy-mmode--arg-docstring mode-pretty-name - ;; Avoid having quotes turn into pretty quotes. - (string-replace "'" "\\\\='" - (format "%S" getter))))) + (argdoc (format + easy-mmode--arg-docstring + (if global "global " "") + mode-pretty-name + ;; Avoid having quotes turn into pretty quotes. + (string-replace "'" "\\\\='" (format "%S" getter))))) (let ((start (point))) (insert argdoc) (when (fboundp 'fill-region) @@ -335,7 +337,7 @@ or call the function `%s'.")))) warnwrap `(defun ,modefun (&optional arg ,@extra-args) ,(easy-mmode--mode-docstring doc pretty-name keymap-sym - getter) + getter globalp) ,(when interactive ;; Use `toggle' rather than (if ,mode 0 1) so that using ;; repeat-command still does the toggling correctly. -- cgit v1.2.3 From 3c6524140b7a5e68875541781c3c48853e763dc3 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Sun, 3 Apr 2022 17:51:04 +0200 Subject: ; * lisp/emacs-lisp/cl-macs.el (cl-struct-slot-value): Fix typo. --- lisp/emacs-lisp/cl-macs.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 5d2a7c03ac4..da7157f4341 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3625,7 +3625,7 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc." (define-inline cl-struct-slot-value (struct-type slot-name inst) "Return the value of slot SLOT-NAME in INST of STRUCT-TYPE. -STRUCT and SLOT-NAME are symbols. INST is a structure instance." +STRUCT-TYPE and SLOT-NAME are symbols. INST is a structure instance." (declare (side-effect-free t)) (inline-letevals (struct-type slot-name inst) (inline-quote -- cgit v1.2.3 From f4833c88bbb3ca69f75e230a50bbd5edb4d5c00d Mon Sep 17 00:00:00 2001 From: Mattias Engdegård Date: Wed, 16 Mar 2022 16:24:24 +0100 Subject: Rewrite string-greaterp and string> using string-lessp Since string-lessp has its own byte-op, using it is much faster than calling string-greaterp even with the need to bind a temporary variable. * lisp/emacs-lisp/byte-opt.el (byte-optimize-string-greaterp): New. (string-greaterp, string>): Set byte-optimizer. --- lisp/emacs-lisp/byte-opt.el | 11 +++++++++++ 1 file changed, 11 insertions(+) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 0a79bf9b797..39bb6224595 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1049,6 +1049,14 @@ See Info node `(elisp) Integer Basics'." form ; No improvement. (cons 'concat (nreverse newargs))))) +(defun byte-optimize-string-greaterp (form) + ;; Rewrite in terms of `string-lessp' which has its own bytecode. + (pcase (cdr form) + (`(,a ,b) (let ((arg1 (make-symbol "arg1"))) + `(let ((,arg1 ,a)) + (string-lessp ,b ,arg1)))) + (_ form))) + (put 'identity 'byte-optimizer #'byte-optimize-identity) (put 'memq 'byte-optimizer #'byte-optimize-memq) (put 'memql 'byte-optimizer #'byte-optimize-member) @@ -1072,6 +1080,9 @@ See Info node `(elisp) Integer Basics'." (put 'string= 'byte-optimizer #'byte-optimize-binary-predicate) (put 'string-equal 'byte-optimizer #'byte-optimize-binary-predicate) +(put 'string-greaterp 'byte-optimizer #'byte-optimize-string-greaterp) +(put 'string> 'byte-optimizer #'byte-optimize-string-greaterp) + (put 'concat 'byte-optimizer #'byte-optimize-concat) ;; I'm not convinced that this is necessary. Doesn't the optimizer loop -- cgit v1.2.3 From 773d4104a592fda4366d8db27d0307ee23de8bfe Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Mon, 4 Apr 2022 12:48:47 +0200 Subject: Further fixes for cl--generic-describe and (function ...) * lisp/emacs-lisp/cl-generic.el (cl--generic-describe): Fix the #' problem for defmethods, too (bug#54628). --- lisp/emacs-lisp/cl-generic.el | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 2ca84b019fc..179310c145b 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -1096,13 +1096,12 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (dolist (method (cl--generic-method-table generic)) (let* ((info (cl--generic-method-info method))) ;; FIXME: Add hyperlinks for the types as well. - (if (length> (nth 0 info) 0) - (insert (format "%s%S" (nth 0 info) - (let ((print-quoted nil)) - (nth 1 info)))) - ;; Make the non-":extra" bits look more like `C-h f' - ;; output. - (insert (format "%S" (cons function (nth 1 info))))) + (let ((print-quoted nil)) + (if (length> (nth 0 info) 0) + (insert (format "%s%S" (nth 0 info) (nth 1 info))) + ;; Make the non-":extra" bits look more like `C-h f' + ;; output. + (insert (format "%S" (cons function (nth 1 info)))))) (let* ((met-name (cl--generic-load-hist-format function (cl--generic-method-qualifiers method) -- cgit v1.2.3 From 1f4f6b956bee611ffa406b3851e5264ee74e3bfb Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 4 Apr 2022 15:06:47 -0400 Subject: OClosure: add support for `slot-value` * lisp/emacs-lisp/oclosure.el (oclosure--slot-index) (oclosure--slot-value, oclosure--set-slot-value): New functions. * lisp/emacs-lisp/eieio-core.el (eieio-oset, eieio-oref): Consolidate the type test. Use `oclosure--(set-)slot-value`. (eieio--validate-slot-value, eieio--validate-class-slot-value): Don't presume `class` is an EIEIO class. (eieio--class): Fix bogus `:type` info. (eieio--object-class): Simplify. (eieio--known-slot-name-p): New function. (eieio-oref, eieio-oref-default, eieio-oset-default): Use it. * test/lisp/emacs-lisp/oclosure-tests.el: Require `eieio`. (oclosure-test): Make `name` field mutable. (oclosure-test-slot-value): New test. --- lisp/emacs-lisp/eieio-core.el | 104 ++++++++++++++++++--------------- lisp/emacs-lisp/oclosure.el | 20 +++++++ test/lisp/emacs-lisp/oclosure-tests.el | 19 +++++- 3 files changed, 95 insertions(+), 48 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index ed1a28a24fb..d687289b22f 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -92,7 +92,7 @@ Currently under control of this var: (:copier nil)) children initarg-tuples ;; initarg tuples list - (class-slots nil :type eieio--slot) + (class-slots nil :type (vector-of eieio--slot)) class-allocation-values ;; class allocated value vector default-object-cache ;; what a newly created object would look like. ; This will speed up instantiation time as @@ -130,10 +130,7 @@ Currently under control of this var: class)) (defsubst eieio--object-class (obj) - (let ((tag (eieio--object-class-tag obj))) - (if eieio-backward-compatibility - (eieio--class-object tag) - tag))) + (eieio--class-object (eieio--object-class-tag obj))) (defun class-p (x) "Return non-nil if X is a valid class vector. @@ -265,6 +262,10 @@ use '%s or turn off `eieio-backward-compatibility' instead" cname) (defvar eieio--known-slot-names nil) (defvar eieio--known-class-slot-names nil) +(defun eieio--known-slot-name-p (name) + (or (memq name eieio--known-slot-names) + (get name 'slot-name))) + (defun eieio-defclass-internal (cname superclasses slots options) "Define CNAME as a new subclass of SUPERCLASSES. SLOTS are the slots residing in that class definition, and OPTIONS @@ -704,13 +705,13 @@ an error." nil ;; Trim off object IDX junk added in for the object index. (setq slot-idx (- slot-idx (eval-when-compile eieio--object-num-slots))) - (let* ((sd (aref (cl--class-slots class) + (let* ((sd (aref (eieio--class-slots class) slot-idx)) (st (cl--slot-descriptor-type sd))) (cond ((not (eieio--perform-slot-validation st value)) (signal 'invalid-slot-type - (list (eieio--class-name class) slot st value))) + (list (cl--class-name class) slot st value))) ((alist-get :read-only (cl--slot-descriptor-props sd)) (signal 'eieio-read-only (list (cl--class-name class) slot))))))) @@ -725,7 +726,7 @@ an error." slot-idx)))) (if (not (eieio--perform-slot-validation st value)) (signal 'invalid-slot-type - (list (eieio--class-name class) slot st value)))))) + (list (cl--class-name class) slot st value)))))) (defun eieio-barf-if-slot-unbound (value instance slotname fn) "Throw a signal if VALUE is a representation of an UNBOUND slot. @@ -746,31 +747,35 @@ Argument FN is the function calling this verifier." (ignore obj) (pcase slot ((and (or `',name (and name (pred keywordp))) - (guard (not (memq name eieio--known-slot-names)))) + (guard (not (eieio--known-slot-name-p name)))) (macroexp-warn-and-return (format-message "Unknown slot `%S'" name) exp nil 'compile-only name)) (_ exp)))) + ;; FIXME: Make it a gv-expander such that the hash-table lookup is + ;; only performed once when used in `push' and friends? (gv-setter eieio-oset)) (cl-check-type slot symbol) - (cl-check-type obj (or eieio-object class cl-structure-object)) - (let* ((class (cond ((symbolp obj) - (error "eieio-oref called on a class: %s" obj) - (eieio--full-class-object obj)) - (t (eieio--object-class obj)))) - (c (eieio--slot-name-index class slot))) - (if (not c) - ;; It might be missing because it is a :class allocated slot. - ;; Let's check that info out. - (if (setq c (eieio--class-slot-name-index class slot)) - ;; Oref that slot. - (aref (eieio--class-class-allocation-values class) c) - ;; 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)) - (cl-check-type obj (or eieio-object cl-structure-object)) - (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) + (cond + ((cl-typep obj '(or eieio-object cl-structure-object)) + (let* ((class (eieio--object-class obj)) + (c (eieio--slot-name-index class slot))) + (if (not c) + ;; It might be missing because it is a :class allocated slot. + ;; Let's check that info out. + (if (setq c (eieio--class-slot-name-index class slot)) + ;; Oref that slot. + (aref (eieio--class-class-allocation-values class) c) + ;; 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)) + (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) + ((cl-typep obj 'oclosure) (oclosure--slot-value obj slot)) + (t + (signal 'wrong-type-argument + (list '(or eieio-object cl-structure-object oclosure) obj))))) + (defun eieio-oref-default (class slot) @@ -782,7 +787,7 @@ Fills in CLASS's SLOT with its default value." (ignore class) (pcase slot ((and (or `',name (and name (pred keywordp))) - (guard (not (memq name eieio--known-slot-names)))) + (guard (not (eieio--known-slot-name-p name)))) (macroexp-warn-and-return (format-message "Unknown slot `%S'" name) exp nil 'compile-only name)) @@ -817,24 +822,29 @@ Fills in CLASS's SLOT with its default value." (defun eieio-oset (obj slot value) "Do the work for the macro `oset'. Fills in OBJ's SLOT with VALUE." - (cl-check-type obj (or eieio-object cl-structure-object)) (cl-check-type slot symbol) - (let* ((class (eieio--object-class obj)) - (c (eieio--slot-name-index class slot))) - (if (not c) - ;; It might be missing because it is a :class allocated slot. - ;; Let's check that info out. - (if (setq c - (eieio--class-slot-name-index class slot)) - ;; Oset that slot. - (progn - (eieio--validate-class-slot-value class c value slot) - (aset (eieio--class-class-allocation-values class) - c value)) - ;; See oref for comment on `slot-missing' - (slot-missing obj slot 'oset value)) - (eieio--validate-slot-value class c value slot) - (aset obj c value)))) + (cond + ((cl-typep obj '(or eieio-object cl-structure-object)) + (let* ((class (eieio--object-class obj)) + (c (eieio--slot-name-index class slot))) + (if (not c) + ;; It might be missing because it is a :class allocated slot. + ;; Let's check that info out. + (if (setq c + (eieio--class-slot-name-index class slot)) + ;; Oset that slot. + (progn + (eieio--validate-class-slot-value class c value slot) + (aset (eieio--class-class-allocation-values class) + c value)) + ;; See oref for comment on `slot-missing' + (slot-missing obj slot 'oset value)) + (eieio--validate-slot-value class c value slot) + (aset obj c value)))) + ((cl-typep obj 'oclosure) (oclosure--set-slot-value obj slot value)) + (t + (signal 'wrong-type-argument + (list '(or eieio-object cl-structure-object oclosure) obj))))) (defun eieio-oset-default (class slot value) "Do the work for the macro `oset-default'. @@ -844,7 +854,7 @@ Fills in the default value in CLASS' in SLOT with VALUE." (ignore class value) (pcase slot ((and (or `',name (and name (pred keywordp))) - (guard (not (memq name eieio--known-slot-names)))) + (guard (not (eieio--known-slot-name-p name)))) (macroexp-warn-and-return (format-message "Unknown slot `%S'" name) exp nil 'compile-only name)) @@ -867,7 +877,7 @@ Fills in the default value in CLASS' in SLOT with VALUE." (eieio--validate-class-slot-value class c value slot) (aset (eieio--class-class-allocation-values class) c value)) - (signal 'invalid-slot-name (list (eieio--class-name class) slot))) + (signal 'invalid-slot-name (list (cl--class-name class) slot))) ;; `oset-default' on an instance-allocated slot is allowed by EIEIO but ;; not by CLOS and is mildly inconsistent with the :initform thingy, so ;; it'd be nice to get rid of it. diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index c37a5352a3a..3df64ad2806 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -511,6 +511,26 @@ This has 2 uses: "OClosure function to access a specific slot of an OClosure function." index) +(defun oclosure--slot-index (oclosure slotname) + (gethash slotname + (oclosure--class-index-table + (cl--find-class (oclosure-type oclosure))))) + +(defun oclosure--slot-value (oclosure slotname) + (let ((class (cl--find-class (oclosure-type oclosure))) + (index (oclosure--slot-index oclosure slotname))) + (oclosure--get oclosure index + (oclosure--slot-mutable-p + (nth index (oclosure--class-slots class)))))) + +(defun oclosure--set-slot-value (oclosure slotname value) + (let ((class (cl--find-class (oclosure-type oclosure))) + (index (oclosure--slot-index oclosure slotname))) + (unless (oclosure--slot-mutable-p + (nth index (oclosure--class-slots class))) + (signal 'setting-constant (list oclosure slotname))) + (oclosure--set value oclosure index))) + (defconst oclosure--mut-getter-prototype (oclosure-lambda (oclosure-accessor (type) (slot) (index)) (oclosure) (oclosure--get oclosure index t))) diff --git a/test/lisp/emacs-lisp/oclosure-tests.el b/test/lisp/emacs-lisp/oclosure-tests.el index c72a9dbd7ad..d3e2b3870a6 100644 --- a/test/lisp/emacs-lisp/oclosure-tests.el +++ b/test/lisp/emacs-lisp/oclosure-tests.el @@ -22,12 +22,13 @@ (require 'ert) (require 'oclosure) (require 'cl-lib) +(require 'eieio) (oclosure-define (oclosure-test (:copier oclosure-test-copy) (:copier oclosure-test-copy1 (fst))) "Simple OClosure." - fst snd name) + fst snd (name :mutable t)) (cl-defmethod oclosure-test-gen ((_x compiled-function)) "#") @@ -123,4 +124,20 @@ (should (equal (funcall f 5) 15)) (should (equal (funcall f2 15) 68)))) +(ert-deftest oclosure-test-slot-value () + (require 'eieio) + (let ((ocl (oclosure-lambda + (oclosure-test (fst 'fst1) (snd 'snd1) (name 'name1)) + (x) + (list name fst snd x)))) + (should (equal 'fst1 (slot-value ocl 'fst))) + (should (equal 'snd1 (slot-value ocl 'snd))) + (should (equal 'name1 (slot-value ocl 'name))) + (setf (slot-value ocl 'name) 'new-name) + (should (equal 'new-name (slot-value ocl 'name))) + (should (equal '(new-name fst1 snd1 arg) (funcall ocl 'arg))) + (should-error (setf (slot-value ocl 'fst) 'new-fst) :type 'setting-constant) + (should (equal 'fst1 (slot-value ocl 'fst))) + )) + ;;; oclosure-tests.el ends here. -- cgit v1.2.3 From 406da54bc63b1099b6e51b3d3e025712a16a1912 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 6 Apr 2022 13:47:46 +0200 Subject: Fix minor-mode doc string quoting * lisp/emacs-lisp/easy-mmode.el (easy-mmode--mode-docstring): Fix double quoting of things like (default-value 'electric-pair-mode) (bug#54746). --- lisp/emacs-lisp/easy-mmode.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index b2302624b1a..8a76eaf58cf 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -129,7 +129,7 @@ it is disabled.") (if global "global " "") mode-pretty-name ;; Avoid having quotes turn into pretty quotes. - (string-replace "'" "\\\\='" (format "%S" getter))))) + (string-replace "'" "\\='" (format "%S" getter))))) (let ((start (point))) (insert argdoc) (when (fboundp 'fill-region) -- cgit v1.2.3 From 4161a368499a3326d13113aa5c6ab332047df767 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 5 Jan 2022 14:28:08 -0500 Subject: cl-generic.el: Fix bug#46722 Fix longstanding bug due to unexpected interference via side-effect. * lisp/emacs-lisp/cl-generic.el (cl--generic-get-dispatcher): Copy the `dispatch` arg before storing it into the hash-table. Backport from `master` (cherrypick from commit 61f8f7f68f). --- lisp/emacs-lisp/cl-generic.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index a7e24236a32..add8e7fda0c 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -602,7 +602,9 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (defun cl--generic-get-dispatcher (dispatch) (cl--generic-with-memoization - (gethash dispatch cl--generic-dispatchers) + ;; We need `copy-sequence` here because this `dispatch' object might be + ;; modified by side-effect in `cl-generic-define-method' (bug#46722). + (gethash (copy-sequence dispatch) cl--generic-dispatchers) ;; (message "cl--generic-get-dispatcher (%S)" dispatch) (let* ((dispatch-arg (car dispatch)) (generalizers (cdr dispatch)) -- cgit v1.2.3 From 4c8e23d5d7fb662dc9eefba67b52ae5df0dffe62 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 7 Apr 2022 13:37:16 +0200 Subject: Clarify read-answer-short/use-short-answers action * lisp/emacs-lisp/map-ynp.el (read-answer-short): Clarify what this variable affects (bug#54754). * src/fns.c (Fyes_or_no_p): Mention `use-short-answers'. --- lisp/emacs-lisp/map-ynp.el | 10 ++++++++-- src/fns.c | 3 +++ 2 files changed, 11 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index b3e7fca4781..c47025f8846 100644 --- a/lisp/emacs-lisp/map-ynp.el +++ b/lisp/emacs-lisp/map-ynp.el @@ -278,11 +278,17 @@ Type \\`SPC' or \\`y' to %s the current %s; ;; For backward compatibility check if short y/n answers are preferred. (defcustom read-answer-short 'auto - "If non-nil, `read-answer' accepts single-character answers. + "If non-nil, the `read-answer' function accepts single-character answers. If t, accept short (single key-press) answers to the question. If nil, require long answers. If `auto', accept short answers if `use-short-answers' is non-nil, or the function cell of `yes-or-no-p' -is set to `y-or-n-p'." +is set to `y-or-n-p'. + +Note that this variable does not affect calls to the more +commonly-used `yes-or-no-p' function; it only affects calls to +the `read-answer' function. To control whether `yes-or-no-p' +requires a long or a short answer, see the `use-short-answers' +variable." :type '(choice (const :tag "Accept short answers" t) (const :tag "Require long answer" nil) (const :tag "Guess preference" auto)) diff --git a/src/fns.c b/src/fns.c index ee4e80b5069..4673fde28c7 100644 --- a/src/fns.c +++ b/src/fns.c @@ -2915,6 +2915,9 @@ it does up to one space will be removed. The user must confirm the answer with RET, and can edit it until it has been confirmed. +If the `use-short-answers' variable is non-nil, instead of asking for +\"yes\" or \"no\", this function will ask for \"y\" or \"n\". + If dialog boxes are supported, a dialog box will be used if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */) (Lisp_Object prompt) -- cgit v1.2.3 From 39e8fd357dd0a1f3776c05eee2cc5be451686712 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 7 Apr 2022 15:59:09 -0400 Subject: OClosure: New function `function-documentation` As mentioned in the original OClosure commit, OClosures (ab)use the bytecode's docstring slot to hold the OClosure's type. This currently prevents OClosures from having their own docstring. Introduce a new generic function `function-documentation` to fetch the docstring of a function, which can then be implemented in various different ways depending on the OClosure's type. * lisp/simple.el (function-documentation): New generic function. (bad-package-check): Strength-reduce `eval` to `symbol-value`. * src/doc.c (Fdocumentation): Use it. * lisp/emacs-lisp/oclosure.el (oclosure--accessor-docstring): New function. * test/lisp/emacs-lisp/oclosure-tests.el (oclosure-test): Add test for accessor's docstrings. --- doc/lispref/help.texi | 7 +++++ etc/NEWS | 6 ++++ lisp/emacs-lisp/oclosure.el | 6 ++++ lisp/simple.el | 34 ++++++++++++++++++++++- src/doc.c | 50 +--------------------------------- test/lisp/emacs-lisp/oclosure-tests.el | 1 + 6 files changed, 54 insertions(+), 50 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/help.texi b/doc/lispref/help.texi index 10a12940a15..d53bfad8e9e 100644 --- a/doc/lispref/help.texi +++ b/doc/lispref/help.texi @@ -158,6 +158,13 @@ the function definition has no documentation string. In that case, @code{documentation} returns @code{nil}. @end defun +@defun function-documentation function +Generic function used by @code{documentation} to extract the raw +docstring from a function object. You can specify how to get the +docstring of a specific function type by adding a corresponding method +to it. +@end defun + @defun face-documentation face This function returns the documentation string of @var{face} as a face. diff --git a/etc/NEWS b/etc/NEWS index 85ed817e05e..1043873f2d7 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1335,6 +1335,12 @@ This change is now applied in 'dired-insert-directory'. 'unify-8859-on-decoding-mode', 'unify-8859-on-encoding-mode', 'vc-arch-command'. ++++ +** New generic function 'function-doumentation'. +Can dynamically generate a raw docstring depending on the type of +a function. +Used mainly for docstrings of OClosures. + +++ ** Base64 encoding no longer tolerates latin-1 input. The functions 'base64-encode-string', 'base64url-encode-string', diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index 3df64ad2806..90811199f25 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -505,6 +505,12 @@ This has 2 uses: "OClosure function to access a specific slot of an object." type slot) +(defun oclosure--accessor-docstring (f) + ;; This would like to be a (cl-defmethod function-documentation ...) + ;; but for circularity reason the defmethod is in `simple.el'. + (format "Access slot \"%S\" of OBJ of type `%S'.\n\n(fn OBJ)" + (accessor--slot f) (accessor--type f))) + (oclosure-define (oclosure-accessor (:parent accessor) (:copier oclosure--accessor-copy (type slot index))) diff --git a/lisp/simple.el b/lisp/simple.el index ef520065011..80c27d6e0e5 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -2357,6 +2357,38 @@ maps." (with-suppressed-warnings ((interactive-only execute-extended-command)) (execute-extended-command prefixarg command-name typed))) +(cl-defgeneric function-documentation (function) + "Extract the raw docstring info from FUNCTION. +FUNCTION is expected to be a function value rather than, say, a mere symbol. +This is intended to be specialized via `cl-defmethod' but not called directly: +if you need a function's documentation use `documentation' which will call this +function as needed." + (let ((docstring-p (lambda (doc) + ;; A docstring can be either a string or a reference + ;; into either the `etc/DOC' or a `.elc' file. + (or (stringp doc) + (fixnump doc) (fixnump (cdr-safe doc)))))) + (pcase function + ((pred byte-code-function-p) + (when (> (length function) 4) + (let ((doc (aref function 4))) + (when (funcall docstring-p doc) doc)))) + ((or (pred stringp) (pred vectorp)) "Keyboard macro.") + (`(keymap . ,_) + "Prefix command (definition is a keymap associating keystrokes with commands).") + ((or `(lambda ,_args . ,body) `(closure ,_env ,_args . ,body) + `(autoload ,_file . ,body)) + (let ((doc (car body))) + (when (and (funcall docstring-p doc) + ;; Handle a doc reference--but these never come last + ;; in the function body, so reject them if they are last. + (or (cdr body) (eq 'autoload (car-safe function)))) + doc))) + (_ (signal 'invalid-function (list function)))))) + +(cl-defmethod function-documentation ((function accessor)) + (oclosure--accessor-docstring function)) ;; FIXME: η-reduce! + (defun command-execute (cmd &optional record-flag keys special) ;; BEWARE: Called directly from the C code. "Execute CMD as an editor command. @@ -10007,7 +10039,7 @@ warning using STRING as the message.") (and list (boundp symbol) (or (eq symbol t) - (and (stringp (setq symbol (eval symbol))) + (and (stringp (setq symbol (symbol-value symbol))) (string-match-p (nth 2 list) symbol))) (display-warning package (nth 3 list) :warning))) (error nil))) diff --git a/src/doc.c b/src/doc.c index e361a86c1a1..5326195c6a0 100644 --- a/src/doc.c +++ b/src/doc.c @@ -341,56 +341,8 @@ string is passed through `substitute-command-keys'. */) else if (MODULE_FUNCTIONP (fun)) doc = module_function_documentation (XMODULE_FUNCTION (fun)); #endif - else if (COMPILEDP (fun)) - { - if (PVSIZE (fun) <= COMPILED_DOC_STRING) - return Qnil; - else - { - Lisp_Object tem = AREF (fun, COMPILED_DOC_STRING); - if (STRINGP (tem)) - doc = tem; - else if (FIXNATP (tem) || CONSP (tem)) - doc = tem; - else - return Qnil; - } - } - else if (STRINGP (fun) || VECTORP (fun)) - { - return build_string ("Keyboard macro."); - } - else if (CONSP (fun)) - { - Lisp_Object funcar = XCAR (fun); - if (!SYMBOLP (funcar)) - xsignal1 (Qinvalid_function, fun); - else if (EQ (funcar, Qkeymap)) - return build_string ("Prefix command (definition is a keymap associating keystrokes with commands)."); - else if (EQ (funcar, Qlambda) - || (EQ (funcar, Qclosure) && (fun = XCDR (fun), 1)) - || EQ (funcar, Qautoload)) - { - Lisp_Object tem1 = Fcdr (Fcdr (fun)); - Lisp_Object tem = Fcar (tem1); - if (STRINGP (tem)) - doc = tem; - /* Handle a doc reference--but these never come last - in the function body, so reject them if they are last. */ - else if ((FIXNATP (tem) || (CONSP (tem) && FIXNUMP (XCDR (tem)))) - && !NILP (XCDR (tem1))) - doc = tem; - else - return Qnil; - } - else - goto oops; - } else - { - oops: - xsignal1 (Qinvalid_function, fun); - } + doc = call1 (intern ("function-documentation"), fun); /* If DOC is 0, it's typically because of a dumped file missing from the DOC file (bug in src/Makefile.in). */ diff --git a/test/lisp/emacs-lisp/oclosure-tests.el b/test/lisp/emacs-lisp/oclosure-tests.el index d3e2b3870a6..b6bdebc0a2b 100644 --- a/test/lisp/emacs-lisp/oclosure-tests.el +++ b/test/lisp/emacs-lisp/oclosure-tests.el @@ -65,6 +65,7 @@ (should (member (oclosure-test-gen ocl1) '("#>>" "#>>"))) + (should (stringp (documentation #'oclosure-test--fst))) )) (ert-deftest oclosure-test-limits () -- cgit v1.2.3 From e2f3b0f16eb34ac6f4941ddcf5b8ee24642656fc Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 8 Apr 2022 14:46:14 +0200 Subject: Improve package.el error messages on too-old Emacsen * lisp/emacs-lisp/package.el (package-compute-transaction): Give a better error message on too-old Emacs versions (bug#54747). --- lisp/emacs-lisp/package.el | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 6aa82e576d9..4f1ac5a5dac 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1854,8 +1854,12 @@ SEEN is used internally to detect infinite recursion." (error "Need package `%s-%s', but only %s is available" next-pkg (package-version-join next-version) found-something)) - (t (error "Package `%s-%s' is unavailable" - next-pkg (package-version-join next-version))))) + (t + (if (eq next-pkg 'emacs) + (error "This package requires Emacs version %s" + (package-version-join next-version)) + (error "Package `%s-%s' is unavailable" + next-pkg (package-version-join next-version)))))) (setq packages (package-compute-transaction (cons found packages) (package-desc-reqs found) -- cgit v1.2.3 From cca47ae555bfddf87b4871988555738c335f8457 Mon Sep 17 00:00:00 2001 From: Kaushal Modi Date: Sun, 10 Apr 2022 13:52:15 +0200 Subject: Update docstrings for shortdoc.el FUNC lisp form API * lisp/emacs-lisp/shortdoc.el (define-short-documentation-group): Updated docstrings. --- lisp/emacs-lisp/shortdoc.el | 70 +++++++++++++++++++++++++++++++++++---------- 1 file changed, 55 insertions(+), 15 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 658edd67527..ebf3c6b1fe9 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -47,30 +47,67 @@ "Add GROUP to the list of defined documentation groups. FUNCTIONS is a list of elements on the form: - (fun + (FUNC :no-manual BOOL :args ARGS - :eval EXAMPLE-FORM + :eval EVAL :no-eval EXAMPLE-FORM - :no-eval* EXAMPLE-FORM :no-value EXAMPLE-FORM + :no-eval* EXAMPLE-FORM :result RESULT-FORM - :result-string RESULT-FORM + :result-string RESULT-STRING :eg-result RESULT-FORM - :eg-result-string RESULT-FORM) + :eg-result-string RESULT-STRING) -BOOL should be non-nil if the function isn't documented in the +FUNC is the function being documented. + +NO-MANUAL should be non-nil if FUNC isn't documented in the manual. -ARGS is optional; the function's signature is displayed if ARGS -is not present. +ARGS is optional list of function FUNC's arguments. FUNC's +signature is displayed automatically if ARGS is not present. +Specifying ARGS might be useful where you don't want to document +some of the uncommon arguments a function might have. + +While the `:no-manual' and `:args' property can be used for +any (FUNC ..) form, all of the other properties shown above +cannot be used simultaneously in such a form. -If EVAL isn't a string, it will be printed with `prin1', and then -evaluated to give a result, which is also printed. If it's a -string, it'll be inserted as is, then the string will be `read', -and then evaluated. +Here are some common forms with examples of properties that go +together: -There can be any number of :example/:result elements." +1. Document a form or string, and its evaluated return value. + (FUNC + :eval EVAL) + +If EVAL is a string, it will be inserted as is, and then that +string will be `read' and evaluated. + +2. Document a form or string, but manually document its evalation + result. The provided form will not be evaluated. + + (FUNC + :no-eval EXAMPLE-FORM + :result RESULT-FORM ;Use `:result-string' if value is in string form + ) + +Using `:no-value' is the same as using `:no-eval'. + +Use `:no-eval*' instead of `:no-eval' where the successful +execution of the documented form depends on some conditions. + +3. Document a form or string EXAMPLE-FORM. Also manually + document an example result. This result could be unrelated to + the documented form. + + (FUNC + :no-eval EXAMPLE-FORM + :eg-result RESULT-FORM ;Use `:eg-result-string' if value is in string form + ) + +A FUNC form can have any number of `:no-eval' (or `:no-value'), +`:no-eval*', `:result', `:result-string', `:eg-result' and +`:eg-result-string' properties." (declare (indent defun)) `(progn (setq shortdoc--groups (delq (assq ',group shortdoc--groups) @@ -1408,11 +1445,14 @@ function's documentation in the Info manual"))) If GROUP doesn't exist, it will be created. If SECTION doesn't exist, it will be added. +ELEM is a Lisp form. See `define-short-documentation-group' for +details. + Example: (shortdoc-add-function - 'file \"Predicates\" - '(file-locked-p :no-eval (file-locked-p \"/tmp\")))" + \\='file \"Predicates\" + \\='(file-locked-p :no-eval (file-locked-p \"/tmp\")))" (let ((glist (assq group shortdoc--groups))) (unless glist (setq glist (list group)) -- cgit v1.2.3 From 6a480c830bc8d313ca3052570487a65411c937c2 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 11 Apr 2022 15:10:51 -0400 Subject: * lisp/emacs-lisp/macroexp.el (macroexp-let2*): Allow common shorthand --- doc/lispref/variables.texi | 10 +++++----- etc/NEWS | 3 +++ lisp/emacs-lisp/macroexp.el | 14 +++++++++++--- 3 files changed, 19 insertions(+), 8 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi index f85ed847c47..f0e3f337a69 100644 --- a/doc/lispref/variables.texi +++ b/doc/lispref/variables.texi @@ -2789,13 +2789,13 @@ implemented this way: (gv-define-expander substring (lambda (do place from &optional to) (gv-letplace (getter setter) place - (macroexp-let2* nil ((start from) (end to)) - (funcall do `(substring ,getter ,start ,end) + (macroexp-let2* (from to) + (funcall do `(substring ,getter ,from ,to) (lambda (v) - (macroexp-let2 nil v v + (macroexp-let2* (v) `(progn ,(funcall setter `(cl--set-substring - ,getter ,start ,end ,v)) + ,getter ,from ,to ,v)) ,v)))))))) @end example @end defmac @@ -2808,7 +2808,7 @@ of Common Lisp could be implemented this way: @example (defmacro incf (place &optional n) (gv-letplace (getter setter) place - (macroexp-let2 nil v (or n 1) + (macroexp-let2* ((v (or n 1))) (funcall setter `(+ ,v ,getter))))) @end example diff --git a/etc/NEWS b/etc/NEWS index 3c4dacf9124..79c27da5495 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1360,6 +1360,9 @@ functions. * Lisp Changes in Emacs 29.1 ++++ +** 'macroexp-let2*' can omit 'test' arg and use single-var bindings. + +++ ** New variable 'last-event-device' and new function 'device-class'. On X Windows, 'last-event-device' specifies the input extension device diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index e91b302af10..e4bc2df2803 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -567,12 +567,20 @@ cases where EXP is a constant." (defmacro macroexp-let2* (test bindings &rest body) "Multiple binding version of `macroexp-let2'. -BINDINGS is a list of elements of the form (SYM EXP). Each EXP -can refer to symbols specified earlier in the binding list." +BINDINGS is a list of elements of the form (SYM EXP) or just SYM, +which then stands for (SYM SYM). +Each EXP can refer to symbols specified earlier in the binding list. + +TEST has to be a symbol, and if it is nil it can be omitted." (declare (indent 2) (debug (sexp (&rest (sexp form)) body))) + (when (consp test) ;; `test' was omitted. + (push bindings body) + (setq bindings test) + (setq test nil)) (pcase-exhaustive bindings ('nil (macroexp-progn body)) - (`((,var ,exp) . ,tl) + (`(,(or `(,var ,exp) (and (pred symbolp) var (let exp var))) + . ,tl) `(macroexp-let2 ,test ,var ,exp (macroexp-let2* ,test ,tl ,@body))))) -- cgit v1.2.3 From 2e9111813b1dfdda1bf56c2b70a4220dbd8abce1 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Mon, 11 Apr 2022 09:20:35 -0700 Subject: Add two classic Common Lisp macro-writing macros * lisp/emacs-lisp/cl-macs.el (cl-with-gensyms, cl-once-only): New macros. --- lisp/emacs-lisp/cl-macs.el | 51 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 51 insertions(+) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index da7157f4341..af8855516ca 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2430,6 +2430,57 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). (unless advised (advice-remove 'macroexpand #'cl--sm-macroexpand))))) +;;;###autoload +(defmacro cl-with-gensyms (names &rest body) + "Bind each of NAMES to an uninterned symbol and evaluate BODY." + (declare (debug (sexp body)) (indent 1)) + `(let ,(cl-loop for name in names collect + `(,name (gensym (symbol-name ',name)))) + ,@body)) + +;;;###autoload +(defmacro cl-once-only (names &rest body) + "Generate code to evaluate each of NAMES just once in BODY. + +This macro helps with writing other macros. Each of names is +either (NAME FORM) or NAME, which latter means (NAME NAME). +During macroexpansion, each NAME is bound to an uninterned +symbol. The expansion evaluates each FORM and binds it to the +corresponding uninterned symbol. + +For example, consider this macro: + + (defmacro my-cons (x) + (cl-once-only (x) + \\=`(cons ,x ,x))) + +The call (my-cons (pop y)) will expand to something like this: + + (let ((g1 (pop y))) + (cons g1 g1)) + +The use of `cl-once-only' ensures that the pop is performed only +once, as intended. + +See also `macroexp-let2'." + (declare (debug (sexp body)) (indent 1)) + (setq names (mapcar #'ensure-list names)) + (let ((our-gensyms (cl-loop for _ in names collect (gensym)))) + ;; During macroexpansion, obtain a gensym for each NAME. + `(let ,(cl-loop for sym in our-gensyms collect `(,sym (gensym))) + ;; Evaluate each FORM and bind to the corresponding gensym. + ;; + ;; We require this explicit call to `list' rather than using + ;; (,,@(cl-loop ...)) due to a limitation of Elisp's backquote. + `(let ,(list + ,@(cl-loop for name in names and gensym in our-gensyms + for to-eval = (or (cadr name) (car name)) + collect ``(,,gensym ,,to-eval))) + ;; During macroexpansion, bind each NAME to its gensym. + ,(let ,(cl-loop for name in names and gensym in our-gensyms + collect `(,(car name) ,gensym)) + ,@body))))) + ;;; Multiple values. ;;;###autoload -- cgit v1.2.3 From 451eeb512dbfb5ccd4e75eca696a5d4143fec646 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Tue, 12 Apr 2022 17:59:22 +0200 Subject: Fix eager macroexpansion cycle in cl-once-only * lisp/emacs-lisp/cl-macs.el (cl-once-only): Use different cl-loop syntax, with no functional change, but such that the loop does not expand into cl-psetq. --- lisp/emacs-lisp/cl-macs.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index af8855516ca..364b5120a0a 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2473,11 +2473,11 @@ See also `macroexp-let2'." ;; We require this explicit call to `list' rather than using ;; (,,@(cl-loop ...)) due to a limitation of Elisp's backquote. `(let ,(list - ,@(cl-loop for name in names and gensym in our-gensyms + ,@(cl-loop for name in names for gensym in our-gensyms for to-eval = (or (cadr name) (car name)) collect ``(,,gensym ,,to-eval))) ;; During macroexpansion, bind each NAME to its gensym. - ,(let ,(cl-loop for name in names and gensym in our-gensyms + ,(let ,(cl-loop for name in names for gensym in our-gensyms collect `(,(car name) ,gensym)) ,@body))))) -- cgit v1.2.3 From 88a04ea985180d1fd619c4a6540fb117a1d59d9e Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 13 Apr 2022 05:07:30 +0200 Subject: Tweak how `M-q' in emacs-lisp-mode works * lisp/emacs-lisp/lisp-mode.el (lisp-fill-paragraph): Only fill as strings inside strings (bug#31656). (lisp--fill-line-simple): New function to do simple sexp-based filling. --- lisp/emacs-lisp/lisp-mode.el | 62 +++++++++++++++++++++++++++++--------------- 1 file changed, 41 insertions(+), 21 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 7df40e36f8f..e7c3a4b64f5 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -1436,29 +1436,49 @@ and initial semicolons." (derived-mode-p 'emacs-lisp-mode)) emacs-lisp-docstring-fill-column fill-column))) - (save-restriction + (let ((ppss (syntax-ppss)) + (start (point))) (save-excursion - (let ((ppss (syntax-ppss)) - (start (point))) - ;; If we're in a string, then narrow (roughly) to that - ;; string before filling. This avoids filling Lisp - ;; statements that follow the string. - (when (ppss-string-terminator ppss) - (goto-char (ppss-comment-or-string-start ppss)) - (beginning-of-line) - ;; The string may be unterminated -- in that case, don't - ;; narrow. - (when (ignore-errors - (progn - (forward-sexp 1) - t)) - (narrow-to-region (ppss-comment-or-string-start ppss) - (point)))) - ;; Move back to where we were. + (save-restriction + ;; If we're not inside a string, then do very basic + ;; filling. This avoids corrupting embedded strings in + ;; code. + (if (not (ppss-comment-or-string-start ppss)) + (lisp--fill-line-simple) + ;; If we're in a string, then narrow (roughly) to that + ;; string before filling. This avoids filling Lisp + ;; statements that follow the string. + (when (ppss-string-terminator ppss) + (goto-char (ppss-comment-or-string-start ppss)) + ;; The string may be unterminated -- in that case, don't + ;; narrow. + (when (ignore-errors + (progn + (forward-sexp 1) + t)) + (narrow-to-region (ppss-comment-or-string-start ppss) + (point)))) + ;; Move back to where we were. + (goto-char start) + (fill-paragraph justify))))))) + ;; Never return nil. + t) + +(defun lisp--fill-line-simple () + (narrow-to-region (line-beginning-position) (line-end-position)) + (goto-char (point-min)) + (while (and (not (eobp)) + (re-search-forward "\\_>" nil t)) + (when (> (current-column) fill-column) + (let ((start (point))) + (backward-sexp) + (if (looking-back "[[(]" (point-min)) (goto-char start) - (fill-paragraph justify))))) - ;; Never return nil. - t)) + (skip-chars-backward " \t") + (insert "\n") + (forward-sexp)))) + (unless (eobp) + (forward-char 1)))) (defun indent-code-rigidly (start end arg &optional nochange-regexp) "Indent all lines of code, starting in the region, sideways by ARG columns. -- cgit v1.2.3 From ab2b822b9bbac321ec061de349cf0166cc406fe7 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 13 Apr 2022 06:07:32 +0200 Subject: Revert "Make cl-concatenate an alias of seq-concatenate" This reverts commit 78f76fe16e2737b40694f82af28d17a90a21ed7b. The commit made calls to cl-concatenate bug out, since autoloading defalises doesn't work very well (bug#54901). --- lisp/emacs-lisp/cl-extra.el | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index ed9b1b7d836..fd94554ca19 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -554,9 +554,10 @@ too large if positive or too small if negative)." (seq-subseq seq start end)) ;;;###autoload -(defalias 'cl-concatenate #'seq-concatenate +(defun cl-concatenate (type &rest sequences) "Concatenate, into a sequence of type TYPE, the argument SEQUENCEs. -\n(fn TYPE SEQUENCE...)") +\n(fn TYPE SEQUENCE...)" + (apply #'seq-concatenate type sequences)) ;;; List functions. -- cgit v1.2.3 From 5ee959aa8783689627a1553c678fd4d3720236c8 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 13 Apr 2022 06:11:43 +0200 Subject: Add a comment about cl-concatenate * lisp/emacs-lisp/cl-extra.el (cl-concatenate): Add a comment. --- lisp/emacs-lisp/cl-extra.el | 3 +++ 1 file changed, 3 insertions(+) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index fd94554ca19..8e38df43c87 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -553,6 +553,9 @@ too large if positive or too small if negative)." ,new))))) (seq-subseq seq start end)) +;;; This isn't a defalias because autoloading defalises doesn't work +;;; very well. + ;;;###autoload (defun cl-concatenate (type &rest sequences) "Concatenate, into a sequence of type TYPE, the argument SEQUENCEs. -- cgit v1.2.3 From 8259e368001a6e30418efed40809e17f3f977622 Mon Sep 17 00:00:00 2001 From: Po Lu Date: Wed, 13 Apr 2022 07:17:30 +0000 Subject: Fix marking upgrades for packages from ELPA or NonGNU ELPA * lisp/emacs-lisp/package.el (package-menu--find-upgrades): Look inside ``external'' packages as well when searching for upgrades. (bug#54117) --- lisp/emacs-lisp/package.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 4f1ac5a5dac..f6aad64d358 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -3465,7 +3465,7 @@ corresponding to the newer version." ;; ENTRY is (PKG-DESC [NAME VERSION STATUS DOC]) (let ((pkg-desc (car entry)) (status (aref (cadr entry) 2))) - (cond ((member status '("installed" "dependency" "unsigned")) + (cond ((member status '("installed" "dependency" "unsigned" "external")) (push pkg-desc installed)) ((member status '("available" "new")) (setq available (package--append-to-alist pkg-desc available)))))) -- cgit v1.2.3 From 918669cb3db21eebc9fb409098a4395f131379ee Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 13 Apr 2022 15:31:02 +0200 Subject: Make list-times not include zero elements * doc/lispref/os.texi (Time Parsing): Mention %x. * lisp/calendar/time-date.el (format-seconds): Accept a new %x spec that removes trailing zeros (bug#54904). * lisp/emacs-lisp/timer-list.el (list-timers): Don't display trailing zero bits. --- doc/lispref/os.texi | 4 +++ etc/NEWS | 5 ++++ lisp/calendar/time-date.el | 56 +++++++++++++++++++++++++---------- lisp/emacs-lisp/timer-list.el | 2 +- test/lisp/calendar/time-date-tests.el | 9 ++++-- 5 files changed, 57 insertions(+), 19 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi index 9cb9bc75d04..4ee893f860f 100644 --- a/doc/lispref/os.texi +++ b/doc/lispref/os.texi @@ -1961,6 +1961,10 @@ encountered. For example, the default format used by @w{@code{"%Y, %D, %H, %M, %z%S"}} means that the number of seconds will always be produced, but years, days, hours, and minutes will only be shown if they are non-zero. +@item %x +Non-printing control flag that works along the same lines as +@samp{%z}, but instead suppresses printing of trailing zero-value time +elements. @item %% Produces a literal @samp{%}. @end table diff --git a/etc/NEWS b/etc/NEWS index 8665a825ce7..c24f3f6ed5a 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1856,6 +1856,11 @@ temporary transition aid for Emacs 27, has served its purpose. month, day, or time. For example, (date-to-time "2021-12-04") now assumes a time of 00:00 instead of signaling an error. ++++ +** 'format-seconds' now allows suppressing zero-value trailing elements. +The new "%x" non-printing control character will suppress zero-value +elements that appear after "%x". + +++ ** New events for taking advantage of touchscreen devices. The events 'touchscreen-begin, 'touchscreen-update', and diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index 51cf7eb213f..0db973ea161 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -287,17 +287,23 @@ use. \"%,1s\" means \"use one decimal\". The \"%z\" specifier does not print anything. When it is used, specifiers must be given in order of decreasing size. To the left of \"%z\", nothing -is output until the first non-zero unit is encountered." +is output until the first non-zero unit is encountered. + +The \"%x\" specifier does not print anything. When it is used, +specifiers must be given in order of decreasing size. To the +right of \"%x\", trailing zero units are not output." (let ((start 0) (units '(("y" "year" 31536000) ("d" "day" 86400) ("h" "hour" 3600) ("m" "minute" 60) ("s" "second" 1) - ("z"))) + ("z") + ("x"))) (case-fold-search t) - spec match usedunits zeroflag larger prev name unit num zeropos - fraction) + spec match usedunits zeroflag larger prev name unit num + leading-zeropos trailing-zeropos fraction + chop-leading chop-trailing) (while (string-match "%\\.?[0-9]*\\(,[0-9]\\)?\\(.\\)" string start) (setq start (match-end 0) spec (match-string 2 string)) @@ -306,15 +312,16 @@ is output until the first non-zero unit is encountered." (error "Bad format specifier: `%s'" spec)) (if (assoc (downcase spec) usedunits) (error "Multiple instances of specifier: `%s'" spec)) - (if (string-equal (car match) "z") + (if (or (string-equal (car match) "z") + (string-equal (car match) "x")) (setq zeroflag t) (unless larger (setq unit (nth 2 match) larger (and prev (> unit prev)) prev unit))) (push match usedunits))) - (and zeroflag larger - (error "Units are not in decreasing order of size")) + (when (and zeroflag larger) + (error "Units are not in decreasing order of size")) (unless (numberp seconds) (setq seconds (float-time seconds))) (setq fraction (mod seconds 1) @@ -326,18 +333,25 @@ is output until the first non-zero unit is encountered." (when (string-match (format "%%\\(\\.?[0-9]+\\)?\\(,[0-9]+\\)?\\(%s\\)" spec) string) - (if (string-equal spec "z") ; must be last in units - (setq string - (replace-regexp-in-string - "%z" "" - (substring string (min (or zeropos (match-end 0)) - (match-beginning 0))))) + (cond + ((string-equal spec "z") + (setq chop-leading (and leading-zeropos + (min leading-zeropos (match-beginning 0))))) + ((string-equal spec "x") + (setq chop-trailing t)) + (t ;; Cf article-make-date-line in gnus-art. (setq num (floor seconds unit) seconds (- seconds (* num unit))) ;; Start position of the first non-zero unit. - (or zeropos - (setq zeropos (unless (zerop num) (match-beginning 0)))) + (when (and (not leading-zeropos) + (not (zerop num))) + (setq leading-zeropos (match-beginning 0))) + (unless (zerop num) + (setq trailing-zeropos nil)) + (when (and (not trailing-zeropos) + (zerop num)) + (setq trailing-zeropos (match-beginning 0))) (setq string (replace-match (format (if (match-string 2 string) @@ -360,7 +374,17 @@ is output until the first non-zero unit is encountered." (format " %s%s" name (if (= num 1) "" "s")))) t t string)))))) - (string-replace "%%" "%" string)) + (let ((pre string)) + (when (and chop-trailing trailing-zeropos) + (setq string (substring string 0 trailing-zeropos))) + (when chop-leading + (setq string (substring string chop-leading))) + ;; If we ended up removing everything, return the formatted + ;; string in full. + (when (equal string "") + (setq string pre))) + (setq string (replace-regexp-in-string "%[zx]" "" string))) + (string-trim (string-replace "%%" "%" string))) (defvar seconds-to-string (list (list 1 "ms" 0.001) diff --git a/lisp/emacs-lisp/timer-list.el b/lisp/emacs-lisp/timer-list.el index c93a50cabfe..aef18d0ba27 100644 --- a/lisp/emacs-lisp/timer-list.el +++ b/lisp/emacs-lisp/timer-list.el @@ -62,7 +62,7 @@ ((numberp repeat) (propertize (format "%12s" (format-seconds - "%dd %hh %mm %z%,1ss" repeat)) + "%x%dd %hh %mm %z%,1ss" repeat)) 'help-echo "Repeat interval")) ((null repeat) (propertize " -" 'help-echo "Runs once")) diff --git a/test/lisp/calendar/time-date-tests.el b/test/lisp/calendar/time-date-tests.el index 5a37c914931..fd4d5ac8a1b 100644 --- a/test/lisp/calendar/time-date-tests.el +++ b/test/lisp/calendar/time-date-tests.el @@ -88,14 +88,19 @@ (ert-deftest test-format-seconds () (should (equal (format-seconds "%y %d %h %m %s %%" 0) "0 0 0 0 0 %")) (should (equal (format-seconds "%y %d %h %m %s %%" 9999999) "0 115 17 46 39 %")) - (should (equal (format-seconds "%y %d %h %m %z %s %%" 1) " 1 %")) + (should (equal (format-seconds "%y %d %h %m %z %s %%" 1) "1 %")) (should (equal (format-seconds "%mm %ss" 66) "1m 6s")) (should (equal (format-seconds "%mm %5ss" 66) "1m 6s")) (should (equal (format-seconds "%mm %.5ss" 66.4) "1m 00006s")) (should (equal (format-seconds "%mm %,1ss" 66.4) "1m 6.4s")) (should (equal (format-seconds "%mm %5,1ss" 66.4) "1m 6.4s")) - (should (equal (format-seconds "%mm %.5,1ss" 66.4) "1m 006.4s"))) + (should (equal (format-seconds "%mm %.5,1ss" 66.4) "1m 006.4s")) + + (should (equal (format-seconds "%hh %z%x%mm %ss" (* 60 2)) "2m")) + (should (equal (format-seconds "%hh %z%mm %ss" (* 60 2)) "2m 0s")) + (should (equal (format-seconds "%hh %x%mm %ss" (* 60 2)) "0h 2m")) + (should (equal (format-seconds "%hh %x%mm %ss" 0) "0h 0m 0s"))) (ert-deftest test-ordinal () (should (equal (date-ordinal-to-time 2008 271) -- cgit v1.2.3 From 29fae93d1c480cc69406a19ab9ef69d84ef8142f Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 13 Apr 2022 16:25:52 +0200 Subject: Add support for column background colors in vtable * doc/misc/vtable.texi (Making A Table): Document it. * lisp/emacs-lisp/vtable.el (vtable): Add a column color element. (make-vtable): Use it. (vtable--insert-line): Insert the colors here. --- doc/misc/vtable.texi | 6 ++++++ lisp/emacs-lisp/vtable.el | 15 ++++++++++++--- 2 files changed, 18 insertions(+), 3 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/misc/vtable.texi b/doc/misc/vtable.texi index 472dee70ec0..48e6301fce0 100644 --- a/doc/misc/vtable.texi +++ b/doc/misc/vtable.texi @@ -387,6 +387,12 @@ The face to be used. This defaults to @code{variable-pitch}. This face doesn't override the faces in the data, or the faces supplied by the getter and formatter functions. +@item :column-colors +If present, this should be a list of color names to be used as the +background color on the columns. If there are fewer colors here than +there are columns, the colors will be repeated. The most common use +case here is to have alternating background colors on the columns. + @item :actions This uses the same syntax as @code{define-keymap}, but doesn't refer to commands directly. Instead each key is bound to a command that diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index 8d777335315..98106e46700 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -57,6 +57,7 @@ (separator-width :initarg :separator-width :accessor vtable-separator-width) (sort-by :initarg :sort-by :accessor vtable-sort-by) (ellipsis :initarg :ellipsis :accessor vtable-ellipsis) + (column-colors :initarg :column-colors :accessor vtable-column-colors) (-cache :initform (make-hash-table :test #'equal))) "A object to hold the data for a table.") @@ -83,7 +84,8 @@ (separator-width 1) sort-by (ellipsis t) - (insert t)) + (insert t) + column-colors) "Create and insert a vtable at point. The vtable object is returned. If INSERT is nil, the table won't be inserted." @@ -122,6 +124,7 @@ be inserted." :keymap keymap :separator-width separator-width :sort-by sort-by + :column-colors column-colors :ellipsis ellipsis))) ;; Compute missing column data. (setf (vtable-columns table) (vtable--compute-columns table)) @@ -377,7 +380,8 @@ This also updates the displayed table." (defun vtable--insert-line (table line widths spacer &optional ellipsis ellipsis-width) (let ((start (point)) - (columns (vtable-columns table))) + (columns (vtable-columns table)) + (colors (vtable-column-colors table))) (seq-do-indexed (lambda (elem index) (let ((value (nth 0 elem)) @@ -438,7 +442,12 @@ This also updates the displayed table." (propertize " " 'display (list 'space :width (list spacer))))) - (put-text-property start (point) 'vtable-column index)))) + (put-text-property start (point) 'vtable-column index) + (when colors + (add-face-text-property + start (point) + (list :background + (elt colors (mod index (length colors))))))))) (cdr line)) (insert "\n") (put-text-property start (point) 'vtable-object (car line)))) -- cgit v1.2.3 From 6c3869a104075403b10130294e7f307143e09a73 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 13 Apr 2022 23:19:01 +0200 Subject: Add a new `vtable' face * doc/misc/vtable.texi (Introduction): Document it. * lisp/emacs-lisp/vtable.el (vtable): Add a new face. --- doc/misc/vtable.texi | 12 ++++++------ lisp/emacs-lisp/vtable.el | 8 +++++++- 2 files changed, 13 insertions(+), 7 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/misc/vtable.texi b/doc/misc/vtable.texi index 48e6301fce0..4f7b722a289 100644 --- a/doc/misc/vtable.texi +++ b/doc/misc/vtable.texi @@ -88,9 +88,9 @@ Here's just about the simplest vtable that can be created: ("Gazonk" 45))) @end lisp -By default, vtable uses the @code{variable-pitch} font, and -right-aligns columns that have only numerical data (and left-aligns -the rest). +By default, vtable uses the @code{vtable} face (which inherits from +the @code{variable-pitch} face), and right-aligns columns that have +only numerical data (and left-aligns the rest). You'd normally want to name the columns: @@ -383,9 +383,9 @@ there are several tables in the same buffer, then this should be @code{nil}. @item :face -The face to be used. This defaults to @code{variable-pitch}. This -face doesn't override the faces in the data, or the faces supplied by -the getter and formatter functions. +The face to be used. This defaults to @code{vtable}. This face +doesn't override the faces in the data, or the faces supplied by the +getter and formatter functions. @item :column-colors If present, this should be a list of color names to be used as the diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index 98106e46700..3e521c94a5c 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -28,6 +28,12 @@ (require 'text-property-search) (require 'mule-util) +(defface vtable + '((t :inherit variable-pitch)) + "Face used (by default) for vtables." + :version "29.1" + :group 'faces) + (cl-defstruct vtable-column "A vtable column." name @@ -79,7 +85,7 @@ formatter displayer (use-header-line t) - (face 'variable-pitch) + (face 'vtable) actions keymap (separator-width 1) sort-by -- cgit v1.2.3 From 800998808a1ebf83263ffbdea833c155fcbae7a6 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 14 Apr 2022 01:00:44 +0200 Subject: Allow putting alternating colors on vtable rows * doc/misc/vtable.texi (Making A Table): Document it. * lisp/emacs-lisp/vtable.el (vtable): Add :row-colors. (make-vtable): Ditto. (vtable--compute-colors, vtable--color-blend): New functions. (vtable--insert-line): Take a line number argument and adjust callers. --- doc/misc/vtable.texi | 12 +++++++++- lisp/emacs-lisp/vtable.el | 61 ++++++++++++++++++++++++++++++++++++++--------- 2 files changed, 61 insertions(+), 12 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/misc/vtable.texi b/doc/misc/vtable.texi index 4f7b722a289..77cb8663af4 100644 --- a/doc/misc/vtable.texi +++ b/doc/misc/vtable.texi @@ -387,11 +387,21 @@ The face to be used. This defaults to @code{vtable}. This face doesn't override the faces in the data, or the faces supplied by the getter and formatter functions. +@item :row-colors +If present, this should be a list of color names to be used as the +background color on the rows. If there are fewer colors here than +there are rows, the rows will be repeated. The most common use +case here is to have alternating background colors on the rows, so +this would usually be a list of two colors. + @item :column-colors If present, this should be a list of color names to be used as the background color on the columns. If there are fewer colors here than there are columns, the colors will be repeated. The most common use -case here is to have alternating background colors on the columns. +case here is to have alternating background colors on the columns, so +this would usually be a list of two colors. If both +@code{:row-colors} and @code{:column-colors} is present, the colors +will be ``blended'' to produce the final colors in the table. @item :actions This uses the same syntax as @code{define-keymap}, but doesn't refer diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index 3e521c94a5c..e0010434447 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -64,6 +64,8 @@ (sort-by :initarg :sort-by :accessor vtable-sort-by) (ellipsis :initarg :ellipsis :accessor vtable-ellipsis) (column-colors :initarg :column-colors :accessor vtable-column-colors) + (row-colors :initarg :row-colors :accessor vtable-row-colors) + (-cached-colors :initform nil :accessor vtable--cached-colors) (-cache :initform (make-hash-table :test #'equal))) "A object to hold the data for a table.") @@ -91,6 +93,7 @@ sort-by (ellipsis t) (insert t) + row-colors column-colors) "Create and insert a vtable at point. The vtable object is returned. If INSERT is nil, the table won't @@ -130,10 +133,15 @@ be inserted." :keymap keymap :separator-width separator-width :sort-by sort-by + :row-colors row-colors :column-colors column-colors :ellipsis ellipsis))) ;; Compute missing column data. (setf (vtable-columns table) (vtable--compute-columns table)) + ;; Compute colors if we have to mix them. + (when (and row-colors column-colors) + (setf (vtable--cached-colors table) + (vtable--compute-colors row-colors column-colors))) (unless sort-by (seq-do-indexed (lambda (column index) (when (vtable-column-primary column) @@ -144,6 +152,20 @@ be inserted." (vtable-insert table)) table)) +(defun vtable--compute-colors (row-colors column-colors) + (cl-loop for row in row-colors + collect (cl-loop for column in column-colors + collect (vtable--color-blend row column)))) + +;;; FIXME: This is probably not the right way to blend two colors, is +;;; it? +(defun vtable--color-blend (color1 color2) + (cl-destructuring-bind (r g b) + (mapcar (lambda (n) (* (/ n 2) 255.0)) + (cl-mapcar #'+ (color-name-to-rgb color1) + (color-name-to-rgb color2))) + (format "#%02X%02X%02X" r g b))) + ;;; Interface utility functions. (defun vtable-current-table () @@ -219,7 +241,8 @@ If it can't be found, return nil and don't move point." (error "Can't find the old object")) (setcar (cdr objects) object)) ;; Then update the cache... - (let ((line (assq old-object (car (vtable--cache table))))) + (let* ((line-number (seq-position old-object (car (vtable--cache table)))) + (line (elt (car (vtable--cache table)) line-number))) (unless line (error "Can't find cached object")) (setcar line object) @@ -230,7 +253,8 @@ If it can't be found, return nil and don't move point." (let ((keymap (get-text-property (point) 'keymap)) (start (point))) (delete-line) - (vtable--insert-line table line (nth 1 (vtable--cache table)) + (vtable--insert-line table line line-number + (nth 1 (vtable--cache table)) (vtable--spacer table)) (add-text-properties start (point) (list 'keymap keymap 'vtable table)))) @@ -285,7 +309,10 @@ This also updates the displayed table." (unless (vtable-goto-object after-object) (vtable-end-of-table)))) (let ((start (point))) - (vtable--insert-line table line (nth 1 cache) (vtable--spacer table)) + ;; FIXME: We have to adjust colors in lines below this if we + ;; have :row-colors. + (vtable--insert-line table line 0 + (nth 1 cache) (vtable--spacer table)) (add-text-properties start (point) (list 'keymap keymap 'vtable table))) ;; We may have inserted a non-numerical value into a previously @@ -374,20 +401,26 @@ This also updates the displayed table." (setq start (point))) (vtable--sort table) ;; Insert the data. - (dolist (line (car (vtable--cache table))) - (vtable--insert-line table line widths spacer - ellipsis ellipsis-width)) + (let ((line-number 0)) + (dolist (line (car (vtable--cache table))) + (vtable--insert-line table line line-number widths spacer + ellipsis ellipsis-width) + (setq line-number (1+ line-number)))) (add-text-properties start (point) (list 'keymap (vtable--make-keymap table) 'rear-nonsticky t 'vtable table)) (goto-char start))) -(defun vtable--insert-line (table line widths spacer +(defun vtable--insert-line (table line line-number widths spacer &optional ellipsis ellipsis-width) (let ((start (point)) (columns (vtable-columns table)) - (colors (vtable-column-colors table))) + (column-colors + (if (vtable-row-colors table) + (elt (vtable--cached-colors table) + (mod line-number (length (vtable-row-colors table)))) + (vtable-column-colors table)))) (seq-do-indexed (lambda (elem index) (let ((value (nth 0 elem)) @@ -449,14 +482,20 @@ This also updates the displayed table." (list 'space :width (list spacer))))) (put-text-property start (point) 'vtable-column index) - (when colors + (when column-colors (add-face-text-property start (point) (list :background - (elt colors (mod index (length colors))))))))) + (elt column-colors (mod index (length column-colors))))))))) (cdr line)) (insert "\n") - (put-text-property start (point) 'vtable-object (car line)))) + (put-text-property start (point) 'vtable-object (car line)) + (unless column-colors + (when-let ((row-colors (vtable-row-colors table))) + (add-face-text-property + start (point) + (list :background + (elt row-colors (mod line-number (length row-colors))))))))) (defun vtable--cache-key () (cons (frame-terminal) (window-width))) -- cgit v1.2.3 From a96679b742fef2058497ae445516f630c77d2a25 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 14 Apr 2022 01:36:24 +0200 Subject: Allow having dividers between columns in vtable * doc/misc/vtable.texi (Making A Table): Document it. * lisp/emacs-lisp/vtable.el (vtable): Add a divider slot. (make-vtable): Accept :divider and :divider-width arguments. (vtable--insert-line, vtable--insert-header-line): Display the divider. --- doc/misc/vtable.texi | 7 ++++ lisp/emacs-lisp/vtable.el | 89 ++++++++++++++++++++++++++++++----------------- 2 files changed, 64 insertions(+), 32 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/misc/vtable.texi b/doc/misc/vtable.texi index 77cb8663af4..5a3957758c9 100644 --- a/doc/misc/vtable.texi +++ b/doc/misc/vtable.texi @@ -418,6 +418,13 @@ current line, they can use the @code{vtable-current-object} function @item :separator-width The width of the blank space between columns. +@item :divider-width +@itemx :divider +You can have a divider inserted between the columns. This can either +be specified by using @code{:divider}, which should be a string to be +displayed between the columns, or @code{:divider-width}, which +specifies the width of the space to be used as the divider. + @item :sort-by This should be a list of tuples, and specifies how the table is to be sorted. Each tuple should consist of an integer (the column index) diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index e0010434447..9b820c329a0 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -61,6 +61,7 @@ (actions :initarg :actions :accessor vtable-actions) (keymap :initarg :keymap :accessor vtable-keymap) (separator-width :initarg :separator-width :accessor vtable-separator-width) + (divider :initarg :divider :accessor vtable-divider :initform nil) (sort-by :initarg :sort-by :accessor vtable-sort-by) (ellipsis :initarg :ellipsis :accessor vtable-ellipsis) (column-colors :initarg :column-colors :accessor vtable-column-colors) @@ -90,6 +91,8 @@ (face 'vtable) actions keymap (separator-width 1) + divider + divider-width sort-by (ellipsis t) (insert t) @@ -120,28 +123,39 @@ be inserted." ;; We'll be altering the list, so create a copy. (setq objects (copy-sequence objects)) (let ((table - (make-instance 'vtable - :columns columns - :objects objects - :objects-function objects-function - :getter getter - :formatter formatter - :displayer displayer - :use-header-line use-header-line - :face face - :actions actions - :keymap keymap - :separator-width separator-width - :sort-by sort-by - :row-colors row-colors - :column-colors column-colors - :ellipsis ellipsis))) + (make-instance + 'vtable + :columns columns + :objects objects + :objects-function objects-function + :getter getter + :formatter formatter + :displayer displayer + :use-header-line use-header-line + :face face + :actions actions + :keymap keymap + :separator-width separator-width + :sort-by sort-by + :row-colors row-colors + :column-colors column-colors + :ellipsis ellipsis))) ;; Compute missing column data. (setf (vtable-columns table) (vtable--compute-columns table)) ;; Compute colors if we have to mix them. (when (and row-colors column-colors) (setf (vtable--cached-colors table) (vtable--compute-colors row-colors column-colors))) + ;; Compute the divider. + (when (or divider divider-width) + (setf (vtable-divider table) + (or divider + (and divider-width + (propertize + " " 'display + (list 'space :width + (list (vtable--compute-width + table divider-width)))))))) (unless sort-by (seq-do-indexed (lambda (column index) (when (vtable-column-primary column) @@ -420,7 +434,8 @@ This also updates the displayed table." (if (vtable-row-colors table) (elt (vtable--cached-colors table) (mod line-number (length (vtable-row-colors table)))) - (vtable-column-colors table)))) + (vtable-column-colors table))) + (divider (vtable-divider table))) (seq-do-indexed (lambda (elem index) (let ((value (nth 0 elem)) @@ -461,32 +476,40 @@ This also updates the displayed table." value (- (elt widths index) ellipsis-width)) ellipsis) value)))) - (start (point))) + (start (point)) + ;; Don't insert the separator and the divider after the + ;; final column. + (last (= index (- (length line) 2)))) (if (eq (vtable-column-align column) 'left) - (insert displayed - (propertize - " " 'display - (list 'space - :width (list - (+ (- (elt widths index) - (string-pixel-width displayed)) - spacer))))) + (progn + (insert displayed) + (insert (propertize + " " 'display + (list 'space + :width (list + (+ (- (elt widths index) + (string-pixel-width displayed)) + (if last 0 spacer))))))) ;; Align to the right. (insert (propertize " " 'display (list 'space :width (list (- (elt widths index) (string-pixel-width displayed))))) - displayed - (propertize " " 'display - (list 'space - :width (list spacer))))) + displayed) + (unless last + (insert (propertize " " 'display + (list 'space + :width (list spacer)))))) (put-text-property start (point) 'vtable-column index) (when column-colors (add-face-text-property start (point) (list :background - (elt column-colors (mod index (length column-colors))))))))) + (elt column-colors (mod index (length column-colors)))))) + (when (and divider (not last)) + (insert divider) + (setq start (point)))))) (cdr line)) (insert "\n") (put-text-property start (point) 'vtable-object (car line)) @@ -556,6 +579,7 @@ This also updates the displayed table." (start (point)) (indicator (vtable--indicator table index)) (indicator-width (string-pixel-width indicator)) + (last (= index (1- (length (vtable-columns table))))) displayed) (insert (setq displayed @@ -566,11 +590,12 @@ This also updates the displayed table." name (- (elt widths index) indicator-width)) name) indicator)) + (or (vtable-divider table) "") (propertize " " 'display (list 'space :width (list (+ (- (elt widths index) (string-pixel-width displayed)) - spacer))))) + (if last 0 spacer)))))) (put-text-property start (point) 'vtable-column index))) (vtable-columns table)) (insert "\n") -- cgit v1.2.3 From 574ae74caa83194a9b4ce3d1f4239d10aabba2eb Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 14 Apr 2022 01:56:15 +0200 Subject: Fix dividers in vtable header lines * lisp/emacs-lisp/vtable.el (vtable--insert-header-line): Put the divider in the correct place in the header line. --- doc/misc/vtable.texi | 2 -- lisp/emacs-lisp/vtable.el | 4 ++-- 2 files changed, 2 insertions(+), 4 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/misc/vtable.texi b/doc/misc/vtable.texi index 5a3957758c9..5e96206528f 100644 --- a/doc/misc/vtable.texi +++ b/doc/misc/vtable.texi @@ -143,8 +143,6 @@ version of @kbd{M-x list-buffers}: (make-vtable :columns '("Name" "Size" "File") :objects (buffer-list) - :actions '("k" kill-buffer - "RET" display-buffer) :getter (lambda (object column vtable) (pcase (vtable-column vtable column) ("Name" (buffer-name object)) diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index 9b820c329a0..de7b9b7cdf5 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -590,12 +590,12 @@ This also updates the displayed table." name (- (elt widths index) indicator-width)) name) indicator)) - (or (vtable-divider table) "") (propertize " " 'display (list 'space :width (list (+ (- (elt widths index) (string-pixel-width displayed)) - (if last 0 spacer)))))) + (if last 0 spacer))))) + (or (vtable-divider table) "")) (put-text-property start (point) 'vtable-column index))) (vtable-columns table)) (insert "\n") -- cgit v1.2.3 From 5a9e4f2230e76d53499cdd574a2cca61c9c3a1d0 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 14 Apr 2022 02:18:01 +0200 Subject: Further divider fixes for vtable * lisp/emacs-lisp/vtable.el (vtable--insert-header-line): Don't insert the divider at the end. (vtable-narrow-current-column, vtable-widen-current-column): Don't error out when being called on the divider. --- lisp/emacs-lisp/vtable.el | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index de7b9b7cdf5..943ede159a1 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -570,7 +570,8 @@ This also updates the displayed table." (defun vtable--insert-header-line (table widths spacer) ;; Insert the header directly into the buffer. - (let* ((start (point))) + (let ((start (point)) + (divider (vtable-divider table))) (seq-do-indexed (lambda (column index) (let* ((name (propertize @@ -594,8 +595,9 @@ This also updates the displayed table." (list 'space :width (list (+ (- (elt widths index) (string-pixel-width displayed)) - (if last 0 spacer))))) - (or (vtable-divider table) "")) + (if last 0 spacer)))))) + (when (and divider (not last)) + (insert divider)) (put-text-property start (point) 'vtable-column index))) (vtable-columns table)) (insert "\n") @@ -762,6 +764,8 @@ This also updates the displayed table." (let* ((table (vtable-current-table)) (column (vtable-current-column)) (widths (vtable--widths table))) + (unless column + (user-error "No column under point")) (setf (aref widths column) (max (* (vtable--char-width table) 2) (- (aref widths column) (vtable--char-width table)))) @@ -773,6 +777,8 @@ This also updates the displayed table." (let* ((table (vtable-current-table)) (column (vtable-current-column)) (widths (nth 1 (vtable--cache table)))) + (unless column + (user-error "No column under point")) (cl-incf (aref widths column) (vtable--char-width table)) (vtable-revert))) -- cgit v1.2.3 From 8969836cb8e36df9dcd3f5031b2dcc648c4c90dc Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 14 Apr 2022 02:37:44 +0200 Subject: Edit some vtable doc strings * lisp/emacs-lisp/vtable.el (make-vtable, vtable): Improve doc strings. --- lisp/emacs-lisp/vtable.el | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index 943ede159a1..2c6c90ee1f5 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -68,7 +68,7 @@ (row-colors :initarg :row-colors :accessor vtable-row-colors) (-cached-colors :initform nil :accessor vtable--cached-colors) (-cache :initform (make-hash-table :test #'equal))) - "A object to hold the data for a table.") + "An object to hold the data for a table.") (defvar-keymap vtable-map "S" #'vtable-sort-by-current-column @@ -100,7 +100,9 @@ column-colors) "Create and insert a vtable at point. The vtable object is returned. If INSERT is nil, the table won't -be inserted." +be inserted. + +See info node `(vtable)Top' for vtable documentation." (when objects-function (setq objects (funcall objects-function))) ;; Auto-generate the columns. -- cgit v1.2.3 From ffb7612d2cf84ca1863a10873eb4a9721ffc720d Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 14 Apr 2022 02:41:27 +0200 Subject: Copy edit make-vtable code * lisp/emacs-lisp/vtable.el (make-vtable): Clean up code slightly. --- lisp/emacs-lisp/vtable.el | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index 2c6c90ee1f5..03fe54c94e9 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -152,12 +152,10 @@ See info node `(vtable)Top' for vtable documentation." (when (or divider divider-width) (setf (vtable-divider table) (or divider - (and divider-width - (propertize - " " 'display - (list 'space :width - (list (vtable--compute-width - table divider-width)))))))) + (propertize + " " 'display + (list 'space :width + (list (vtable--compute-width table divider-width))))))) (unless sort-by (seq-do-indexed (lambda (column index) (when (vtable-column-primary column) -- cgit v1.2.3 From c3b6cfda3621c61634a6be37cbc3d62406daee00 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 14 Apr 2022 02:47:23 +0200 Subject: Make vtable narrow/widen functions take a prefix * lisp/emacs-lisp/vtable.el (vtable-narrow-current-column) (vtable-widen-current-column): Allow using the prefix to say how much to narrow/widen the columns. --- lisp/emacs-lisp/vtable.el | 24 ++++++++++++++++-------- 1 file changed, 16 insertions(+), 8 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index 03fe54c94e9..f14c9ae9a65 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -758,9 +758,12 @@ This also updates the displayed table." "Minor mode for buffers with vtables with headers." :keymap vtable-header-mode-map) -(defun vtable-narrow-current-column () - "Narrow the current column." - (interactive) +(defun vtable-narrow-current-column (&optional n) + "Narrow the current column by N characters. +If N isn't given, N defaults to 1. + +Interactively, N is the prefix argument." + (interactive "p") (let* ((table (vtable-current-table)) (column (vtable-current-column)) (widths (vtable--widths table))) @@ -768,18 +771,23 @@ This also updates the displayed table." (user-error "No column under point")) (setf (aref widths column) (max (* (vtable--char-width table) 2) - (- (aref widths column) (vtable--char-width table)))) + (- (aref widths column) + (* (vtable--char-width table) (or n 1))))) (vtable-revert))) -(defun vtable-widen-current-column () - "Widen the current column." - (interactive) +(defun vtable-widen-current-column (&optional n) + "Widen the current column by N characters. +If N isn't given, N defaults to 1. + +Interactively, N is the prefix argument." + (interactive "p") (let* ((table (vtable-current-table)) (column (vtable-current-column)) (widths (nth 1 (vtable--cache table)))) (unless column (user-error "No column under point")) - (cl-incf (aref widths column) (vtable--char-width table)) + (cl-incf (aref widths column) + (* (vtable--char-width table) (or n 1))) (vtable-revert))) (defun vtable-previous-column () -- cgit v1.2.3 From e7f7930a61e6603a3d489b5d09db24ac48870f49 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 14 Apr 2022 16:25:31 +0200 Subject: Ensure that commands like { work on all frames in vtable * lisp/emacs-lisp/vtable.el (vtable--recompute-cache) (vtable--ensure-cache): New functions. (vtable-insert): Use it. (vtable--widths): Ditto. --- lisp/emacs-lisp/vtable.el | 29 ++++++++++++++++------------- 1 file changed, 16 insertions(+), 13 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index f14c9ae9a65..66feec4e69a 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -383,6 +383,16 @@ This also updates the displayed table." (defun vtable--spacer (table) (vtable--compute-width table (vtable-separator-width table))) +(defun vtable--recompute-cache (table) + (let* ((data (vtable--compute-cache table)) + (widths (vtable--compute-widths table data))) + (setf (gethash (vtable--cache-key) (slot-value table '-cache)) + (list data widths)))) + +(defun vtable--ensure-cache (table) + (or (vtable--cache table) + (vtable--recompute-cache table))) + (defun vtable-insert (table) (let* ((spacer (vtable--spacer table)) (start (point)) @@ -391,17 +401,10 @@ This also updates the displayed table." 'face (vtable-face table)) "")) (ellipsis-width (string-pixel-width ellipsis)) - data widths) - ;; We maintain a cache per screen/window width, so that we render - ;; correctly if Emacs is open on two different screens (or the - ;; user resizes the frame). - (if-let ((cache (vtable--cache table))) - (setq data (nth 0 cache) - widths (nth 1 cache)) - (setq data (vtable--compute-cache table) - widths (vtable--compute-widths table data)) - (setf (gethash (vtable--cache-key) (slot-value table '-cache)) - (list data widths))) + ;; We maintain a cache per screen/window width, so that we render + ;; correctly if Emacs is open on two different screens (or the + ;; user resizes the frame). + (widths (nth 1 (vtable--ensure-cache table)))) (if (vtable-use-header-line table) (vtable--set-header-line table widths spacer) ;; Insert the header line directly into the buffer, and put a @@ -746,7 +749,7 @@ This also updates the displayed table." (vtable-goto-column column)))) (defun vtable--widths (table) - (nth 1 (vtable--cache table))) + (nth 1 (vtable--ensure-cache table))) ;;; Commands. @@ -783,7 +786,7 @@ Interactively, N is the prefix argument." (interactive "p") (let* ((table (vtable-current-table)) (column (vtable-current-column)) - (widths (nth 1 (vtable--cache table)))) + (widths (vtable--widths table))) (unless column (user-error "No column under point")) (cl-incf (aref widths column) -- cgit v1.2.3 From f498d055a4bd8f7b650faddd8033100069750d78 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 14 Apr 2022 18:03:58 +0200 Subject: Make vtable remember user-altered column widths * lisp/emacs-lisp/vtable.el (vtable-narrow-current-column) (vtable-widen-current-column): Store the size to that it's respected on `g'. --- lisp/emacs-lisp/vtable.el | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index 66feec4e69a..d53f8b07450 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -776,6 +776,9 @@ Interactively, N is the prefix argument." (max (* (vtable--char-width table) 2) (- (aref widths column) (* (vtable--char-width table) (or n 1))))) + ;; Store the width so it'll be respected on a revert. + (setf (vtable-column-width (elt (vtable-columns table) column)) + (format "%dpx" (aref widths column))) (vtable-revert))) (defun vtable-widen-current-column (&optional n) @@ -791,6 +794,9 @@ Interactively, N is the prefix argument." (user-error "No column under point")) (cl-incf (aref widths column) (* (vtable--char-width table) (or n 1))) + ;; Store the width so it'll be respected on a revert. + (setf (vtable-column-width (elt (vtable-columns table) column)) + (format "%dpx" (aref widths column))) (vtable-revert))) (defun vtable-previous-column () -- cgit v1.2.3 From be54c25dbb42425701cee3d669d37acdacfa17ce Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 14 Apr 2022 19:36:08 +0200 Subject: Allow resizing vtable columns by dragging * lisp/emacs-lisp/vtable.el (vtable--insert-header-line): Allow resizing by dragging headers. (vtable--drag-resize-column): New function. (vtable-narrow-current-column): Refactor out common bits. (vtable--alter-column-width): To here. (vtable-widen-current-column): Rewrite to use vtable-narrow-current-column. --- lisp/emacs-lisp/vtable.el | 47 +++++++++++++++++++++++++++++++---------------- 1 file changed, 31 insertions(+), 16 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index d53f8b07450..5900d886e80 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -579,7 +579,11 @@ This also updates the displayed table." (lambda (column index) (let* ((name (propertize (vtable-column-name column) - 'face (list 'header-line (vtable-face table)))) + 'face (list 'header-line (vtable-face table)) + 'keymap (define-keymap + " " + #'vtable--drag-resize-column + " " #'ignore))) (start (point)) (indicator (vtable--indicator table index)) (indicator-width (string-pixel-width indicator)) @@ -606,6 +610,24 @@ This also updates the displayed table." (insert "\n") (add-face-text-property start (point) 'header-line))) +(defun vtable--drag-resize-column (e) + "Resize the column by dragging." + (interactive "e") + (let* ((pos-start (event-start e)) + (obj (posn-object pos-start))) + (with-current-buffer (window-buffer (posn-window pos-start)) + (let ((column + (get-text-property (if obj (cdr obj) + (posn-point pos-start)) + 'vtable-column + (car obj))) + (start-x (car (posn-x-y pos-start))) + (end-x (car (posn-x-y (event-end e))))) + (when (> column 0) + (vtable--alter-column-width (vtable-current-table) + (1- column) + (- end-x start-x))))))) + (defun vtable--recompute-numerical (table line) "Recompute numericalness of columns if necessary." (let ((columns (vtable-columns table)) @@ -768,14 +790,17 @@ If N isn't given, N defaults to 1. Interactively, N is the prefix argument." (interactive "p") (let* ((table (vtable-current-table)) - (column (vtable-current-column)) - (widths (vtable--widths table))) + (column (vtable-current-column))) (unless column (user-error "No column under point")) + (vtable--alter-column-width table column + (- (* (vtable--char-width table) (or n 1)))))) + +(defun vtable--alter-column-width (table column delta) + (let ((widths (vtable--widths table))) (setf (aref widths column) (max (* (vtable--char-width table) 2) - (- (aref widths column) - (* (vtable--char-width table) (or n 1))))) + (+ (aref widths column) delta))) ;; Store the width so it'll be respected on a revert. (setf (vtable-column-width (elt (vtable-columns table) column)) (format "%dpx" (aref widths column))) @@ -787,17 +812,7 @@ If N isn't given, N defaults to 1. Interactively, N is the prefix argument." (interactive "p") - (let* ((table (vtable-current-table)) - (column (vtable-current-column)) - (widths (vtable--widths table))) - (unless column - (user-error "No column under point")) - (cl-incf (aref widths column) - (* (vtable--char-width table) (or n 1))) - ;; Store the width so it'll be respected on a revert. - (setf (vtable-column-width (elt (vtable-columns table) column)) - (format "%dpx" (aref widths column))) - (vtable-revert))) + (vtable-narrow-current-column (- n))) (defun vtable-previous-column () "Go to the previous column." -- cgit v1.2.3 From 807682de1e427ec5a9b43e8fb6a4c9befa73fed3 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 14 Apr 2022 19:48:47 +0200 Subject: Allow dragging dividers in vtable * lisp/emacs-lisp/vtable.el (vtable--insert-header-line): Allow dragging dividers. (vtable--drag-resize-column): Adjust function. --- lisp/emacs-lisp/vtable.el | 29 +++++++++++++++++++---------- 1 file changed, 19 insertions(+), 10 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index 5900d886e80..9201fea3656 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -574,16 +574,22 @@ This also updates the displayed table." (defun vtable--insert-header-line (table widths spacer) ;; Insert the header directly into the buffer. (let ((start (point)) - (divider (vtable-divider table))) + (divider (vtable-divider table)) + (cmap (define-keymap + " " #'vtable--drag-resize-column + " " #'ignore)) + (dmap (define-keymap + " " + (lambda (e) + (interactive "e") + (vtable--drag-resize-column e t)) + " " #'ignore))) (seq-do-indexed (lambda (column index) (let* ((name (propertize (vtable-column-name column) 'face (list 'header-line (vtable-face table)) - 'keymap (define-keymap - " " - #'vtable--drag-resize-column - " " #'ignore))) + 'keymap cmap)) (start (point)) (indicator (vtable--indicator table index)) (indicator-width (string-pixel-width indicator)) @@ -604,14 +610,15 @@ This also updates the displayed table." (string-pixel-width displayed)) (if last 0 spacer)))))) (when (and divider (not last)) - (insert divider)) + (insert (propertize divider 'keymap dmap))) (put-text-property start (point) 'vtable-column index))) (vtable-columns table)) (insert "\n") (add-face-text-property start (point) 'header-line))) -(defun vtable--drag-resize-column (e) - "Resize the column by dragging." +(defun vtable--drag-resize-column (e &optional next) + "Resize the column by dragging. +If NEXT, do the next column." (interactive "e") (let* ((pos-start (event-start e)) (obj (posn-object pos-start))) @@ -623,9 +630,11 @@ This also updates the displayed table." (car obj))) (start-x (car (posn-x-y pos-start))) (end-x (car (posn-x-y (event-end e))))) - (when (> column 0) + (when (or (> column 0) next) (vtable--alter-column-width (vtable-current-table) - (1- column) + (if next + column + (1- column)) (- end-x start-x))))))) (defun vtable--recompute-numerical (table line) -- cgit v1.2.3 From e95c545180a63cce49e8cdeff0d2660c2ddac9ec Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 15 Apr 2022 11:06:44 +0200 Subject: Fix off-by-one error in text-property-search-backward * lisp/emacs-lisp/text-property-search.el (text-property-search-backward): Fix off-by-one error -- this would result in not finding the previous (non-)match when at the first character in a field. --- lisp/emacs-lisp/text-property-search.el | 1 - 1 file changed, 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/text-property-search.el b/lisp/emacs-lisp/text-property-search.el index 9f86a28eb64..2494e948078 100644 --- a/lisp/emacs-lisp/text-property-search.el +++ b/lisp/emacs-lisp/text-property-search.el @@ -166,7 +166,6 @@ and if a matching region is found, place point at the start of the region." (let ((origin (point)) (ended nil) pos) - (forward-char -1) ;; Find the previous candidate. (while (not ended) (setq pos (previous-single-property-change (point) property)) -- cgit v1.2.3 From cc2a1b27806bff8431ebc8563ae5252267e3b178 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 15 Apr 2022 11:10:05 +0200 Subject: Allow dragging the divider in vtable * lisp/emacs-lisp/vtable.el (vtable): Add a keymap cache. (make-vtable): Allow dragging the divider. (vtable-insert): Don't put the table keymap over the entire line -- avoid the divider, which has its own keymap. (vtable--drag-resize-column): Adjust to the in-buffer divider dragging. --- lisp/emacs-lisp/vtable.el | 52 ++++++++++++++++++++++++++++++++--------------- 1 file changed, 36 insertions(+), 16 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index 9201fea3656..5b868440108 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -66,8 +66,9 @@ (ellipsis :initarg :ellipsis :accessor vtable-ellipsis) (column-colors :initarg :column-colors :accessor vtable-column-colors) (row-colors :initarg :row-colors :accessor vtable-row-colors) - (-cached-colors :initform nil :accessor vtable--cached-colors) - (-cache :initform (make-hash-table :test #'equal))) + (-cached-colors :initform nil) + (-cache :initform (make-hash-table :test #'equal)) + (-cached-keymap :initform nil)) "An object to hold the data for a table.") (defvar-keymap vtable-map @@ -146,16 +147,23 @@ See info node `(vtable)Top' for vtable documentation." (setf (vtable-columns table) (vtable--compute-columns table)) ;; Compute colors if we have to mix them. (when (and row-colors column-colors) - (setf (vtable--cached-colors table) + (setf (slot-value table '-cached-colors) (vtable--compute-colors row-colors column-colors))) ;; Compute the divider. (when (or divider divider-width) (setf (vtable-divider table) - (or divider - (propertize - " " 'display - (list 'space :width - (list (vtable--compute-width table divider-width))))))) + (propertize + (or (copy-sequence divider) + (propertize + " " 'display + (list 'space :width + (list (vtable--compute-width table divider-width))))) + 'keymap + (define-keymap + "" #'vtable--drag-resize-column + "" #'ignore)))) + ;; Compute the keymap. + (setf (slot-value table '-cached-keymap) (vtable--make-keymap table)) (unless sort-by (seq-do-indexed (lambda (column index) (when (vtable-column-primary column) @@ -424,8 +432,7 @@ This also updates the displayed table." ellipsis ellipsis-width) (setq line-number (1+ line-number)))) (add-text-properties start (point) - (list 'keymap (vtable--make-keymap table) - 'rear-nonsticky t + (list 'rear-nonsticky t 'vtable table)) (goto-char start))) @@ -435,10 +442,11 @@ This also updates the displayed table." (columns (vtable-columns table)) (column-colors (if (vtable-row-colors table) - (elt (vtable--cached-colors table) + (elt (slot-value table '-cached-colors) (mod line-number (length (vtable-row-colors table)))) (vtable-column-colors table))) - (divider (vtable-divider table))) + (divider (vtable-divider table)) + (keymap (slot-value table '-cached-keymap))) (seq-do-indexed (lambda (elem index) (let ((value (nth 0 elem)) @@ -505,6 +513,7 @@ This also updates the displayed table." (list 'space :width (list spacer)))))) (put-text-property start (point) 'vtable-column index) + (put-text-property start (point) 'keymap keymap) (when column-colors (add-face-text-property start (point) @@ -624,10 +633,21 @@ If NEXT, do the next column." (obj (posn-object pos-start))) (with-current-buffer (window-buffer (posn-window pos-start)) (let ((column - (get-text-property (if obj (cdr obj) - (posn-point pos-start)) - 'vtable-column - (car obj))) + ;; In the header line we have a text property on the + ;; divider. + (or (get-text-property (if obj (cdr obj) + (posn-point pos-start)) + 'vtable-column + (car obj)) + ;; For reasons of efficiency, we don't have that in + ;; the buffer itself, so find the column. + (save-excursion + (goto-char (posn-point pos-start)) + (1+ + (get-text-property + (prop-match-beginning + (text-property-search-backward 'vtable-column)) + 'vtable-column))))) (start-x (car (posn-x-y pos-start))) (end-x (car (posn-x-y (event-end e))))) (when (or (> column 0) next) -- cgit v1.2.3 From f36ff9da170abeada75d7c3d29ba420ffe7c02f4 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 15 Apr 2022 11:46:40 +0200 Subject: Allow using faces for colors in vtable * doc/misc/vtable.texi (Making A Table): Adjust color documentation. * lisp/emacs-lisp/vtable.el (make-vtable): Mix more. (vtable--compute-colors): Mix both foreground and background colors. (vtable--make-color-face, vtable--face-blend): New functions. (vtable--insert-line): Adjust usage. --- doc/misc/vtable.texi | 10 ++++---- lisp/emacs-lisp/vtable.el | 59 ++++++++++++++++++++++++++++++++++++----------- 2 files changed, 51 insertions(+), 18 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/misc/vtable.texi b/doc/misc/vtable.texi index 5a3957758c9..296dc520a1b 100644 --- a/doc/misc/vtable.texi +++ b/doc/misc/vtable.texi @@ -392,16 +392,18 @@ If present, this should be a list of color names to be used as the background color on the rows. If there are fewer colors here than there are rows, the rows will be repeated. The most common use case here is to have alternating background colors on the rows, so -this would usually be a list of two colors. +this would usually be a list of two colors. This can also be a list +of faces to be used. @item :column-colors If present, this should be a list of color names to be used as the background color on the columns. If there are fewer colors here than there are columns, the colors will be repeated. The most common use case here is to have alternating background colors on the columns, so -this would usually be a list of two colors. If both -@code{:row-colors} and @code{:column-colors} is present, the colors -will be ``blended'' to produce the final colors in the table. +this would usually be a list of two colors. This can also be a list +of faces to be used. If both @code{:row-colors} and +@code{:column-colors} is present, the colors will be ``blended'' to +produce the final colors in the table. @item :actions This uses the same syntax as @code{define-keymap}, but doesn't refer diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index 5b868440108..f2c20b6a806 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -145,8 +145,8 @@ See info node `(vtable)Top' for vtable documentation." :ellipsis ellipsis))) ;; Compute missing column data. (setf (vtable-columns table) (vtable--compute-columns table)) - ;; Compute colors if we have to mix them. - (when (and row-colors column-colors) + ;; Compute the colors. + (when (or row-colors column-colors) (setf (slot-value table '-cached-colors) (vtable--compute-colors row-colors column-colors))) ;; Compute the divider. @@ -175,9 +175,41 @@ See info node `(vtable)Top' for vtable documentation." table)) (defun vtable--compute-colors (row-colors column-colors) - (cl-loop for row in row-colors - collect (cl-loop for column in column-colors - collect (vtable--color-blend row column)))) + (cond + ((null column-colors) + (mapcar #'vtable--make-color-face row-colors)) + ((null row-colors) + (mapcar #'vtable--make-color-face column-colors)) + (t + (cl-loop for row in row-colors + collect (cl-loop for column in column-colors + collect (vtable--face-blend + (vtable--make-color-face row) + (vtable--make-color-face column))))))) + +(defun vtable--make-color-face (object) + (if (stringp object) + (list :background object) + object)) + +(defun vtable--face-blend (face1 face2) + (let ((foreground (vtable--face-color face1 face2 #'face-foreground + :foreground)) + (background (vtable--face-color face1 face2 #'face-background + :background))) + `(,@(and foreground (list :foreground foreground)) + ,@(and background (list :background background))))) + +(defun vtable--face-color (face1 face2 accessor slot) + (let ((col1 (if (facep face1) + (funcall accessor face1) + (plist-get face1 slot))) + (col2 (if (facep face2) + (funcall accessor face2) + (plist-get face2 slot)))) + (if (and col1 col2) + (vtable--color-blend col1 col2) + (or col1 col2)))) ;;; FIXME: This is probably not the right way to blend two colors, is ;;; it? @@ -441,10 +473,11 @@ This also updates the displayed table." (let ((start (point)) (columns (vtable-columns table)) (column-colors - (if (vtable-row-colors table) - (elt (slot-value table '-cached-colors) - (mod line-number (length (vtable-row-colors table)))) - (vtable-column-colors table))) + (and (vtable-column-colors table) + (if (vtable-row-colors table) + (elt (slot-value table '-cached-colors) + (mod line-number (length (vtable-row-colors table)))) + (slot-value table '-cached-colors)))) (divider (vtable-divider table)) (keymap (slot-value table '-cached-keymap))) (seq-do-indexed @@ -517,8 +550,7 @@ This also updates the displayed table." (when column-colors (add-face-text-property start (point) - (list :background - (elt column-colors (mod index (length column-colors)))))) + (elt column-colors (mod index (length column-colors))))) (when (and divider (not last)) (insert divider) (setq start (point)))))) @@ -526,11 +558,10 @@ This also updates the displayed table." (insert "\n") (put-text-property start (point) 'vtable-object (car line)) (unless column-colors - (when-let ((row-colors (vtable-row-colors table))) + (when-let ((row-colors (slot-value table '-cached-colors))) (add-face-text-property start (point) - (list :background - (elt row-colors (mod line-number (length row-colors))))))))) + (elt row-colors (mod line-number (length row-colors)))))))) (defun vtable--cache-key () (cons (frame-terminal) (window-width))) -- cgit v1.2.3 From c4768cda7f84a4368500685d1525fa93990e5aa0 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 15 Apr 2022 13:37:05 +0200 Subject: Make the sorting indicator prettier in vtable * lisp/emacs-lisp/vtable.el (vtable--insert-header-line): Place the sorting indicator flush right in the heading. --- lisp/emacs-lisp/vtable.el | 51 ++++++++++++++++++++++++++++++++++------------- 1 file changed, 37 insertions(+), 14 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index f2c20b6a806..ec7e4b4a6b9 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -635,20 +635,43 @@ This also updates the displayed table." (indicator-width (string-pixel-width indicator)) (last (= index (1- (length (vtable-columns table))))) displayed) - (insert - (setq displayed - (concat - (if (> (string-pixel-width name) - (- (elt widths index) indicator-width)) - (vtable--limit-string - name (- (elt widths index) indicator-width)) - name) - indicator)) - (propertize " " 'display - (list 'space :width - (list (+ (- (elt widths index) - (string-pixel-width displayed)) - (if last 0 spacer)))))) + (setq displayed + (if (> (string-pixel-width name) + (- (elt widths index) indicator-width)) + (vtable--limit-string + name (- (elt widths index) indicator-width)) + name)) + (let ((fill-width + (+ (- (elt widths index) + (string-pixel-width displayed) + indicator-width + (vtable-separator-width table)) + (if last 0 spacer)))) + (if (or (not last) + (zerop indicator-width) + (< (seq-reduce #'+ widths 0) (window-width nil t))) + ;; Normal case. + (insert + displayed + (propertize " " 'display + (list 'space :width (list fill-width))) + indicator) + ;; This is the final column, and we have a sorting + ;; indicator, and the table is too wide for the window. + (let* ((pre-indicator (string-pixel-width + (buffer-substring (point-min) (point)))) + (pre-fill + (- (window-width nil t) + pre-indicator + (string-pixel-width displayed)))) + (insert + displayed + (propertize " " 'display + (list 'space :width (list pre-fill))) + indicator + (propertize " " 'display + (list 'space :width + (list (- fill-width pre-fill)))))))) (when (and divider (not last)) (insert (propertize divider 'keymap dmap))) (put-text-property start (point) 'vtable-column index))) -- cgit v1.2.3 From 4bc36f09b9eb27a8c5e4c6fdc630d9476897c04b Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 15 Apr 2022 13:45:00 +0200 Subject: Tweak sorting indicator placement in vtable * lisp/emacs-lisp/vtable.el (vtable--insert-header-line): Tweak sorting indicator position. --- lisp/emacs-lisp/vtable.el | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index ec7e4b4a6b9..d620f237266 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -645,7 +645,10 @@ This also updates the displayed table." (+ (- (elt widths index) (string-pixel-width displayed) indicator-width - (vtable-separator-width table)) + (vtable-separator-width table) + ;; We want the indicator to not be quite flush + ;; right. + (/ (vtable--char-width table) 2.0)) (if last 0 spacer)))) (if (or (not last) (zerop indicator-width) @@ -674,6 +677,10 @@ This also updates the displayed table." (list (- fill-width pre-fill)))))))) (when (and divider (not last)) (insert (propertize divider 'keymap dmap))) + (insert (propertize + " " 'display + (list 'space :width (list + (/ (vtable--char-width table) 2.0))))) (put-text-property start (point) 'vtable-column index))) (vtable-columns table)) (insert "\n") -- cgit v1.2.3 From 68e6430959892dc755a80e05da2fedc530b5a924 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 15 Apr 2022 13:58:41 +0200 Subject: Add some mouse-face bits to vtable * lisp/emacs-lisp/vtable.el (make-vtable) (vtable--insert-header-line): Put mouse-face on draggable bits. --- lisp/emacs-lisp/vtable.el | 2 ++ 1 file changed, 2 insertions(+) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index d620f237266..525dc9359ff 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -158,6 +158,7 @@ See info node `(vtable)Top' for vtable documentation." " " 'display (list 'space :width (list (vtable--compute-width table divider-width))))) + 'mouse-face 'highlight 'keymap (define-keymap "" #'vtable--drag-resize-column @@ -629,6 +630,7 @@ This also updates the displayed table." (let* ((name (propertize (vtable-column-name column) 'face (list 'header-line (vtable-face table)) + 'mouse-face 'header-line-highlight 'keymap cmap)) (start (point)) (indicator (vtable--indicator table index)) -- cgit v1.2.3 From 2d4c5f0b8594c85a4877da3dd9527cab3066dd17 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 15 Apr 2022 14:06:26 +0200 Subject: Enable dragging resizing final column in vtable * lisp/emacs-lisp/vtable.el (vtable--insert-line): Insert the divider after the final column, too, so that the size can be dragged. --- lisp/emacs-lisp/vtable.el | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index 525dc9359ff..7148844b638 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -522,8 +522,7 @@ This also updates the displayed table." ellipsis) value)))) (start (point)) - ;; Don't insert the separator and the divider after the - ;; final column. + ;; Don't insert the separator after the final column. (last (= index (- (length line) 2)))) (if (eq (vtable-column-align column) 'left) (progn @@ -552,7 +551,7 @@ This also updates the displayed table." (add-face-text-property start (point) (elt column-colors (mod index (length column-colors))))) - (when (and divider (not last)) + (when divider (insert divider) (setq start (point)))))) (cdr line)) -- cgit v1.2.3 From 2b6a1c98dfba09d6922f1074047853366d26e31e Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Mon, 18 Apr 2022 10:19:54 +0000 Subject: Byte compiler: remove symbol positions from byte-switch tables This fixes bug #54990. * lisp/emacs-lisp/bytecomp.el (byte-compile-lapcode): Remove positions from symbols with positions in byte-switch tables, by temporarily removing the entries from the table, and reinserting them amended. --- lisp/emacs-lisp/bytecomp.el | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index c39d931517e..43648fa657b 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1009,13 +1009,22 @@ CONST2 may be evaluated multiple times." ;; 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)) + (let (alist) + (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). + ;; De-position any symbols with position in `value'. + ;; Since this may change the hash table key, we remove + ;; the entry from the table and reinsert it outside the + ;; scope of the `maphash'. + (setq value (byte-run-strip-symbol-positions value)) + (push (cons value pc) alist) + (remhash value hash-table)) + hash-table) + (dolist (elt alist) + (puthash (car elt) (cdr elt) hash-table)))) (let ((bytecode (apply 'unibyte-string (nreverse bytes)))) (when byte-native-compiling ;; Spill LAP for the native compiler here. -- cgit v1.2.3 From 850074636e73509b09c28e965c1af054a84f4069 Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Mon, 18 Apr 2022 15:16:54 +0000 Subject: Byte compiler: correct output warning message positions Correct the algorithm for determining the warning position to get the first symbol-with-position in byte-compile--form-stack. * lisp/emacs-lisp/bytecomp.el (byte-compile--first-symbol-with-pos): Function renamed and amended from byte-compile--first-symbol. (byte-compile--warning-source-offset): Call the new function above rather than the old one. --- lisp/emacs-lisp/bytecomp.el | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 43648fa657b..8128410916a 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1173,16 +1173,16 @@ message buffer `default-directory'." (f2 (file-relative-name file dir))) (if (< (length f2) (length f1)) f2 f1))) -(defun byte-compile--first-symbol (form) - "Return the \"first\" symbol found in form, or 0 if there is none. +(defun byte-compile--first-symbol-with-pos (form) + "Return the \"first\" symbol with position found in form, or 0 if none. Here, \"first\" is by a depth first search." (let (sym) (cond - ((symbolp form) form) + ((symbol-with-pos-p form) form) ((consp form) - (or (and (symbolp (setq sym (byte-compile--first-symbol (car form)))) + (or (and (symbol-with-pos-p (setq sym (byte-compile--first-symbol-with-pos (car form)))) sym) - (and (symbolp (setq sym (byte-compile--first-symbol (cdr form)))) + (and (symbolp (setq sym (byte-compile--first-symbol-with-pos (cdr form)))) sym) 0)) ((and (vectorp form) @@ -1193,7 +1193,7 @@ Here, \"first\" is by a depth first search." (catch 'sym (while (< i len) (when (symbolp - (setq elt (byte-compile--first-symbol (aref form i)))) + (setq elt (byte-compile--first-symbol-with-pos (aref form i)))) (throw 'sym elt)) (setq i (1+ i))) 0))) @@ -1204,7 +1204,7 @@ Here, \"first\" is by a depth first search." Return nil if such is not found." (catch 'offset (dolist (form byte-compile-form-stack) - (let ((s (byte-compile--first-symbol form))) + (let ((s (byte-compile--first-symbol-with-pos form))) (if (symbol-with-pos-p s) (throw 'offset (symbol-with-pos-pos s))))))) -- cgit v1.2.3 From 935f400a33d6ff0f5d61fc7ade688a4378613882 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 21 Apr 2022 15:11:25 +0200 Subject: Clarify cl-incf/decf doc strings * lisp/emacs-lisp/cl-lib.el (cl-incf): (cl-decf): Clarify that nil isn't a valid value for X (bug#31715). --- lisp/emacs-lisp/cl-lib.el | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 4e60a3c63d0..3f40ab07605 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -114,7 +114,10 @@ a future Emacs interpreter will be able to use it.") (defmacro cl-incf (place &optional x) "Increment PLACE by X (1 by default). PLACE may be a symbol, or any generalized variable allowed by `setf'. -The return value is the incremented value of PLACE." +The return value is the incremented value of PLACE. + +If X is specified, it should be an expression that should +evaluate to a number." (declare (debug (place &optional form))) (if (symbolp place) (list 'setq place (if x (list '+ place x) (list '1+ place))) @@ -123,7 +126,10 @@ The return value is the incremented value of PLACE." (defmacro cl-decf (place &optional x) "Decrement PLACE by X (1 by default). PLACE may be a symbol, or any generalized variable allowed by `setf'. -The return value is the decremented value of PLACE." +The return value is the decremented value of PLACE. + +If X is specified, it should be an expression that should +evaluate to a number." (declare (debug cl-incf)) (if (symbolp place) (list 'setq place (if x (list '- place x) (list '1- place))) -- cgit v1.2.3 From 16dfec3c4ccafb2ec7b9a428fb2730ca8f0202fd Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 22 Apr 2022 15:17:15 +0200 Subject: Fix map-into doc string example * lisp/emacs-lisp/map.el (map-into): Fix quote quoting in example. --- lisp/emacs-lisp/map.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index dea5b34991a..c53f253f87f 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -540,7 +540,7 @@ TYPE is a list whose car is `hash-table' and cdr a list of keyword-args forwarded to `make-hash-table'. Example: - (map-into '((1 . 3)) '(hash-table :test eql))" + (map-into \\='((1 . 3)) \\='(hash-table :test eql))" (map--into-hash map (cdr type))) (defun map--make-pcase-bindings (args) -- cgit v1.2.3 From bbf389ea6deab229ba18dc519fe712ec982609d1 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 22 Apr 2022 16:17:22 +0200 Subject: Audit quoting the quote character in doc strings * test/src/regex-emacs-tests.el (regex-tests-compare): (regex-tests-compare): (regex-tests-match): * test/lisp/xml-tests.el (xml-parse-tests--qnames): * test/lisp/mh-e/mh-thread-tests.el (mh-thread-tests-before-from): * test/lisp/cedet/srecode-utest-template.el (srecode-utest-map-reset): * test/lisp/calc/calc-tests.el (calc-tests-equal): * lisp/window.el (get-lru-window): (get-mru-window): (get-largest-window): (quit-restore-window): (display-buffer): * lisp/vc/vc-rcs.el (vc-rcs-consult-headers): * lisp/url/url-auth.el (url-digest-auth-build-response): * lisp/tutorial.el (tutorial--find-changed-keys): * lisp/transient.el (transient-suffix-object): * lisp/textmodes/rst.el (rst-insert-list-new-item): * lisp/textmodes/bibtex.el (bibtex-clean-entry): * lisp/tab-bar.el (tab-bar--key-to-number): (toggle-frame-tab-bar): * lisp/ses.el (ses-recalculate-cell): (ses-define-local-printer): (ses-prin1): * lisp/progmodes/xref.el (xref--find-ignores-arguments): * lisp/progmodes/verilog-mode.el (verilog-single-declaration-end): * lisp/progmodes/tcl.el (tcl-mode-hook): * lisp/progmodes/gdb-mi.el (gdb-get-buffer-create): * lisp/progmodes/elisp-mode.el (elisp--xref-make-xref): * lisp/play/dunnet.el (dun-room-objects): * lisp/outline.el (outline--cycle-state): * lisp/org/ox-publish.el (org-publish-find-property): * lisp/org/ox-html.el (org-html--unlabel-latex-environment): * lisp/org/org-table.el (org-table-collapse-header): * lisp/org/org-plot.el (org--plot/prime-factors): * lisp/org/org-agenda.el (org-agenda--mark-blocked-entry): (org-agenda-set-restriction-lock): * lisp/org/ob-lua.el (org-babel-lua-read-string): * lisp/org/ob-julia.el (org-babel-julia-evaluate-external-process): (org-babel-julia-evaluate-session): * lisp/org/ob-core.el (org-babel-default-header-args): * lisp/obsolete/mouse-sel.el (mouse-select): (mouse-select-secondary): * lisp/net/tramp.el (tramp-methods): * lisp/net/eww.el (eww-accept-content-types): * lisp/net/dictionary-connection.el (dictionary-connection-status): * lisp/minibuffer.el (completion-flex--make-flex-pattern): * lisp/mh-e/mh-mime.el (mh-have-file-command): * lisp/mh-e/mh-limit.el (mh-subject-to-sequence): (mh-subject-to-sequence-threaded): (mh-subject-to-sequence-unthreaded): * lisp/mail/feedmail.el (feedmail-queue-buffer-file-name): (feedmail-vm-mail-mode): * lisp/ls-lisp.el (ls-lisp--sanitize-switches): * lisp/keymap.el (key-valid-p): * lisp/international/ccl.el (ccl-compile-branch-blocks): * lisp/image/image-converter.el (image-convert): * lisp/gnus/spam.el (spam-backend-check): * lisp/gnus/nnselect.el (nnselect-generate-artlist): * lisp/gnus/nnmairix.el (nnmairix-widget-other): * lisp/gnus/message.el (message-mailto): * lisp/gnus/gnus-sum.el (gnus-collect-urls-from-article): * lisp/gnus/gnus-search.el (gnus-search-prepare-query): * lisp/frame.el (frame-size-history): * lisp/eshell/esh-var.el (eshell-parse-variable-ref): * lisp/eshell/em-dirs.el (eshell-expand-multiple-dots): * lisp/erc/erc-backend.el (erc-bounds-of-word-at-point): * lisp/emulation/cua-rect.el (cua--rectangle-operation): * lisp/emacs-lisp/text-property-search.el (text-property-search-forward): * lisp/emacs-lisp/package.el (package-desc-suffix): * lisp/emacs-lisp/faceup.el (faceup-test-explain): * lisp/emacs-lisp/comp.el (comp-curr-allocation-class): (comp-alloc-class-to-container): (comp-add-cstrs): (comp-remove-type-hints-func): (batch-byte+native-compile): * lisp/emacs-lisp/cl-macs.el (cl--optimize): * lisp/elec-pair.el (electric-pair--syntax-ppss): * lisp/doc-view.el (doc-view-doc-type): * lisp/cedet/semantic/symref.el (semantic-symref-tool-alist): (semantic-symref-hit-to-tag-via-db): (semantic-symref-hit-to-tag-via-buffer): * lisp/cedet/semantic/lex-spp.el (semantic-lex-spp-get-overlay): * lisp/cedet/semantic/java.el (semantic-java-doc-keywords-map): * lisp/cedet/semantic/find.el (semantic-brute-find-tag-by-function): * lisp/cedet/semantic/db.el (semanticdb-project-predicate-functions): * lisp/cedet/semantic.el (semantic-working-type): * lisp/cedet/ede/files.el (ede-flush-directory-hash): * lisp/calc/calc.el (calc--header-line): * lisp/auth-source.el (auth-source-pick-first-password): (auth-source--decode-octal-string): * etc/themes/modus-themes.el (modus-themes--paren): (modus-themes--agenda-habit): * admin/cus-test.el (cus-test-vars-with-changed-state): Fix quoting in doc strings. In code examples, the ' character is quoted with \\=, and regularize 'foo to `foo', and quote strings like "foo" instead of 'foo'. --- admin/cus-test.el | 2 +- etc/themes/modus-themes.el | 8 ++++---- lisp/auth-source.el | 4 ++-- lisp/calc/calc.el | 2 +- lisp/cedet/ede/files.el | 2 +- lisp/cedet/semantic.el | 4 ++-- lisp/cedet/semantic/db.el | 2 +- lisp/cedet/semantic/find.el | 2 +- lisp/cedet/semantic/java.el | 2 +- lisp/cedet/semantic/lex-spp.el | 2 +- lisp/cedet/semantic/symref.el | 6 +++--- lisp/doc-view.el | 4 ++-- lisp/elec-pair.el | 2 +- lisp/emacs-lisp/cl-macs.el | 2 +- lisp/emacs-lisp/comp.el | 12 ++++++------ lisp/emacs-lisp/faceup.el | 2 +- lisp/emacs-lisp/package.el | 6 +++--- lisp/emacs-lisp/text-property-search.el | 2 +- lisp/emulation/cua-rect.el | 2 +- lisp/erc/erc-backend.el | 2 +- lisp/eshell/em-dirs.el | 2 +- lisp/eshell/esh-var.el | 2 +- lisp/frame.el | 2 +- lisp/gnus/gnus-search.el | 4 ++-- lisp/gnus/gnus-sum.el | 2 +- lisp/gnus/message.el | 2 +- lisp/gnus/nnmairix.el | 2 +- lisp/gnus/nnselect.el | 4 ++-- lisp/gnus/spam.el | 2 +- lisp/image/image-converter.el | 2 +- lisp/international/ccl.el | 2 +- lisp/keymap.el | 8 ++++---- lisp/ls-lisp.el | 2 +- lisp/mail/feedmail.el | 4 ++-- lisp/mh-e/mh-limit.el | 6 +++--- lisp/mh-e/mh-mime.el | 2 +- lisp/minibuffer.el | 2 +- lisp/net/dictionary-connection.el | 8 ++++---- lisp/net/eww.el | 2 +- lisp/net/tramp.el | 2 +- lisp/obsolete/mouse-sel.el | 4 ++-- lisp/org/ob-core.el | 2 +- lisp/org/ob-julia.el | 8 ++++---- lisp/org/ob-lua.el | 2 +- lisp/org/org-agenda.el | 4 ++-- lisp/org/org-plot.el | 2 +- lisp/org/org-table.el | 2 +- lisp/org/ox-html.el | 2 +- lisp/org/ox-publish.el | 2 +- lisp/outline.el | 2 +- lisp/play/dunnet.el | 2 +- lisp/progmodes/elisp-mode.el | 2 +- lisp/progmodes/gdb-mi.el | 2 +- lisp/progmodes/tcl.el | 2 +- lisp/progmodes/verilog-mode.el | 8 ++++---- lisp/progmodes/xref.el | 2 +- lisp/ses.el | 12 ++++++------ lisp/tab-bar.el | 4 ++-- lisp/textmodes/bibtex.el | 2 +- lisp/textmodes/rst.el | 2 +- lisp/transient.el | 2 +- lisp/tutorial.el | 2 +- lisp/url/url-auth.el | 4 ++-- lisp/vc/vc-rcs.el | 6 +++--- lisp/window.el | 16 ++++++++-------- test/lisp/calc/calc-tests.el | 2 +- test/lisp/cedet/srecode-utest-template.el | 2 +- test/lisp/mh-e/mh-thread-tests.el | 2 +- test/lisp/xml-tests.el | 2 +- test/src/regex-emacs-tests.el | 12 ++++++------ 70 files changed, 125 insertions(+), 125 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/admin/cus-test.el b/admin/cus-test.el index 8f0914ff691..5894abed3df 100644 --- a/admin/cus-test.el +++ b/admin/cus-test.el @@ -156,7 +156,7 @@ Names should be as they appear in loaddefs.el.") "Set by `cus-test-apropos' to a list of options with :get property.") (defvar cus-test-vars-with-changed-state nil - "Set by `cus-test-apropos' to a list of options with state 'changed.") + "Set by `cus-test-apropos' to a list of options with state \\='changed.") (defvar cus-test-deps-errors nil "List of require/load problems found by `cus-test-deps'.") diff --git a/etc/themes/modus-themes.el b/etc/themes/modus-themes.el index adec113bd21..1c522239508 100644 --- a/etc/themes/modus-themes.el +++ b/etc/themes/modus-themes.el @@ -3368,10 +3368,10 @@ theme's fallback text color." (defun modus-themes--paren (normalbg intensebg) "Conditional use of intense colors for matching parentheses. -NORMALBG should be the special palette color 'bg-paren-match' or +NORMALBG should be the special palette color `bg-paren-match' or something similar. INTENSEBG must be easier to discern next to other backgrounds, such as the special palette color -'bg-paren-match-intense'." +`bg-paren-match-intense'." (let ((properties (modus-themes--list-or-warn 'modus-themes-paren-match))) (list :inherit (if (memq 'bold properties) @@ -3637,8 +3637,8 @@ clearly distinguishes past, present, future tasks." (defun modus-themes--agenda-habit (default traffic simple &optional default-d traffic-d simple-d) "Specify background values for `modus-themes-org-agenda' habits. DEFAULT is the original foregrounc color. TRAFFIC is to be used -when the 'traffic-light' style is applied, while SIMPLE -corresponds to the 'simplified style'. +when the `traffic-light' style is applied, while SIMPLE +corresponds to the \"simplified style\". Optional DEFAULT-D, TRAFFIC-D, SIMPLE-D are alternatives to the main colors, meant for dopia when `modus-themes-deuteranopia' is diff --git a/lisp/auth-source.el b/lisp/auth-source.el index cd135bd2e2c..fc62e36dfc2 100644 --- a/lisp/auth-source.el +++ b/lisp/auth-source.el @@ -867,7 +867,7 @@ while \(:host t) would find all host entries." secret))) (defun auth-source-pick-first-password (&rest spec) - "Pick the first secret found by applying 'auth-source-search' to SPEC." + "Pick the first secret found by applying `auth-source-search' to SPEC." (auth-info-password (car (apply #'auth-source-search (plist-put spec :max 1))))) (defun auth-source-format-prompt (prompt alist) @@ -1958,7 +1958,7 @@ entries for git.gnus.org: (defun auth-source--decode-octal-string (string) - "Convert octal STRING to utf-8 string. E.g: 'a\134b' to 'a\b'." + "Convert octal STRING to utf-8 string. E.g: \"a\134b\" to \"a\b\"." (let ((list (string-to-list string)) (size (length string))) (decode-coding-string diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index 2c139a02385..523f51533a1 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -1375,7 +1375,7 @@ Notations: 3.14e6 3.14 * 10^6 LONG is a desired text for a wide window, SHORT is a desired abbreviated text, and width is the buffer width, which will be -some fraction of the 'parent' window width (At the time of +some fraction of the \"parent\" window width (At the time of writing, 2/3 for calc, 1/3 for trail). The optional FUDGE is a trial-and-error adjustment number for the edge-cases at the border of the two cases." diff --git a/lisp/cedet/ede/files.el b/lisp/cedet/ede/files.el index 3b9002a6e31..b8acb192c17 100644 --- a/lisp/cedet/ede/files.el +++ b/lisp/cedet/ede/files.el @@ -257,7 +257,7 @@ If optional EXACT is non-nil, only return exact matches for DIR." (defun ede-flush-directory-hash () "Flush the project directory hash. Do this only when developing new projects that are incorrectly putting -'nomatch tokens into the hash." +`nomatch' tokens into the hash." (interactive) (setq ede-project-directory-hash (make-hash-table :test 'equal)) ;; Also slush the current project's locator hash. diff --git a/lisp/cedet/semantic.el b/lisp/cedet/semantic.el index dc6751db6cf..78002dd8abc 100644 --- a/lisp/cedet/semantic.el +++ b/lisp/cedet/semantic.el @@ -497,8 +497,8 @@ is requested." (defvar semantic-working-type 'percent "The type of working message to use when parsing. -'percent means we are doing a linear parse through the buffer. -'dynamic means we are reparsing specific tags.") +`percent' means we are doing a linear parse through the buffer. +`dynamic' means we are reparsing specific tags.") (defvar semantic-minimum-working-buffer-size (* 1024 5) "The minimum size of a buffer before working messages are displayed. diff --git a/lisp/cedet/semantic/db.el b/lisp/cedet/semantic/db.el index 7f25a848918..82785ec6d2e 100644 --- a/lisp/cedet/semantic/db.el +++ b/lisp/cedet/semantic/db.el @@ -729,7 +729,7 @@ Exit the save between databases if there is user input." (defvar semanticdb-project-predicate-functions nil "List of predicates to try that indicate a directory belongs to a project. This list is used when `semanticdb-persistent-path' contains the value -'project. If the predicate list is nil, then presume all paths are valid. +`project'. If the predicate list is nil, then presume all paths are valid. Project Management software (such as EDE and JDE) should add their own predicates with `add-hook' to this variable, and semanticdb will save tag diff --git a/lisp/cedet/semantic/find.el b/lisp/cedet/semantic/find.el index e894022315f..92644ce0066 100644 --- a/lisp/cedet/semantic/find.el +++ b/lisp/cedet/semantic/find.el @@ -591,7 +591,7 @@ in the new list. If optional argument SEARCH-PARTS is non-nil, all sub-parts of tags are searched. The overloadable function `semantic-tag-components' is used for the searching child lists. If SEARCH-PARTS is the symbol -'positiononly, then only children that have positional information are +`positiononly', then only children that have positional information are searched. If SEARCH-INCLUDES has not been implemented. diff --git a/lisp/cedet/semantic/java.el b/lisp/cedet/semantic/java.el index a7c02032e22..9b70afd0a33 100644 --- a/lisp/cedet/semantic/java.el +++ b/lisp/cedet/semantic/java.el @@ -391,7 +391,7 @@ That is TAG `symbol-name' without the leading `@'." Return the list of FUN results. If optional PROPERTY is non-nil only call FUN for javadoc keywords which have a value for PROPERTY. FUN receives two arguments: the javadoc keyword and its associated -'javadoc property list. It can return any value. All nil values are +`javadoc' property list. It can return any value. All nil values are removed from the result list." (delq nil (mapcar diff --git a/lisp/cedet/semantic/lex-spp.el b/lisp/cedet/semantic/lex-spp.el index 26a3b39f0d6..57e59f4e9fe 100644 --- a/lisp/cedet/semantic/lex-spp.el +++ b/lisp/cedet/semantic/lex-spp.el @@ -726,7 +726,7 @@ Returns position with the end of that macro." (point)))))) (defun semantic-lex-spp-get-overlay (&optional point) - "Return first overlay which has a 'semantic-spp property." + "Return first overlay which has a `semantic-spp' property." (let ((overlays (overlays-at (or point (point))))) (while (and overlays (null (overlay-get (car overlays) 'semantic-spp))) diff --git a/lisp/cedet/semantic/symref.el b/lisp/cedet/semantic/symref.el index ba236059f66..e48cefa4ca6 100644 --- a/lisp/cedet/semantic/symref.el +++ b/lisp/cedet/semantic/symref.el @@ -101,7 +101,7 @@ Where PREDICATE is a function that takes a directory name for the root of a project, and returns non-nil if the tool represented by KEY is supported. -If no tools are supported, then 'grep is assumed.") +If no tools are supported, then `grep' is assumed.") (defun semantic-symref-calculate-rootdir () "Calculate the root directory for a symref search. @@ -475,7 +475,7 @@ already." Return the Semantic tag associated with HIT. SEARCHTXT is the text that is being searched for. Used to narrow the in-buffer search. -SEARCHTYPE is the type of search (such as 'symbol or 'tagname). +SEARCHTYPE is the type of search (such as `symbol' or `tagname'). If there is no database, or if the searchtype is wrong, return nil." ;; Allowed search types for this mechanism: ;; tagname, tagregexp, tagcompletions @@ -506,7 +506,7 @@ If there is no database, or if the searchtype is wrong, return nil." Return the Semantic tag associated with HIT. SEARCHTXT is the text that is being searched for. Used to narrow the in-buffer search. -SEARCHTYPE is the type of search (such as 'symbol or 'tagname). +SEARCHTYPE is the type of search (such as `symbol' or `tagname'). Optional OPEN-BUFFERS, when nil will use a faster version of `find-file' when a file needs to be opened. If non-nil, then normal buffer initialization will be used. diff --git a/lisp/doc-view.el b/lisp/doc-view.el index 10adc9fcc9b..e8698fad7e7 100644 --- a/lisp/doc-view.el +++ b/lisp/doc-view.el @@ -234,8 +234,8 @@ Higher values result in larger images." (defvar doc-view-doc-type nil "The type of document in the current buffer. -Can be `dvi', `pdf', `ps', `djvu', `odf', 'epub', `cbz', `fb2', -`'xps' or `oxps'.") +Can be `dvi', `pdf', `ps', `djvu', `odf', `epub', `cbz', `fb2', +`xps' or `oxps'.") ;; FIXME: The doc-view-current-* definitions below are macros because they ;; map to accessors which we want to use via `setf' as well! diff --git a/lisp/elec-pair.el b/lisp/elec-pair.el index c3fd90e5bfd..231dcdeb980 100644 --- a/lisp/elec-pair.el +++ b/lisp/elec-pair.el @@ -256,7 +256,7 @@ cache is flushed from position START, defaulting to point." (defun electric-pair--syntax-ppss (&optional pos where) "Like `syntax-ppss', but sometimes fallback to `parse-partial-sexp'. -WHERE is a list defaulting to '(string comment) and indicates +WHERE is a list defaulting to \\='(string comment) and indicates when to fallback to `parse-partial-sexp'." (let* ((pos (or pos (point))) (where (or where '(string comment))) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 364b5120a0a..c2f8c4d009c 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2560,7 +2560,7 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). (push x defun-declarations-alist))) (defun cl--optimize (f _args &rest qualities) - "Serve 'cl-optimize' in function declarations. + "Serve `cl-optimize' in function declarations. Example: (defun foo (x) (declare (cl-optimize (speed 3) (safety 0))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 00efedd71f3..237de52884b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -238,7 +238,7 @@ native compilation runs.") (defvar comp-curr-allocation-class 'd-default "Current allocation class. -Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") +Can be one of: `d-default', `d-impure' or `d-ephemeral'. See `comp-ctxt'.") (defconst comp-passes '(comp-spill-lap comp-limplify @@ -1023,7 +1023,7 @@ To be used by all entry points." (defun comp-alloc-class-to-container (alloc-class) "Given ALLOC-CLASS, return the data container for the current context. -Assume allocation class 'd-default as default." +Assume allocation class `d-default' as default." (cl-struct-slot-value 'comp-ctxt (or alloc-class 'd-default) comp-ctxt)) (defsubst comp-add-const-to-relocs (obj) @@ -2633,8 +2633,8 @@ TARGET-BB-SYM is the symbol name of the target block." do (comp-emit-call-cstr target insn-cell cstr))))))) (defun comp-add-cstrs (_) - "Rewrite conditional branches adding appropriate 'assume' insns. -This is introducing and placing 'assume' insns in use by fwprop + "Rewrite conditional branches adding appropriate `assume' insns. +This is introducing and placing `assume' insns in use by fwprop to propagate conditional branch test information on target basic blocks." (maphash (lambda (_ f) @@ -3482,7 +3482,7 @@ Return the list of m-var ids nuked." (defun comp-remove-type-hints-func () "Remove type hints from the current function. -These are substituted with a normal 'set' op." +These are substituted with a normal `set' op." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (comp-loop-insn-in-block b @@ -4217,7 +4217,7 @@ Generate .elc files in addition to the .eln files. Force the produced .eln to be outputted in the eln system directory (the last entry in `native-comp-eln-load-path') unless `native-compile-target-directory' is non-nil. If the environment -variable 'NATIVE_DISABLED' is set, only byte compile." +variable \"NATIVE_DISABLED\" is set, only byte compile." (comp-ensure-native-compiler) (if (equal (getenv "NATIVE_DISABLED") "1") (batch-byte-compile) diff --git a/lisp/emacs-lisp/faceup.el b/lisp/emacs-lisp/faceup.el index 77689f434c2..b44132dcead 100644 --- a/lisp/emacs-lisp/faceup.el +++ b/lisp/emacs-lisp/faceup.el @@ -1006,7 +1006,7 @@ which could be defined as: (defun my-test-explain (args...) (let ((faceup-test-explain t)) (the-test args...))) - (put 'my-test 'ert-explainer 'my-test-explain) + (put \\='my-test \\='ert-explainer \\='my-test-explain) Alternative, you can use the macro `faceup-defexplainer' as follows: diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index f6aad64d358..7f2c427c2ee 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -566,9 +566,9 @@ This is the name of the package with its version appended." "Return file-name extension of package-desc object PKG-DESC. Depending on the `package-desc-kind' of PKG-DESC, this is one of: - 'single - \".el\" - 'tar - \".tar\" - 'dir - \"\" + \\='single - \".el\" + \\='tar - \".tar\" + \\='dir - \"\" Signal an error if the kind is none of the above." (pcase (package-desc-kind pkg-desc) diff --git a/lisp/emacs-lisp/text-property-search.el b/lisp/emacs-lisp/text-property-search.el index 2494e948078..d11980f4f45 100644 --- a/lisp/emacs-lisp/text-property-search.el +++ b/lisp/emacs-lisp/text-property-search.el @@ -47,7 +47,7 @@ match if is not `equal' to VALUE. Furthermore, a nil PREDICATE means that the match region is ended if the value changes. For instance, this means that if you loop with - (while (setq prop (text-property-search-forward 'face)) + (while (setq prop (text-property-search-forward \\='face)) ...) you will get all distinct regions with non-nil `face' values in diff --git a/lisp/emulation/cua-rect.el b/lisp/emulation/cua-rect.el index e399fd0fbf3..a7f3d5fe14c 100644 --- a/lisp/emulation/cua-rect.el +++ b/lisp/emulation/cua-rect.el @@ -572,7 +572,7 @@ Only call fct for visible lines if VISIBLE==t. Set undo boundary if UNDO is non-nil. Rectangle is padded if PAD = t or numeric and (cua--rectangle-virtual-edges) Perform auto-tabify after operation if TABIFY is non-nil. -Mark is kept if keep-clear is 'keep and cleared if keep-clear is 'clear." +Mark is kept if keep-clear is `keep' and cleared if keep-clear is `clear'." (declare (indent 4)) (let* ((inhibit-field-text-motion t) (start (cua--rectangle-top)) diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 398fe6cc9e7..4b21711da42 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -464,7 +464,7 @@ If POS is out of range, the value is nil." (defun erc-bounds-of-word-at-point () "Return the bounds of word at point, or nil if we're not at a word. If no `subword-mode' is active, then this is -\(bounds-of-thing-at-point 'word)." +\(bounds-of-thing-at-point \\='word)." (if (or (erc-word-at-arg-p (point)) (erc-word-at-arg-p (1- (point)))) (save-excursion diff --git a/lisp/eshell/em-dirs.el b/lisp/eshell/em-dirs.el index 3998026d7f4..5396044d8ca 100644 --- a/lisp/eshell/em-dirs.el +++ b/lisp/eshell/em-dirs.el @@ -313,7 +313,7 @@ With the following piece of advice, you can make this functionality available in most of Emacs, with the exception of filename completion in the minibuffer: - (advice-add 'expand-file-name :around #'my-expand-multiple-dots) + (advice-add \\='expand-file-name :around #\\='my-expand-multiple-dots) (defun my-expand-multiple-dots (orig-fun filename &rest args) (apply orig-fun (eshell-expand-multiple-dots filename) args))" (while (string-match "\\(?:\\`\\|/\\)\\.\\.\\(\\.+\\)\\(?:\\'\\|/\\)" diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el index ca4cbd744c1..3c6bcc753c2 100644 --- a/lisp/eshell/esh-var.el +++ b/lisp/eshell/esh-var.el @@ -422,7 +422,7 @@ Possible options are: NAME an environment or Lisp variable value \"LONG-NAME\" disambiguates the length of the name - 'LONG-NAME' as above + `LONG-NAME' as above {COMMAND} result of command is variable's value (LISP-FORM) result of Lisp form is variable's value write the output of command to a temporary file; diff --git a/lisp/frame.el b/lisp/frame.el index 7b19b8b5d32..83e67dac4e5 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -1727,7 +1727,7 @@ to the selected frame. Storing information about resize operations is off by default. If you set the variable `frame-size-history' like this -(setq frame-size-history '(100)) +(setq frame-size-history \\='(100)) then Emacs will save information about the next 100 significant operations affecting any frame's size in that variable. This diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el index 6c70257f42f..17724c3a514 100644 --- a/lisp/gnus/gnus-search.el +++ b/lisp/gnus/gnus-search.el @@ -2125,9 +2125,9 @@ Assume \"size\" key is equal to \"larger\"." (defun gnus-search-prepare-query (query-spec) "Accept a search query in raw format, and prepare it. QUERY-SPEC is an alist produced by functions such as -`gnus-group-make-search-group', and contains at least a 'query +`gnus-group-make-search-group', and contains at least a `query' key, and possibly some meta keys. This function extracts any -additional meta keys from the 'query string, and parses the +additional meta keys from the `query' string, and parses the remaining string, then adds all that to the top-level spec." (let ((query (alist-get 'query query-spec)) val) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 62efacfd6e2..d2221eb41c8 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -9447,7 +9447,7 @@ The 1st element is the button named by `gnus-collect-urls-primary-text'." (defun gnus-collect-urls-from-article () "Select the article and return the list of URLs in it. -See 'gnus-collect-urls'." +See `gnus-collect-urls'." (gnus-summary-select-article) (gnus-with-article-buffer (article-goto-body) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 30734b8f1ad..cc994d3ba59 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -9008,7 +9008,7 @@ used to take the screenshot." This is meant to be used for MIME handlers: Setting the handler for \"x-scheme-handler/mailto;\" to \"emacs -f message-mailto %u\" will then start up Emacs ready to compose mail. For emacsclient use - emacsclient -e '(message-mailto \"%u\")'" + emacsclient -e \\='(message-mailto \"%u\")'" (interactive) ;; Send email (message-mail) diff --git a/lisp/gnus/nnmairix.el b/lisp/gnus/nnmairix.el index 4e8e329f983..8c811b0c6c0 100644 --- a/lisp/gnus/nnmairix.el +++ b/lisp/gnus/nnmairix.el @@ -333,7 +333,7 @@ this might lead to problems, especially when used with marks propagation." (defvar nnmairix-widget-other '(threads flags) "Other editable mairix commands when using customization widgets. -Currently there are 'threads and 'flags.") +Currently there are `threads' and `flags'.") (defvar nnmairix-interactive-query-parameters '((?f "from" "f" "From") (?t "to" "t" "To") (?c "to" "tc" "To or Cc") diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el index 89ddd608979..cdbfa0b5910 100644 --- a/lisp/gnus/nnselect.el +++ b/lisp/gnus/nnselect.el @@ -269,8 +269,8 @@ If this variable is nil, or if the provided function returns nil, (defun nnselect-generate-artlist (group &optional specs) "Generate the artlist for GROUP using SPECS. -SPECS should be an alist including an 'nnselect-function and an -'nnselect-args. The former applied to the latter should create +SPECS should be an alist including an `nnselect-function' and an +`nnselect-args'. The former applied to the latter should create the artlist. If SPECS is nil retrieve the specs from the group parameters." (let* ((specs diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el index 297576288bb..5af29c0a246 100644 --- a/lisp/gnus/spam.el +++ b/lisp/gnus/spam.el @@ -852,7 +852,7 @@ The value nil means that the check does not yield a decision, and so, that further checks are needed. The value t means that the message is definitely not spam, and that further spam checks should be inhibited. Otherwise, a mailgroup name or the symbol -'spam (depending on `spam-split-symbolic-return') is returned where +`spam' (depending on `spam-split-symbolic-return') is returned where the mail should go, and further checks are also inhibited. The usual mailgroup name is the value of `spam-split-group', meaning that the message is definitely a spam." diff --git a/lisp/image/image-converter.el b/lisp/image/image-converter.el index a339e95ab4a..7914d28c293 100644 --- a/lisp/image/image-converter.el +++ b/lisp/image/image-converter.el @@ -109,7 +109,7 @@ To pass in image data, IMAGE should a string containing the image data, and IMAGE-FORMAT should be a symbol with a MIME format name like \"image/webp\". For instance: - (image-convert data-string 'image/bmp) + (image-convert data-string \\='image/bmp) IMAGE can also be an image object as returned by `create-image'. diff --git a/lisp/international/ccl.el b/lisp/international/ccl.el index 9188e3d6ae4..c7d883276db 100644 --- a/lisp/international/ccl.el +++ b/lisp/international/ccl.el @@ -577,7 +577,7 @@ Return register which holds a value of the expression." (ccl-check-register expr cmd))) (defun ccl-compile-branch-blocks (code rrr blocks) - "Compile BLOCKs of BRANCH statement. CODE is 'branch or 'read-branch. + "Compile BLOCKs of BRANCH statement. CODE is `branch' or `read-branch'. REG is a register which holds a value of EXPRESSION part. BLOCKs is a list of CCL-BLOCKs." (let ((branches (length blocks)) diff --git a/lisp/keymap.el b/lisp/keymap.el index c0fdf8721b2..db37d80b363 100644 --- a/lisp/keymap.el +++ b/lisp/keymap.el @@ -306,10 +306,10 @@ number of characters have a special shorthand syntax. Here's some example key sequences. - \"f\" (the key 'f') - \"S o m\" (a three key sequence of the keys 'S', 'o' and 'm') - \"C-c o\" (a two key sequence of the keys 'c' with the control modifier - and then the key 'o') + \"f\" (the key `f') + \"S o m\" (a three key sequence of the keys `S', `o' and `m') + \"C-c o\" (a two key sequence of the keys `c' with the control modifier + and then the key `o') \"H-\" (the key named \"left\" with the hyper modifier) \"M-RET\" (the \"return\" key with a meta modifier) \"C-M-\" (the \"space\" key with both the control and meta modifiers) diff --git a/lisp/ls-lisp.el b/lisp/ls-lisp.el index 7a4be3c7e4c..33dd98ef8d2 100644 --- a/lisp/ls-lisp.el +++ b/lisp/ls-lisp.el @@ -891,7 +891,7 @@ All ls time options, namely c, t and u, are handled." nil) (defun ls-lisp--sanitize-switches (switches) - "Convert long options of GNU 'ls' to their short form. + "Convert long options of GNU \"ls\" to their short form. Conversion is done only for flags supported by ls-lisp. Long options not supported by ls-lisp are removed. Supported options are: A a B C c F G g h i n R r S s t U u v X. diff --git a/lisp/mail/feedmail.el b/lisp/mail/feedmail.el index 32edc292619..35e9f73f8cf 100644 --- a/lisp/mail/feedmail.el +++ b/lisp/mail/feedmail.el @@ -1317,7 +1317,7 @@ feedmail-queue-buffer-file-name is restored to nil. Example advice for mail-send: - (advice-add 'mail-send :around #'my-feedmail-mail-send-advice) + (advice-add \\='mail-send :around #\\='my-feedmail-mail-send-advice) (defun my-feedmail-mail-send-advice (orig-fun &rest args) (let ((feedmail-queue-buffer-file-name buffer-file-name) (buffer-file-name nil)) @@ -1742,7 +1742,7 @@ applied to a file after you've just read it from disk: for example, a feedmail FQM message file from a queue. You could use something like this: - (add-to-list 'auto-mode-alist \\='(\"\\\\.fqm\\\\\\='\" . feedmail-vm-mail-mode))" + (add-to-list \\='auto-mode-alist \\='(\"\\\\.fqm\\\\\\='\" . feedmail-vm-mail-mode))" (feedmail-say-debug ">in-> feedmail-vm-mail-mode") (let ((the-buf (current-buffer))) (vm-mail) diff --git a/lisp/mh-e/mh-limit.el b/lisp/mh-e/mh-limit.el index a2ea7610139..3e731e22a1f 100644 --- a/lisp/mh-e/mh-limit.el +++ b/lisp/mh-e/mh-limit.el @@ -143,7 +143,7 @@ Use \\\\[mh-widen] to undo this command." ;;; Support Routines (defun mh-subject-to-sequence (all) - "Put all following messages with same subject in sequence 'subject. + "Put all following messages with same subject in sequence `subject'. If arg ALL is t, move to beginning of folder buffer to collect all messages. If arg ALL is nil, collect only messages from current one on forward. @@ -161,7 +161,7 @@ Return number of messages put in the sequence: (mh-subject-to-sequence-unthreaded all))) (defun mh-subject-to-sequence-threaded (all) - "Put all messages with the same subject in the 'subject sequence. + "Put all messages with the same subject in the `subject' sequence. This function works when the folder is threaded. In this situation the subject could get truncated and so the normal @@ -192,7 +192,7 @@ are taken into account." It would be desirable to avoid hard-coding this.") (defun mh-subject-to-sequence-unthreaded (all) - "Put all following messages with same subject in sequence 'subject. + "Put all following messages with same subject in sequence `subject'. This function only works with an unthreaded folder. If arg ALL is t, move to beginning of folder buffer to collect all messages. If diff --git a/lisp/mh-e/mh-mime.el b/lisp/mh-e/mh-mime.el index 98a20b7bb4f..d2e07977e5d 100644 --- a/lisp/mh-e/mh-mime.el +++ b/lisp/mh-e/mh-mime.el @@ -1764,7 +1764,7 @@ initialized. Always use the command `mh-have-file-command'.") ;;;###mh-autoload (defun mh-have-file-command () "Return t if `file' command is on the system. -'file -i' is used to get MIME type of composition insertion." +\"file -i\" is used to get MIME type of composition insertion." (when (eq mh-have-file-command 'undefined) (setq mh-have-file-command (and (executable-find "file") ; file command exists diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 198162266ee..d52084afc3c 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -4101,7 +4101,7 @@ This turns into (prefix \"f\" any \"o\" any \"o\" any point) which is at the core of flex logic. The extra -'any' is optimized away later on." +`any' is optimized away later on." (mapcan (lambda (elem) (if (stringp elem) (mapcan (lambda (char) diff --git a/lisp/net/dictionary-connection.el b/lisp/net/dictionary-connection.el index aef3c4efc74..a4afcd6647d 100644 --- a/lisp/net/dictionary-connection.el +++ b/lisp/net/dictionary-connection.el @@ -83,10 +83,10 @@ Return a data structure identifying the connection." "Return the status of the CONNECTION. Possible return values are the symbols: nil: argument is not a connection object - 'none: argument is not connected - 'up: connection is open and buffer is existing - 'down: connection is closed - 'alone: connection is not associated with a buffer" + `none': argument is not connected + `up': connection is open and buffer is existing + `down': connection is closed + `alone': connection is not associated with a buffer" (when (dictionary-connection-p connection) (let ((process (dictionary-connection-process connection)) (buffer (dictionary-connection-buffer connection))) diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 75dc679a3dd..57cb566c95d 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -311,7 +311,7 @@ parameter, and should return the (possibly) transformed URL." (defvar eww-accept-content-types "text/html, text/plain, text/sgml, text/css, application/xhtml+xml, */*;q=0.01" - "Value used for the HTTP 'Accept' header.") + "Value used for the HTTP \"Accept\" header.") (defvar-keymap eww-link-keymap :parent shr-map diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index d7d375e111d..9aac5b27e69 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -238,7 +238,7 @@ pair of the form (KEY VALUE). The following KEYs are defined: unchanged after expansion (i.e. no host, no user or no port were specified), that sublist is not used. For e.g. - '((\"-a\" \"-b\") (\"-l\" \"%u\")) + \\='((\"-a\" \"-b\") (\"-l\" \"%u\")) that means that (\"-l\" \"%u\") is used only if the user was specified, and it is thus effectively optional. diff --git a/lisp/obsolete/mouse-sel.el b/lisp/obsolete/mouse-sel.el index a9d6bfee604..3eacac65fba 100644 --- a/lisp/obsolete/mouse-sel.el +++ b/lisp/obsolete/mouse-sel.el @@ -438,7 +438,7 @@ Click sets point & mark to click position. Dragging extends region/selection. Multi-clicking selects word/lines/paragraphs, as determined by -'mouse-sel-determine-selection-thing. +`mouse-sel-determine-selection-thing'. Clicking mouse-2 while selecting copies selected text to the kill-ring. Clicking mouse-1 or mouse-3 kills the selected text. @@ -459,7 +459,7 @@ Click sets the start of the secondary selection to click position. Dragging extends the secondary selection. Multi-clicking selects word/lines/paragraphs, as determined by -'mouse-sel-determine-selection-thing. +`mouse-sel-determine-selection-thing'. Clicking mouse-2 while selecting copies selected text to the kill-ring. Clicking mouse-1 or mouse-3 kills the selected text. diff --git a/lisp/org/ob-core.el b/lisp/org/ob-core.el index 23ef162a7f3..04af84d2e44 100644 --- a/lisp/org/ob-core.el +++ b/lisp/org/ob-core.el @@ -480,7 +480,7 @@ value. The value can either be a string or a closure that evaluates to a string. The closure is evaluated when the source block is being evaluated (e.g. during execution or export), with point at the source block. It is not possible to use an -arbitrary function symbol (e.g. 'some-func), since org uses +arbitrary function symbol (e.g. `some-func'), since org uses lexical binding. To achieve the same functionality, call the function within a closure (e.g. (lambda () (some-func))). diff --git a/lisp/org/ob-julia.el b/lisp/org/ob-julia.el index abddca36134..50a44bcf448 100644 --- a/lisp/org/ob-julia.el +++ b/lisp/org/ob-julia.el @@ -250,8 +250,8 @@ end") (defun org-babel-julia-evaluate-external-process (body result-type result-params column-names-p) "Evaluate BODY in external julia process. -If RESULT-TYPE equals 'output then return standard output as a -string. If RESULT-TYPE equals 'value then return the value of the +If RESULT-TYPE equals `output' then return standard output as a +string. If RESULT-TYPE equals `value' then return the value of the last statement in BODY, as elisp." (cl-case result-type (value @@ -274,8 +274,8 @@ last statement in BODY, as elisp." (defun org-babel-julia-evaluate-session (session body result-type result-params column-names-p) "Evaluate BODY in SESSION. -If RESULT-TYPE equals 'output then return standard output as a -string. If RESULT-TYPE equals 'value then return the value of the +If RESULT-TYPE equals `output' then return standard output as a +string. If RESULT-TYPE equals `value' then return the value of the last statement in BODY, as elisp." (cl-case result-type (value diff --git a/lisp/org/ob-lua.el b/lisp/org/ob-lua.el index 48de0dbad06..b6e78fb7fd8 100644 --- a/lisp/org/ob-lua.el +++ b/lisp/org/ob-lua.el @@ -395,7 +395,7 @@ fd:close()" (org-babel-lua-table-or-string results))))) (defun org-babel-lua-read-string (string) - "Strip 's from around Lua string." + "Strip \\=' characters from around Lua string." (org-unbracket-string "'" "'" string)) (provide 'ob-lua) diff --git a/lisp/org/org-agenda.el b/lisp/org/org-agenda.el index 71aac271f7b..dfd5d829db2 100644 --- a/lisp/org/org-agenda.el +++ b/lisp/org/org-agenda.el @@ -4124,7 +4124,7 @@ dimming them." ;FIXME: The arg isn't used, actually! If the header at `org-hd-marker' is blocked according to `org-entry-blocked-p', then if `org-agenda-dim-blocked-tasks' is -'invisible and the header is not blocked by checkboxes, set the +`invisible' and the header is not blocked by checkboxes, set the text property `org-todo-blocked' to `invisible', otherwise set it to t." (when (get-text-property 0 'todo-state entry) @@ -7399,7 +7399,7 @@ Argument ARG is the prefix argument." When in a restricted subtree, remove it. The restriction will span over the entire file if TYPE is `file', -or if type is '(4), or if the cursor is before the first headline +or if type is \\='(4), or if the cursor is before the first headline in the file. Otherwise, only apply the restriction to the current subtree." (interactive "P") diff --git a/lisp/org/org-plot.el b/lisp/org/org-plot.el index bf84c99e042..4507fbe7ddc 100644 --- a/lisp/org/org-plot.el +++ b/lisp/org/org-plot.el @@ -280,7 +280,7 @@ When NORMALISE is non-nil, the count is divided by the number of values." collect (cons n (/ (length m) normaliser))))) (defun org--plot/prime-factors (value) - "Return the prime decomposition of VALUE, e.g. for 12, '(3 2 2)." + "Return the prime decomposition of VALUE, e.g. for 12, \\='(3 2 2)." (let ((factors '(1)) (i 1)) (while (/= 1 value) (setq i (1+ i)) diff --git a/lisp/org/org-table.el b/lisp/org/org-table.el index 860fd6e5608..c301bc6af1a 100644 --- a/lisp/org/org-table.el +++ b/lisp/org/org-table.el @@ -5465,7 +5465,7 @@ The table is taken from the parameter TXT, or from the buffer at point." (nreverse table))))) (defun org-table-collapse-header (table &optional separator max-header-lines) - "Collapse the lines before 'hline into a single header. + "Collapse the lines before `hline' into a single header. The given TABLE is a list of lists as returned by `org-table-to-lisp'. The leading lines before the first `hline' symbol are considered diff --git a/lisp/org/ox-html.el b/lisp/org/ox-html.el index 81ef002a052..9cf9125aebd 100644 --- a/lisp/org/ox-html.el +++ b/lisp/org/ox-html.el @@ -2909,7 +2909,7 @@ Starred and \"displaymath\" environments are not numbered." (defun org-html--unlabel-latex-environment (latex-frag) "Change environment in LATEX-FRAG string to an unnumbered one. -For instance, change an 'equation' environment to 'equation*'." +For instance, change an `equation' environment to `equation*'." (replace-regexp-in-string "\\`[ \t]*\\\\begin{\\([^*]+?\\)}" "\\1*" diff --git a/lisp/org/ox-publish.el b/lisp/org/ox-publish.el index 636bd0d2ae3..51e2352b4e8 100644 --- a/lisp/org/ox-publish.el +++ b/lisp/org/ox-publish.el @@ -839,7 +839,7 @@ in `org-export-options-alist' or in export back-ends. In the latter case, optional argument BACKEND has to be set to the back-end where the option is defined, e.g., - (org-publish-find-property file :subtitle 'latex) + (org-publish-find-property file :subtitle \\='latex) Return value may be a string or a list, depending on the type of PROPERTY, i.e. \"behavior\" parameter from `org-export-options-alist'." diff --git a/lisp/outline.el b/lisp/outline.el index 9f73ca0d0c7..7fd43195cc0 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -1502,7 +1502,7 @@ LEVEL, decides of subtree visibility according to (defun outline--cycle-state () "Return the cycle state of current heading. -Return either 'hide-all, 'headings-only, or 'show-all." +Return either `hide-all', `headings-only', or `show-all'." (save-excursion (let (start end ov-list heading-end) (outline-back-to-heading) diff --git a/lisp/play/dunnet.el b/lisp/play/dunnet.el index 07f27374df7..b859176bb47 100644 --- a/lisp/play/dunnet.el +++ b/lisp/play/dunnet.el @@ -898,7 +898,7 @@ Regular objects have whole numbers lower than 255. Objects that cannot be taken but might move and are described during room description are negative. Stuff that is described and might change are 255, and are -handled specially by 'dun-describe-room.") +handled specially by `dun-describe-room'.") (defconst dun-room-silents (list nil (list obj-tree obj-coconut) ;; dead-end diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index 0dfff32f20d..8cae680634f 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -779,7 +779,7 @@ functions are annotated with \"\" via the (defun elisp--xref-make-xref (type symbol file &optional summary) "Return an xref for TYPE SYMBOL in FILE. TYPE must be a type in `find-function-regexp-alist' (use nil for -'defun). If SUMMARY is non-nil, use it for the summary; +`defun'). If SUMMARY is non-nil, use it for the summary; otherwise build the summary from TYPE and SYMBOL." (xref-make (or summary (format elisp--xref-format (or type 'defun) symbol)) diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el index a35a7deb4b1..089c273bc6d 100644 --- a/lisp/progmodes/gdb-mi.el +++ b/lisp/progmodes/gdb-mi.el @@ -1581,7 +1581,7 @@ Buffer mode and name are selected according to buffer type. If buffer has trigger associated with it in `gdb-buffer-rules', this trigger is subscribed to `gdb-buf-publisher' and called with -'update argument." +`update' argument." (or (gdb-get-buffer buffer-type thread) (let ((rules (assoc buffer-type gdb-buffer-rules)) (new (generate-new-buffer "limbo"))) diff --git a/lisp/progmodes/tcl.el b/lisp/progmodes/tcl.el index ed6dce02c03..8c179879ce2 100644 --- a/lisp/progmodes/tcl.el +++ b/lisp/progmodes/tcl.el @@ -344,7 +344,7 @@ information): Add functions to the hook with `add-hook': - (add-hook 'tcl-mode-hook #'tcl-guess-application)") + (add-hook \\='tcl-mode-hook #\\='tcl-guess-application)") (defvar tcl-proc-list diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el index edce3fef6cf..31d50a1882e 100644 --- a/lisp/progmodes/verilog-mode.el +++ b/lisp/progmodes/verilog-mode.el @@ -3622,10 +3622,10 @@ is 0. Meaning of *single* declaration: E.g. In a module's port-list - module test(input clk, rst, x, output [1:0] y); - Here 'input clk, rst, x' is 1 *single* declaration statement, -and 'output [1:0] y' is the other single declaration. In the 1st single -declaration, POINT is moved to start of 'clk'. And in the 2nd declaration, -POINT is moved to 'y'." + Here `input clk, rst, x' is 1 *single* declaration statement, +and `output [1:0] y' is the other single declaration. In the 1st single +declaration, POINT is moved to start of `clk'. And in the 2nd declaration, +POINT is moved to `y'." (let (maxpoint old-point) diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 958d4e8b9d7..fee2d0afcb9 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -1868,7 +1868,7 @@ to control which program to use when looking for matches." (xref--find-ignores-arguments ignores dir))) (defun xref--find-ignores-arguments (ignores dir) - "Convert IGNORES and DIR to a list of arguments for 'find'. + "Convert IGNORES and DIR to a list of arguments for `find'. IGNORES is a list of glob patterns. DIR is an absolute directory, used as the root of the ignore globs." (cl-assert (not (string-match-p "\\`~" dir))) diff --git a/lisp/ses.el b/lisp/ses.el index 59e10e777f1..7a9b35d749a 100644 --- a/lisp/ses.el +++ b/lisp/ses.el @@ -2331,7 +2331,7 @@ Narrow to print area if optional argument NONARROW is nil." "Recalculate and reprint the current cell or range. If CURCELL is non nil use it as current cell or range -without any check, otherwise function (ses-check-curcell 'range) +without any check, otherwise function (ses-check-curcell \\='range) is called. For an individual cell, shows the error if the formula or printer @@ -3774,15 +3774,15 @@ DEFINITION shall be either a string formatter, e.g.: \"%.2f\" or (\"%.2f\") for left alignment. or a lambda expression, e.g. for formatting in ISO format dates -created with a '(calcFunc-date YEAR MONTH DAY)' formula: +created with a `(calcFunc-date YEAR MONTH DAY)' formula: (lambda (x) (cond ((null val) \"\") - ((eq (car-safe x) 'date) - (let ((calc-format-date '(X YYYY \"-\" MM \"-\" DD))) + ((eq (car-safe x) \\='date) + (let ((calc-format-date \\='(X YYYY \"-\" MM \"-\" DD))) (math-format-date x))) - (t (ses-center-span val ?# 'ses-prin1)))) + (t (ses-center-span val ?# \\='ses-prin1)))) If NAME is already used to name a local printer function, then the current definition is proposed as default value, and the @@ -4122,7 +4122,7 @@ until the next nonblank column." (ses-center-span value ?~ printer)) (defun ses-prin1 (value) - "Shorthand for '(prin1-to-string VALUE t)'. + "Shorthand for `(prin1-to-string VALUE t)'. Useful to handle the default behavior in custom lambda based printer functions." (prin1-to-string value t)) diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index c4d450fe2a5..a0dd20a99ca 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -229,7 +229,7 @@ a list of frames to update." (defun tab-bar--key-to-number (key) "Return the tab number represented by KEY. -If KEY is a symbol 'tab-N', where N is a tab number, the value is N. +If KEY is a symbol `tab-N', where N is a tab number, the value is N. If KEY is \\='current-tab, the value is nil. For any other value of KEY, the value is t." (cond @@ -426,7 +426,7 @@ on each new frame when the global `tab-bar-mode' is disabled, or if you want to disable the tab bar individually on each new frame when the global `tab-bar-mode' is enabled, by using - (add-hook 'after-make-frame-functions 'toggle-frame-tab-bar)" + (add-hook \\='after-make-frame-functions #\\='toggle-frame-tab-bar)" (interactive) (set-frame-parameter frame 'tab-bar-lines (if (> (frame-parameter frame 'tab-bar-lines) 0) 0 1)) diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el index b2e0b7f9d09..62a4af13774 100644 --- a/lisp/textmodes/bibtex.el +++ b/lisp/textmodes/bibtex.el @@ -5039,7 +5039,7 @@ on the value of `bibtex-entry-format'. If the reference key of the entry is empty or a prefix argument is given, calculate a new reference key. (Note: this works only if fields in entry begin on separate lines prior to calling `bibtex-clean-entry' or if -'realign is contained in `bibtex-entry-format'.) +`realign' is contained in `bibtex-entry-format'.) Don't call `bibtex-clean-entry' on @Preamble entries. At end of the cleaning process, the functions in `bibtex-clean-entry-hook' are called with region narrowed to entry." diff --git a/lisp/textmodes/rst.el b/lisp/textmodes/rst.el index 9d3e9effe6e..6a91cef1d94 100644 --- a/lisp/textmodes/rst.el +++ b/lisp/textmodes/rst.el @@ -2351,7 +2351,7 @@ If user selects bullets or #, it's just added with position arranged by `rst-insert-list-new-tag'. If user selects enumerations, a further prompt is given. User need to -input a starting item, for example 'e' for 'A)' style. The position is +input a starting item, for example `e' for `A)' style. The position is also arranged by `rst-insert-list-new-tag'." (let* ((itemstyle (completing-read (format-prompt "Select preferred item style" "#.") diff --git a/lisp/transient.el b/lisp/transient.el index 0d7f9d0317b..13e8de258bd 100644 --- a/lisp/transient.el +++ b/lisp/transient.el @@ -1384,7 +1384,7 @@ The optional argument COMMAND is intended for internal use. If you are contemplating using it in your own code, then you should probably use this instead: - (get COMMAND 'transient--suffix)" + (get COMMAND \\='transient--suffix)" (when command (cl-check-type command command)) (if (or transient--prefix diff --git a/lisp/tutorial.el b/lisp/tutorial.el index 2d313076e3a..0f3a1506d6b 100644 --- a/lisp/tutorial.el +++ b/lisp/tutorial.el @@ -385,7 +385,7 @@ correspond to what the tutorial says.\n\n") "Find the key bindings used in the tutorial that have changed. Return a list with elements of the form - '(KEY DEF-FUN DEF-FUN-TXT WHERE REMARK QUIET) + (KEY DEF-FUN DEF-FUN-TXT WHERE REMARK QUIET) where diff --git a/lisp/url/url-auth.el b/lisp/url/url-auth.el index dd658b1b68b..53cefb46e4b 100644 --- a/lisp/url/url-auth.el +++ b/lisp/url/url-auth.el @@ -307,8 +307,8 @@ object." (defun url-digest-auth-build-response (key url realm attrs) "Compute authorization string for the given challenge using KEY. -The string looks like 'Digest username=\"John\", realm=\"The -Realm\", ...' +The string looks like \"Digest username=\"John\", realm=\"The +Realm\", ...\" Part of the challenge is already solved in a pre-computed KEY which is list of a realm (or a directory), user name, and hash diff --git a/lisp/vc/vc-rcs.el b/lisp/vc/vc-rcs.el index fb57b2bbc6e..170f5c8d464 100644 --- a/lisp/vc/vc-rcs.el +++ b/lisp/vc/vc-rcs.el @@ -1062,9 +1062,9 @@ file." (defun vc-rcs-consult-headers (file) "Search for RCS headers in FILE, and set properties accordingly. -Returns: nil if no headers were found - 'rev if a workfile revision was found - 'rev-and-lock if revision and lock info was found" +Returns: nil if no headers were found + `rev' if a workfile revision was found + `rev-and-lock' if revision and lock info was found" (cond ((not (get-file-buffer file)) nil) ((let (status version) diff --git a/lisp/window.el b/lisp/window.el index f3a09ee462b..c15f14cc61d 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -2496,7 +2496,7 @@ unless DEDICATED is non-nil, so if all windows are dedicated, the value is nil. Avoid returning the selected window if possible. Optional argument NOT-SELECTED non-nil means never return the selected window. Optional argument NO-OTHER non-nil means to -never return a window whose 'no-other-window' parameter is +never return a window whose `no-other-window' parameter is non-nil. The following non-nil values of the optional argument ALL-FRAMES @@ -2538,7 +2538,7 @@ never a candidate unless DEDICATED is non-nil, so if all windows are dedicated, the value is nil. Optional argument NOT-SELECTED non-nil means never return the selected window. Optional argument NO-OTHER non-nil means to never return a window whose -'no-other-window' parameter is non-nil. +`no-other-window' parameter is non-nil. The following non-nil values of the optional argument ALL-FRAMES have special meanings: @@ -2574,7 +2574,7 @@ never a candidate unless DEDICATED is non-nil, so if all windows are dedicated, the value is nil. Optional argument NOT-SELECTED non-nil means never return the selected window. Optional argument NO-OTHER non-nil means to never return a window whose -'no-other-window' parameter is non-nil. +`no-other-window' parameter is non-nil. The following non-nil values of the optional argument ALL-FRAMES have special meanings: @@ -5117,7 +5117,7 @@ parameter to nil. See Info node `(elisp) Quitting Windows' for more details. If WINDOW's dedicated flag is t, try to delete WINDOW. If it -equals the value 'side', restore that value when WINDOW is not +equals the value `side', restore that value when WINDOW is not deleted. Optional second argument BURY-OR-KILL tells how to proceed with @@ -7549,7 +7549,7 @@ to an expression containing one of these \"action\" functions: For instance: - (setq display-buffer-alist '((\".*\" display-buffer-at-bottom))) + (setq display-buffer-alist \\='((\".*\" display-buffer-at-bottom))) Buffer display can be further customized to a very high degree; the rest of this docstring explains some of the many @@ -7604,7 +7604,7 @@ Action alist entries are: the window specified in frame lines), a floating point number (the fraction of its total height with respect to the total height of the frame's root window), a cons cell whose - car is 'body-lines' and whose cdr is an integer that + car is `body-lines' and whose cdr is an integer that specifies the height of the window's body in frame lines, or a function to be called with one argument - the chosen window. That function is supposed to adjust the height of @@ -7615,7 +7615,7 @@ Action alist entries are: the window specified in frame lines), a floating point number (the fraction of its total width with respect to the width of the frame's root window), a cons cell whose car is - 'body-columns' and whose cdr is an integer that specifies the + `body-columns' and whose cdr is an integer that specifies the width of the window's body in frame columns, or a function to be called with one argument - the chosen window. That function is supposed to adjust the width of the window. @@ -7623,7 +7623,7 @@ Action alist entries are: alone on their frame and specifies the desired size of that window either as a cons of integers (the total width and height of the window on that frame), a cons cell whose car is - 'body-chars' and whose cdr is a cons of integers (the desired + `body-chars' and whose cdr is a cons of integers (the desired width and height of the window's body in columns and lines of its frame), or a function to be called with one argument - the chosen window. That function is supposed to adjust the diff --git a/test/lisp/calc/calc-tests.el b/test/lisp/calc/calc-tests.el index 892fd278df8..56cb9057ed9 100644 --- a/test/lisp/calc/calc-tests.el +++ b/test/lisp/calc/calc-tests.el @@ -38,7 +38,7 @@ ;; be used to compare such calc expressions. (defun calc-tests-equal (a b) "Like `equal' but allow for different representations of numbers. -For example: (calc-tests-equal 10 '(float 1 1)) => t. +For example: (calc-tests-equal 10 \\='(float 1 1)) => t. A and B should be calc expressions." (cond ((math-numberp a) (and (math-numberp b) diff --git a/test/lisp/cedet/srecode-utest-template.el b/test/lisp/cedet/srecode-utest-template.el index 1eb91e6053b..87c28c6af12 100644 --- a/test/lisp/cedet/srecode-utest-template.el +++ b/test/lisp/cedet/srecode-utest-template.el @@ -33,7 +33,7 @@ ;;; MAP DUMP TESTING (defun srecode-utest-map-reset () "Reset, then dump the map of SRecoder templates. -Probably should be called 'describe-srecode-maps'." +Probably should be called `describe-srecode-maps'." (interactive) (message "SRecode Template Path: %S" srecode-map-load-path) ;; Interactive call allows us to dump. diff --git a/test/lisp/mh-e/mh-thread-tests.el b/test/lisp/mh-e/mh-thread-tests.el index 84f59e5d300..ea8d441e2d1 100644 --- a/test/lisp/mh-e/mh-thread-tests.el +++ b/test/lisp/mh-e/mh-thread-tests.el @@ -24,7 +24,7 @@ (eval-when-compile (require 'cl-lib)) (defun mh-thread-tests-before-from () - "Generate the fields of a scan line up to where the 'From' field would start. + "Generate the fields of a scan line up to where the \"From\" field would start. The exact contents are not important, but the number of characters is." (concat (make-string mh-cmd-note ?9) (make-string mh-scan-cmd-note-width ?A) diff --git a/test/lisp/xml-tests.el b/test/lisp/xml-tests.el index eecf6406fb8..748f1e39446 100644 --- a/test/lisp/xml-tests.el +++ b/test/lisp/xml-tests.el @@ -97,7 +97,7 @@ ((("FOOBAR:" . "something") nil "hi there")) ((FOOBAR:something nil "hi there")))) "List of strings which are parsed using namespace expansion. -Parser is called with and without 'symbol-qnames argument.") +Parser is called with and without `symbol-qnames' argument.") (ert-deftest xml-parse-tests () "Test XML parsing." diff --git a/test/src/regex-emacs-tests.el b/test/src/regex-emacs-tests.el index e6288d1fc9b..ff0d6be3f5d 100644 --- a/test/src/regex-emacs-tests.el +++ b/test/src/regex-emacs-tests.el @@ -157,8 +157,8 @@ are known failures, and are skipped." (defun regex-tests-compare (string what-failed bounds-ref &optional substring-ref) "I just ran a search, looking at STRING. WHAT-FAILED describes -what failed, if anything; valid values are 'search-failed, -'compilation-failed and nil. I compare the beginning/end of each +what failed, if anything; valid values are `search-failed', +`compilation-failed' and nil. I compare the beginning/end of each group with their expected values. This is done with either BOUNDS-REF or SUBSTRING-REF; one of those should be non-nil. BOUNDS-REF is a sequence [start-ref0 end-ref0 start-ref1 @@ -166,9 +166,9 @@ end-ref1 ....] while SUBSTRING-REF is the expected substring obtained by indexing the input string by start/end-ref. If the search was supposed to fail then start-ref0/substring-ref0 -is 'search-failed. If the search wasn't even supposed to compile +is `search-failed'. If the search wasn't even supposed to compile successfully, then start-ref0/substring-ref0 is -'compilation-failed. If I only care about a match succeeding, +`compilation-failed'. If I only care about a match succeeding, this can be set to t. This function returns a string that describes the failure, or nil @@ -259,8 +259,8 @@ BOUNDS-REF is a sequence [start-ref0 end-ref0 start-ref1 end-ref1 ....]. If the search was supposed to fail then start-ref0 is -'search-failed. If the search wasn't even supposed to compile -successfully, then start-ref0 is 'compilation-failed. +`search-failed'. If the search wasn't even supposed to compile +successfully, then start-ref0 is `compilation-failed'. This function returns a string that describes the failure, or nil on success" -- cgit v1.2.3 From 2d71fd3b041506c68b5f1cd1e409e09e25778c34 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 22 Apr 2022 17:16:42 +0200 Subject: Further doc string quoting fixes * test/lisp/progmodes/cperl-mode-tests.el (cperl--run-test-cases): * lisp/simple.el (undo-equiv-table): * lisp/shell.el (shell-mode): (shell-mode): * lisp/recentf.el (recentf-mode): * lisp/org/ob-table.el (org-sbe): * lisp/net/eudc.el (eudc-rfc5322-cctext-token): * lisp/mail/ietf-drums-date.el (ietf-drums-date--slot-ranges): * lisp/faces.el (color-luminance-dark-limit): * lisp/erc/erc.el (erc-tls): * lisp/emacs-lisp/pcase.el (pcase-setq): Further quoting fixes in doc strings. --- lisp/emacs-lisp/pcase.el | 2 +- lisp/erc/erc.el | 2 +- lisp/faces.el | 4 ++-- lisp/mail/ietf-drums-date.el | 4 ++-- lisp/net/eudc.el | 2 +- lisp/org/ob-table.el | 2 +- lisp/recentf.el | 2 +- lisp/shell.el | 4 ++-- lisp/simple.el | 4 ++-- test/lisp/progmodes/cperl-mode-tests.el | 2 +- 10 files changed, 14 insertions(+), 14 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 0330a2a0aba..07443dabfef 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -328,7 +328,7 @@ PATTERNS are normal `pcase' patterns, and VALUES are expression. Evaluation happens sequentially as in `setq' (not in parallel). -An example: (pcase-setq `((,a) [(,b)]) '((1) [(2)])) +An example: (pcase-setq \\=`((,a) [(,b)]) \\='((1) [(2)])) VAL is presumed to match PAT. Failure to match may signal an error or go undetected, binding variables to arbitrary values, such as nil. diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 52fe106f2d1..06381c5ebee 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -2269,7 +2269,7 @@ Example usage: (erc-tls :server \"irc.libera.chat\" :port 6697 :client-certificate - '(\"/home/bandali/my-cert.key\" + \\='(\"/home/bandali/my-cert.key\" \"/home/bandali/my-cert.crt\"))" (interactive (let ((erc-default-port erc-default-port-tls)) (erc-select-read-args))) diff --git a/lisp/faces.el b/lisp/faces.el index b4e1f03eef6..962501ee7cc 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -1858,8 +1858,8 @@ on which one provides better contrast with COLOR." "#ffffff" "black")) (defconst color-luminance-dark-limit 0.325 - "The relative luminance below which a color is considered 'dark'. -A 'dark' color in this sense provides better contrast with white + "The relative luminance below which a color is considered \"dark\". +A \"dark\" color in this sense provides better contrast with white than with black; see `color-dark-p'. This value was determined experimentally.") diff --git a/lisp/mail/ietf-drums-date.el b/lisp/mail/ietf-drums-date.el index 6f64ae73377..ddef7f11b66 100644 --- a/lisp/mail/ietf-drums-date.el +++ b/lisp/mail/ietf-drums-date.el @@ -50,8 +50,8 @@ See the decoded-time defstruct.") '((0 60) (0 59) (0 23) (1 31) (1 12) (1 9999)) "Numeric slot ranges, for bounds checking. Note that RFC5322 explicitly requires that seconds go up to 60, -to allow for leap seconds (see Mills, D., 'Network Time -Protocol', STD 12, RFC 1119, September 1989).") +to allow for leap seconds (see Mills, D., \"Network Time +Protocol\", STD 12, RFC 1119, September 1989).") (defsubst ietf-drums-date--ignore-char-p (char) ;; Ignore whitespace and commas. diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el index 6ce89ce5be4..808d2ca509c 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el @@ -174,7 +174,7 @@ Value is the new string." "Folding white space.") (defconst eudc-rfc5322-cctext-token "\u005D-\u007E\u002A-\u005B\u0021-\u0027" - "Printable US-ASCII characters not including '(', ')', or '\\'.") + "Printable US-ASCII characters not including \"(\", \")\", or \"\\\".") (defun eudc-rfc5322-quote-phrase (string) "Quote STRING if it needs quoting as a phrase in a header." diff --git a/lisp/org/ob-table.el b/lisp/org/ob-table.el index 2f092998d8b..f6729e0ece7 100644 --- a/lisp/org/ob-table.el +++ b/lisp/org/ob-table.el @@ -84,7 +84,7 @@ is the equivalent of the following source code block: #+end_src NOTE: The quotation marks around the function name, -'source-block', are optional. +`source-block', are optional. NOTE: By default, string variable names are interpreted as references to source-code blocks, to force interpretation of a diff --git a/lisp/recentf.el b/lisp/recentf.el index 5e2f2218614..2de98311540 100644 --- a/lisp/recentf.el +++ b/lisp/recentf.el @@ -1353,7 +1353,7 @@ to a file, and killing a buffer is counted as \"operating\" on the file. If instead you want to prioritize files that appear in buffers you switch to a lot, you can say something like the following: - (add-hook 'buffer-list-update-hook 'recentf-track-opened-file)" + (add-hook \\='buffer-list-update-hook #\\='recentf-track-opened-file)" :global t :group 'recentf :keymap recentf-mode-map diff --git a/lisp/shell.el b/lisp/shell.el index a9990f5d551..627c48e35fb 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -528,7 +528,7 @@ Shell buffers. It implements `shell-completion-execonly' for the shell. This is useful for entering passwords. Or, add the function `comint-watch-for-password-prompt' to `comint-output-filter-functions'. -If you want to make multiple shell buffers, rename the `*shell*' buffer +If you want to make multiple shell buffers, rename the \"*shell*\" buffer using \\[rename-buffer] or \\[rename-uniquely] and start a new shell. If you want to make shell buffers limited in length, add the function @@ -575,7 +575,7 @@ buffer. By default, shell mode does nothing special when it receives a \"bell\" character (C-g or ^G). If you - (add-hook 'comint-output-filter-functions 'shell-filter-ring-bell nil t) + (add-hook \\='comint-output-filter-functions #\\='shell-filter-ring-bell nil t) from `shell-mode-hook', Emacs will call the `ding' function whenever it receives the bell character in output from a command." diff --git a/lisp/simple.el b/lisp/simple.el index 323d51dd2d3..75720d895cc 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -3008,12 +3008,12 @@ the minibuffer contents." (defconst undo-equiv-table (make-hash-table :test 'eq :weakness t) "Table mapping redo records to the corresponding undo one. -A redo record for an undo in region maps to 'undo-in-region. +A redo record for an undo in region maps to `undo-in-region'. A redo record for ordinary undo maps to the following (earlier) undo. A redo record that undoes to the beginning of the undo list maps to t. In the rare case where there are (erroneously) consecutive nil's in `buffer-undo-list', `undo' maps the previous valid undo record to -'empty, if the previous record is a redo record, `undo' doesn't change +`empty', if the previous record is a redo record, `undo' doesn't change its mapping. To be clear, a redo record is just an undo record, the only difference diff --git a/test/lisp/progmodes/cperl-mode-tests.el b/test/lisp/progmodes/cperl-mode-tests.el index b8a3bd97d8d..4e0debffb69 100644 --- a/test/lisp/progmodes/cperl-mode-tests.el +++ b/test/lisp/progmodes/cperl-mode-tests.el @@ -64,7 +64,7 @@ The expected output from running BODY on the input goes here. # -------- NAME: end -------- You can have many of these blocks in one test file. You can -chose a NAME for each block, which is passed to the 'should' +chose a NAME for each block, which is passed to the `should' clause for easy identification of the first test case that failed (if any). Text outside these the blocks is ignored by the tests, so you can use it to document the test cases if you wish." -- cgit v1.2.3 From 5b23c9942ae057c886e68edb8c4bf09bf7e8eda9 Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Fri, 22 Apr 2022 17:16:21 +0000 Subject: Byte compiler: correct output warning message positions (part 2) A supplementary commit to that on 2022-04-18: * lisp/emacs-lisp/bytecomp.el (byte-compile--first-symbol-with-pos): Handle vectors and records correctly. * lisp/emacs-lisp/byte-run.el (byte-run--ssp-seen): Correct the doc string. --- lisp/emacs-lisp/byte-run.el | 3 +-- lisp/emacs-lisp/bytecomp.el | 4 ++-- 2 files changed, 3 insertions(+), 4 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 384e8cba88f..0113051c8eb 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -32,8 +32,7 @@ (defvar byte-run--ssp-seen nil "Which conses/vectors/records have been processed in strip-symbol-positions? -The value is a hash table, the key being the old element and the value being -the corresponding new element of the same type. +The value is a hash table, the keys being the elements and the values being t. The purpose of this is to detect circular structures.") diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 8128410916a..f97324f3a8f 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1185,14 +1185,14 @@ Here, \"first\" is by a depth first search." (and (symbolp (setq sym (byte-compile--first-symbol-with-pos (cdr form)))) sym) 0)) - ((and (vectorp form) + ((and (or (vectorp form) (recordp form)) (> (length form) 0)) (let ((i 0) (len (length form)) elt) (catch 'sym (while (< i len) - (when (symbolp + (when (symbol-with-pos-p (setq elt (byte-compile--first-symbol-with-pos (aref form i)))) (throw 'sym elt)) (setq i (1+ i))) -- cgit v1.2.3 From 0b9b363dabd70032a288e14333896022caa2d252 Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Fri, 22 Apr 2022 19:11:31 +0000 Subject: Byte compiler: Prevent special forms' symbols being replaced by bare symbols These are symbols with position from source code, which should not be replaced by bare symbols in, e.g., optimization functions. * lisp/Makefile.in: (BYTE_COMPILE_FLAGS, compile-first case): Set max-specpdl-size to 5000 for the benefit of lisp/emacs-lisp/comp.el. * lisp/emacs-lisp/byte-opt.el (byte-optimize-form-code-walker) (byte-optimize--rename-var, byte-optimize-if, byte-optimize-letX) * lisp/emacs-lisp/bytecomp.el (byte-compile-recurse-toplevel) (byte-compile-lambda) * lisp/emacs-lisp/cconv.el (cconv-convert) * lisp/emacs-lisp/macroexp.el (macroexp--expand-all): Preserve, e.g., (car form) in the byte compiler, when this form's car is a symbol with position of a special form, rather than replacing the symbol with a bare symbol, e.g. 'cond. --- lisp/Makefile.in | 4 +- lisp/emacs-lisp/byte-opt.el | 115 ++++++++++++------------- lisp/emacs-lisp/bytecomp.el | 4 +- lisp/emacs-lisp/cconv.el | 22 ++--- lisp/emacs-lisp/macroexp.el | 203 ++++++++++++++++++++++---------------------- 5 files changed, 176 insertions(+), 172 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 308407a8bf1..fabf6ed55e1 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -78,7 +78,9 @@ AUTOGENEL = ${loaddefs} ${srcdir}/cus-load.el ${srcdir}/finder-inf.el \ BYTE_COMPILE_FLAGS = \ --eval '(setq load-prefer-newer t)' $(BYTE_COMPILE_EXTRA_FLAGS) # ... but we must prefer .elc files for those in the early bootstrap. -compile-first: BYTE_COMPILE_FLAGS = $(BYTE_COMPILE_EXTRA_FLAGS) +# A larger `max-specpdl-size' is needed for emacs-lisp/comp.el. +compile-first: BYTE_COMPILE_FLAGS = \ + --eval '(setq max-specpdl-size 5000)' $(BYTE_COMPILE_EXTRA_FLAGS) # Files to compile before others during a bootstrap. This is done to # speed up the bootstrap process. They're ordered by size, so we use diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 39bb6224595..d3d8405d068 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -338,7 +338,7 @@ for speeding up processing.") (let ((exps-opt (byte-optimize-body exps t))) (if (macroexp-const-p exp-opt) `(progn ,@exps-opt ,exp-opt) - `(prog1 ,exp-opt ,@exps-opt))) + `(,fn ,exp-opt ,@exps-opt))) exp-opt))) (`(,(or `save-excursion `save-restriction `save-current-buffer) . ,exps) @@ -358,7 +358,7 @@ for speeding up processing.") (then-opt (and test-opt (byte-optimize-form then for-effect))) (else-opt (and (not (and test-opt const)) (byte-optimize-body else for-effect)))) - `(if ,test-opt ,then-opt . ,else-opt))) + `(,fn ,test-opt ,then-opt . ,else-opt))) (`(,(or 'and 'or) . ,exps) ;; FIXME: We have to traverse the expressions in left-to-right @@ -397,7 +397,7 @@ for speeding up processing.") ;; as mutated variables have been marked as non-substitutable. (condition (byte-optimize-form (car condition-body) nil)) (body (byte-optimize-body (cdr condition-body) t))) - `(while ,condition . ,body))) + `(,fn ,condition . ,body))) (`(interactive . ,_) (byte-compile-warn-x form "misplaced interactive spec: `%s'" form) @@ -409,7 +409,7 @@ for speeding up processing.") form) (`(condition-case ,var ,exp . ,clauses) - `(condition-case ,var ;Not evaluated. + `(,fn ,var ;Not evaluated. ,(byte-optimize-form exp for-effect) ,@(mapcar (lambda (clause) (let ((byte-optimize--lexvars @@ -432,14 +432,14 @@ for speeding up processing.") (let ((bodyform (byte-optimize-form exp for-effect))) (pcase exps (`(:fun-body ,f) - `(unwind-protect ,bodyform + `(,fn ,bodyform :fun-body ,(byte-optimize-form f nil))) (_ - `(unwind-protect ,bodyform + `(,fn ,bodyform . ,(byte-optimize-body exps t)))))) (`(catch ,tag . ,exps) - `(catch ,(byte-optimize-form tag nil) + `(,fn ,(byte-optimize-form tag nil) . ,(byte-optimize-body exps for-effect))) ;; Needed as long as we run byte-optimize-form after cconv. @@ -495,7 +495,7 @@ for speeding up processing.") (cons (byte-optimize-form (car rest) nil) (cdr rest))))) (push name byte-optimize--dynamic-vars) - `(defvar ,name . ,optimized-rest))) + `(,fn ,name . ,optimized-rest))) (`(,(pred byte-code-function-p) . ,exps) (cons fn (mapcar #'byte-optimize-form exps))) @@ -561,49 +561,50 @@ for speeding up processing.") (defun byte-optimize--rename-var (var new-var form) "Replace VAR with NEW-VAR in FORM." - (pcase form - ((pred symbolp) (if (eq form var) new-var form)) - (`(setq . ,args) - (let ((new-args nil)) - (while args - (push (byte-optimize--rename-var var new-var (car args)) new-args) - (push (byte-optimize--rename-var var new-var (cadr args)) new-args) - (setq args (cddr args))) - `(setq . ,(nreverse new-args)))) - ;; In binding constructs like `let', `let*' and `condition-case' we - ;; rename everything for simplicity, even new bindings named VAR. - (`(,(and head (or 'let 'let*)) ,bindings . ,body) - `(,head - ,(mapcar (lambda (b) (byte-optimize--rename-var-body var new-var b)) - bindings) - ,@(byte-optimize--rename-var-body var new-var body))) - (`(condition-case ,res-var ,protected-form . ,handlers) - `(condition-case ,(byte-optimize--rename-var var new-var res-var) - ,(byte-optimize--rename-var var new-var protected-form) - ,@(mapcar (lambda (h) - (cons (car h) - (byte-optimize--rename-var-body var new-var (cdr h)))) - handlers))) - (`(internal-make-closure ,vars ,env . ,rest) - `(internal-make-closure - ,vars ,(byte-optimize--rename-var-body var new-var env) . ,rest)) - (`(defvar ,name . ,rest) - ;; NAME is not renamed here; we only care about lexical variables. - `(defvar ,name . ,(byte-optimize--rename-var-body var new-var rest))) - - (`(cond . ,clauses) - `(cond ,@(mapcar (lambda (c) - (byte-optimize--rename-var-body var new-var c)) - clauses))) - - (`(function . ,_) form) - (`(quote . ,_) form) - (`(lambda . ,_) form) - - ;; Function calls and special forms not handled above. - (`(,head . ,args) - `(,head . ,(byte-optimize--rename-var-body var new-var args))) - (_ form))) + (let ((fn (car-safe form))) + (pcase form + ((pred symbolp) (if (eq form var) new-var form)) + (`(setq . ,args) + (let ((new-args nil)) + (while args + (push (byte-optimize--rename-var var new-var (car args)) new-args) + (push (byte-optimize--rename-var var new-var (cadr args)) new-args) + (setq args (cddr args))) + `(,fn . ,(nreverse new-args)))) + ;; In binding constructs like `let', `let*' and `condition-case' we + ;; rename everything for simplicity, even new bindings named VAR. + (`(,(and head (or 'let 'let*)) ,bindings . ,body) + `(,head + ,(mapcar (lambda (b) (byte-optimize--rename-var-body var new-var b)) + bindings) + ,@(byte-optimize--rename-var-body var new-var body))) + (`(condition-case ,res-var ,protected-form . ,handlers) + `(,fn ,(byte-optimize--rename-var var new-var res-var) + ,(byte-optimize--rename-var var new-var protected-form) + ,@(mapcar (lambda (h) + (cons (car h) + (byte-optimize--rename-var-body var new-var (cdr h)))) + handlers))) + (`(internal-make-closure ,vars ,env . ,rest) + `(,fn + ,vars ,(byte-optimize--rename-var-body var new-var env) . ,rest)) + (`(defvar ,name . ,rest) + ;; NAME is not renamed here; we only care about lexical variables. + `(,fn ,name . ,(byte-optimize--rename-var-body var new-var rest))) + + (`(cond . ,clauses) + `(,fn ,@(mapcar (lambda (c) + (byte-optimize--rename-var-body var new-var c)) + clauses))) + + (`(function . ,_) form) + (`(quote . ,_) form) + (`(lambda . ,_) form) + + ;; Function calls and special forms not handled above. + (`(,head . ,args) + `(,head . ,(byte-optimize--rename-var-body var new-var args))) + (_ form)))) (defun byte-optimize-let-form (head form for-effect) ;; Recursively enter the optimizer for the bindings and body @@ -1174,21 +1175,21 @@ See Info node `(elisp) Integer Basics'." (proper-list-p clause)) (if (null (cddr clause)) ;; A trivial `progn'. - (byte-optimize-if `(if ,(cadr clause) ,@(nthcdr 2 form))) + (byte-optimize-if `(,(car form) ,(cadr clause) ,@(nthcdr 2 form))) (nconc (butlast clause) (list (byte-optimize-if - `(if ,(car (last clause)) ,@(nthcdr 2 form))))))) + `(,(car form) ,(car (last clause)) ,@(nthcdr 2 form))))))) ((byte-compile-trueconstp clause) `(progn ,clause ,(nth 2 form))) ((byte-compile-nilconstp clause) `(progn ,clause ,@(nthcdr 3 form))) ((nth 2 form) (if (equal '(nil) (nthcdr 3 form)) - (list 'if clause (nth 2 form)) + (list (car form) clause (nth 2 form)) form)) ((or (nth 3 form) (nthcdr 4 form)) - (list 'if + (list (car form) ;; Don't make a double negative; ;; instead, take away the one that is there. (if (and (consp clause) (memq (car clause) '(not null)) @@ -1267,7 +1268,7 @@ See Info node `(elisp) Integer Basics'." (and (consp binding) (cadr binding))) bindings) ,const) - `(let* ,(butlast bindings) + `(,head ,(butlast bindings) ,@(and (consp (car (last bindings))) (cdar (last bindings))) ,const))) @@ -1282,7 +1283,7 @@ See Info node `(elisp) Integer Basics'." `(progn ,@(mapcar (lambda (binding) (and (consp binding) (cadr binding))) bindings)) - `(let* ,(butlast bindings) + `(,head ,(butlast bindings) ,@(and (consp (car (last bindings))) (cdar (last bindings)))))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index f97324f3a8f..28237d67d29 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -471,7 +471,7 @@ Return the compile-time value of FORM." (let ((print-symbols-bare t)) ; Possibly redundant binding. (setf form (macroexp-macroexpand form byte-compile-macro-environment))) (if (eq (car-safe form) 'progn) - (cons 'progn + (cons (car form) (mapcar (lambda (subform) (byte-compile-recurse-toplevel subform non-toplevel-case)) @@ -3084,7 +3084,7 @@ lambda-expression." ;; which may include "calls" to ;; internal-make-closure (Bug#29988). lexical-binding) - (setq int `(interactive ,newform))))) + (setq int `(,(car int) ,newform))))) ((cdr int) ; Invalid (interactive . something). (byte-compile-warn-x int "malformed interactive spec: %s" int)))) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index be4fea7be14..4535f1aa6eb 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -500,11 +500,11 @@ places where they originally did not directly appear." args))) (`(cond . ,cond-forms) ; cond special form - `(cond . ,(mapcar (lambda (branch) - (mapcar (lambda (form) - (cconv-convert form env extend)) - branch)) - cond-forms))) + `(,(car form) . ,(mapcar (lambda (branch) + (mapcar (lambda (form) + (cconv-convert form env extend)) + branch)) + cond-forms))) (`(function (lambda ,args . ,body) . ,_) (let ((docstring (if (eq :documentation (car-safe (car body))) @@ -538,7 +538,7 @@ places where they originally did not directly appear." (msg (when (eq class :unused) (cconv--warn-unused-msg var "variable"))) (newprotform (cconv-convert protected-form env extend))) - `(condition-case ,var + `(,(car form) ,var ,(if msg (macroexp--warn-wrap var msg newprotform 'lexical) newprotform) @@ -554,9 +554,9 @@ places where they originally did not directly appear." `((let ((,var (list ,var))) ,@body)))))) handlers)))) - (`(unwind-protect ,form . ,body) - `(unwind-protect ,(cconv-convert form env extend) - :fun-body ,(cconv--convert-function () body env form))) + (`(unwind-protect ,form1 . ,body) + `(,(car form) ,(cconv-convert form1 env extend) + :fun-body ,(cconv--convert-function () body env form1))) (`(setq . ,forms) ; setq special form (if (= (logand (length forms) 1) 1) @@ -568,7 +568,7 @@ places where they originally did not directly appear." (sym-new (or (cdr (assq sym env)) sym)) (value (cconv-convert (pop forms) env extend))) (push (pcase sym-new - ((pred symbolp) `(setq ,sym-new ,value)) + ((pred symbolp) `(,(car form) ,sym-new ,value)) (`(car-safe ,iexp) `(setcar ,iexp ,value)) ;; This "should never happen", but for variables which are ;; mutated+captured+unused, we may end up trying to `setq' @@ -604,7 +604,7 @@ places where they originally did not directly appear." (cons fun args))))))) (`(interactive . ,forms) - `(interactive . ,(mapcar (lambda (form) + `(,(car form) . ,(mapcar (lambda (form) (cconv-convert form nil nil)) forms))) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index e4bc2df2803..51c6e8e0ca2 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -330,108 +330,109 @@ Assumes the caller has bound `macroexpand-all-environment'." (setq form (macroexp-macroexpand form macroexpand-all-environment)) ;; FIXME: It'd be nice to use `byte-optimize--pcase' here, but when ;; I tried it, it broke the bootstrap :-( - (pcase form - (`(cond . ,clauses) - (macroexp--cons 'cond (macroexp--all-clauses clauses) form)) - (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare)) - (macroexp--cons - 'condition-case - (macroexp--cons err - (macroexp--cons (macroexp--expand-all body) - (macroexp--all-clauses handlers 1) - (cddr form)) - (cdr form)) - form)) - (`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_) - (push name macroexp--dynvars) - (macroexp--all-forms form 2)) - (`(function ,(and f `(lambda . ,_))) - (let ((macroexp--dynvars macroexp--dynvars)) - (macroexp--cons 'function - (macroexp--cons (macroexp--all-forms f 2) - nil - (cdr form)) - form))) - (`(,(or 'function 'quote) . ,_) form) - (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) - pcase--dontcare)) - (let ((macroexp--dynvars macroexp--dynvars)) + (let ((fn (car-safe form))) + (pcase form + (`(cond . ,clauses) + (macroexp--cons fn (macroexp--all-clauses clauses) form)) + (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare)) (macroexp--cons - fun - (macroexp--cons - (macroexp--all-clauses bindings 1) - (if (null body) - (macroexp-unprogn - (macroexp-warn-and-return - (format "Empty %s body" fun) - nil nil 'compile-only fun)) - (macroexp--all-forms body)) - (cdr form)) - form))) - (`(,(and fun `(lambda . ,_)) . ,args) - ;; Embedded lambda in function position. - ;; If the byte-optimizer is loaded, try to unfold this, - ;; i.e. rewrite it to (let () ). We'd do it in the optimizer - ;; anyway, but doing it here (i.e. earlier) can sometimes avoid the - ;; creation of a closure, thus resulting in much better code. - (let ((newform (macroexp--unfold-lambda form))) - (if (eq newform form) - ;; Unfolding failed for some reason, avoid infinite recursion. - (macroexp--cons (macroexp--all-forms fun 2) - (macroexp--all-forms args) - form) - (macroexp--expand-all newform)))) - (`(funcall ,exp . ,args) - (let ((eexp (macroexp--expand-all exp)) - (eargs (macroexp--all-forms args))) - ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' - ;; has a compiler-macro, or to unfold it. - (pcase eexp - ((and `#',f - (guard (not (or (special-form-p f) (macrop f))))) ;; bug#46636 - (macroexp--expand-all `(,f . ,eargs))) - (_ `(funcall ,eexp . ,eargs))))) - (`(funcall . ,_) form) ;bug#53227 - (`(,func . ,_) - (let ((handler (function-get func 'compiler-macro)) - (funargs (function-get func 'funarg-positions))) - ;; Check functions quoted with ' rather than with #' - (dolist (funarg funargs) - (let ((arg (nth funarg form))) - (when (and (eq 'quote (car-safe arg)) - (eq 'lambda (car-safe (cadr arg)))) - (setcar (nthcdr funarg form) - (macroexp-warn-and-return - (format "%S quoted with ' rather than with #'" - (let ((f (cadr arg))) - (if (symbolp f) f `(lambda ,(nth 1 f) ...)))) - arg nil nil (cadr arg)))))) - ;; Macro expand compiler macros. This cannot be delayed to - ;; byte-optimize-form because the output of the compiler-macro can - ;; use macros. - (if (null handler) - ;; No compiler macro. We just expand each argument (for - ;; setq/setq-default this works alright because the variable names - ;; are symbols). - (macroexp--all-forms form 1) - ;; If the handler is not loaded yet, try (auto)loading the - ;; function itself, which may in turn load the handler. - (unless (functionp handler) - (with-demoted-errors "macroexp--expand-all: %S" - (autoload-do-load (indirect-function func) func))) - (let ((newform (macroexp--compiler-macro handler form))) - (if (eq form newform) - ;; The compiler macro did not find anything to do. - (if (equal form (setq newform (macroexp--all-forms form 1))) - form - ;; Maybe after processing the args, some new opportunities - ;; appeared, so let's try the compiler macro again. - (setq form (macroexp--compiler-macro handler newform)) - (if (eq newform form) - newform - (macroexp--expand-all newform))) - (macroexp--expand-all newform)))))) - (_ form))) + fn + (macroexp--cons err + (macroexp--cons (macroexp--expand-all body) + (macroexp--all-clauses handlers 1) + (cddr form)) + (cdr form)) + form)) + (`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_) + (push name macroexp--dynvars) + (macroexp--all-forms form 2)) + (`(function ,(and f `(lambda . ,_))) + (let ((macroexp--dynvars macroexp--dynvars)) + (macroexp--cons fn + (macroexp--cons (macroexp--all-forms f 2) + nil + (cdr form)) + form))) + (`(,(or 'function 'quote) . ,_) form) + (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) + pcase--dontcare)) + (let ((macroexp--dynvars macroexp--dynvars)) + (macroexp--cons + fun + (macroexp--cons + (macroexp--all-clauses bindings 1) + (if (null body) + (macroexp-unprogn + (macroexp-warn-and-return + (format "Empty %s body" fun) + nil nil 'compile-only fun)) + (macroexp--all-forms body)) + (cdr form)) + form))) + (`(,(and fun `(lambda . ,_)) . ,args) + ;; Embedded lambda in function position. + ;; If the byte-optimizer is loaded, try to unfold this, + ;; i.e. rewrite it to (let () ). We'd do it in the optimizer + ;; anyway, but doing it here (i.e. earlier) can sometimes avoid the + ;; creation of a closure, thus resulting in much better code. + (let ((newform (macroexp--unfold-lambda form))) + (if (eq newform form) + ;; Unfolding failed for some reason, avoid infinite recursion. + (macroexp--cons (macroexp--all-forms fun 2) + (macroexp--all-forms args) + form) + (macroexp--expand-all newform)))) + (`(funcall ,exp . ,args) + (let ((eexp (macroexp--expand-all exp)) + (eargs (macroexp--all-forms args))) + ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' + ;; has a compiler-macro, or to unfold it. + (pcase eexp + ((and `#',f + (guard (not (or (special-form-p f) (macrop f))))) ;; bug#46636 + (macroexp--expand-all `(,f . ,eargs))) + (_ `(funcall ,eexp . ,eargs))))) + (`(funcall . ,_) form) ;bug#53227 + (`(,func . ,_) + (let ((handler (function-get func 'compiler-macro)) + (funargs (function-get func 'funarg-positions))) + ;; Check functions quoted with ' rather than with #' + (dolist (funarg funargs) + (let ((arg (nth funarg form))) + (when (and (eq 'quote (car-safe arg)) + (eq 'lambda (car-safe (cadr arg)))) + (setcar (nthcdr funarg form) + (macroexp-warn-and-return + (format "%S quoted with ' rather than with #'" + (let ((f (cadr arg))) + (if (symbolp f) f `(lambda ,(nth 1 f) ...)))) + arg nil nil (cadr arg)))))) + ;; Macro expand compiler macros. This cannot be delayed to + ;; byte-optimize-form because the output of the compiler-macro can + ;; use macros. + (if (null handler) + ;; No compiler macro. We just expand each argument (for + ;; setq/setq-default this works alright because the variable names + ;; are symbols). + (macroexp--all-forms form 1) + ;; If the handler is not loaded yet, try (auto)loading the + ;; function itself, which may in turn load the handler. + (unless (functionp handler) + (with-demoted-errors "macroexp--expand-all: %S" + (autoload-do-load (indirect-function func) func))) + (let ((newform (macroexp--compiler-macro handler form))) + (if (eq form newform) + ;; The compiler macro did not find anything to do. + (if (equal form (setq newform (macroexp--all-forms form 1))) + form + ;; Maybe after processing the args, some new opportunities + ;; appeared, so let's try the compiler macro again. + (setq form (macroexp--compiler-macro handler newform)) + (if (eq newform form) + newform + (macroexp--expand-all newform))) + (macroexp--expand-all newform)))))) + (_ form)))) (pop byte-compile-form-stack))) ;; Record which arguments expect functions, so we can warn when those -- cgit v1.2.3 From 2c0a01ee389944d95034ef673ff0255d99ef4b80 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 23 Apr 2022 14:47:55 +0200 Subject: Don't make a header if the user hasn't specified columns in vtable * lisp/emacs-lisp/vtable.el (vtable): (make-vtable): Store whether the user has specified the columns. (vtable-insert): Don't insert a header line or a header if the user hasn't specified the columns (bug#55075). --- lisp/emacs-lisp/vtable.el | 66 ++++++++++++++++++++++++++--------------------- 1 file changed, 36 insertions(+), 30 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index 7148844b638..61265c97c28 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -68,7 +68,8 @@ (row-colors :initarg :row-colors :accessor vtable-row-colors) (-cached-colors :initform nil) (-cache :initform (make-hash-table :test #'equal)) - (-cached-keymap :initform nil)) + (-cached-keymap :initform nil) + (-has-column-spec :initform nil)) "An object to hold the data for a table.") (defvar-keymap vtable-map @@ -106,29 +107,11 @@ be inserted. See info node `(vtable)Top' for vtable documentation." (when objects-function (setq objects (funcall objects-function))) - ;; Auto-generate the columns. - (unless columns - (unless objects - (error "Can't auto-generate columns; no objects")) - (setf columns (make-list (length (car objects)) ""))) - (setq columns (mapcar (lambda (column) - (cond - ;; We just have the name (as a string). - ((stringp column) - (make-vtable-column :name column)) - ;; A plist of keywords/values. - ((listp column) - (apply #'make-vtable-column column)) - ;; A full `vtable-column' object. - (t - column))) - columns)) ;; We'll be altering the list, so create a copy. (setq objects (copy-sequence objects)) (let ((table (make-instance 'vtable - :columns columns :objects objects :objects-function objects-function :getter getter @@ -143,6 +126,26 @@ See info node `(vtable)Top' for vtable documentation." :row-colors row-colors :column-colors column-colors :ellipsis ellipsis))) + ;; Store whether the user has specified columns or not. + (setf (slot-value table '-has-column-spec) (not (not columns))) + ;; Auto-generate the columns. + (unless columns + (unless objects + (error "Can't auto-generate columns; no objects")) + (setq columns (make-list (length (car objects)) ""))) + (setf (vtable-columns table) + (mapcar (lambda (column) + (cond + ;; We just have the name (as a string). + ((stringp column) + (make-vtable-column :name column)) + ;; A plist of keywords/values. + ((listp column) + (apply #'make-vtable-column column)) + ;; A full `vtable-column' object. + (t + column))) + columns)) ;; Compute missing column data. (setf (vtable-columns table) (vtable--compute-columns table)) ;; Compute the colors. @@ -446,17 +449,20 @@ This also updates the displayed table." ;; correctly if Emacs is open on two different screens (or the ;; user resizes the frame). (widths (nth 1 (vtable--ensure-cache table)))) - (if (vtable-use-header-line table) - (vtable--set-header-line table widths spacer) - ;; Insert the header line directly into the buffer, and put a - ;; keymap to be able to sort the columns there (by clicking on - ;; them). - (vtable--insert-header-line table widths spacer) - (add-text-properties start (point) - (list 'keymap vtable-header-line-map - 'rear-nonsticky t - 'vtable table)) - (setq start (point))) + ;; Don't insert any header or header line if the user hasn't + ;; specified the columns. + (when (slot-value table '-has-column-spec) + (if (vtable-use-header-line table) + (vtable--set-header-line table widths spacer) + ;; Insert the header line directly into the buffer, and put a + ;; keymap to be able to sort the columns there (by clicking on + ;; them). + (vtable--insert-header-line table widths spacer) + (add-text-properties start (point) + (list 'keymap vtable-header-line-map + 'rear-nonsticky t + 'vtable table)) + (setq start (point)))) (vtable--sort table) ;; Insert the data. (let ((line-number 0)) -- cgit v1.2.3 From 0a151b7c29c46ae67ae92d0960e199ae84b3a48b Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 25 Apr 2022 15:41:04 -0400 Subject: cl-generic.el: Upcase formal args in `C-h o` Try and improve the display of methods in `C-h o` by moving the qualifiers to a separate line and upcasing the formal args. It still needs love, tho. * lisp/emacs-lisp/cl-generic.el: Upcase formal args in `C-h o` (cl--generic-upcase-formal-args): New function. (cl--generic-describe): Use it. --- lisp/emacs-lisp/cl-generic.el | 35 +++++++++++++++++++++++++++-------- 1 file changed, 27 insertions(+), 8 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 179310c145b..200af057cd7 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -1078,6 +1078,19 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (setq combined-args (append (nreverse combined-args) args)) (list qual-string combined-args doconly))) +(defun cl--generic-upcase-formal-args (args) + (mapcar (lambda (arg) + (cond + ((symbolp arg) + (let ((name (symbol-name arg))) + (if (eq ?& (aref name 0)) arg + (intern (upcase name))))) + ((consp arg) + (cons (intern (upcase (symbol-name (car arg)))) + (cdr arg))) + (t arg))) + args)) + (add-hook 'help-fns-describe-function-functions #'cl--generic-describe) (defun cl--generic-describe (function) ;; Supposedly this is called from help-fns, so help-fns should be loaded at @@ -1094,14 +1107,20 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (insert (propertize "Implementations:\n\n" 'face 'bold)) ;; Loop over fanciful generics (dolist (method (cl--generic-method-table generic)) - (let* ((info (cl--generic-method-info method))) + (pcase-let* + ((`(,qualifiers ,args ,doc) (cl--generic-method-info method))) ;; FIXME: Add hyperlinks for the types as well. - (let ((print-quoted nil)) - (if (length> (nth 0 info) 0) - (insert (format "%s%S" (nth 0 info) (nth 1 info))) - ;; Make the non-":extra" bits look more like `C-h f' - ;; output. - (insert (format "%S" (cons function (nth 1 info)))))) + (let ((print-quoted nil) + (quals (if (length> qualifiers 0) + (concat (substring qualifiers + 0 (string-match " *\\'" + qualifiers)) + "\n") + ""))) + (insert (format "%s%S" + quals + (cons function + (cl--generic-upcase-formal-args args))))) (let* ((met-name (cl--generic-load-hist-format function (cl--generic-method-qualifiers method) @@ -1113,7 +1132,7 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." 'help-function-def met-name file 'cl-defmethod) (insert (substitute-command-keys "'.\n")))) - (insert "\n" (or (nth 2 info) "Undocumented") "\n\n"))))))) + (insert "\n" (or doc "Undocumented") "\n\n"))))))) (defun cl--generic-specializers-apply-to-type-p (specializers type) "Return non-nil if a method with SPECIALIZERS applies to TYPE." -- cgit v1.2.3 From 756b7cf5d9a817503437b3e8a9e8d912b7ee6c75 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 26 Apr 2022 15:32:45 +0200 Subject: Mention caveats in the map-delete doc string * lisp/emacs-lisp/map.el (map-delete): Mention how this has to be used for lists (bug#25929). --- lisp/emacs-lisp/map.el | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index c53f253f87f..8c67d7c7a25 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -175,7 +175,17 @@ MAP can be an alist, plist, hash-table, or array." (cl-defgeneric map-delete (map key) "Delete KEY in-place from MAP and return MAP. -Keys not present in MAP are ignored.") +Keys not present in MAP are ignored. + +Note that if MAP is a list (either alist or plist), and you're +deleting the final element in the list, the list isn't actually +destructively modified (but the return value will reflect the +deletion). So if you're using this method on a list, you have to +say + + (setq map (map-delete map key)) + +for this to work reliably.") (cl-defmethod map-delete ((map list) key) ;; FIXME: Signal map-not-inplace i.s.o returning a different list? -- cgit v1.2.3 From 21112e3683dd7c1f88028bac4b1835204b8e30f8 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 26 Apr 2022 17:30:29 -0400 Subject: Pretty print OClosure slot accessors * lisp/emacs-lisp/oclosure.el (oclosure--accessor-cl-print): New function. * lisp/emacs-lisp/cl-print.el (cl-print-object) : New method. * test/lisp/emacs-lisp/nadvice-tests.el (advice-test-call-interactively): Avoid `defun` within a function. --- lisp/emacs-lisp/cl-print.el | 6 ++++++ lisp/emacs-lisp/oclosure.el | 7 +++++++ test/lisp/emacs-lisp/nadvice-tests.el | 8 ++++---- 3 files changed, 17 insertions(+), 4 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index 2aade140e25..eaf2532da39 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -242,6 +242,12 @@ into a button whose action shows the function's disassembly.") (cl-print-object props stream))) (princ ")" stream))) +;; This belongs in oclosure.el, of course, but some load-ordering issues make it +;; complicated. +(cl-defmethod cl-print-object ((object accessor) stream) + ;; FIXME: η-reduce! + (oclosure--accessor-cl-print object stream)) + (cl-defmethod cl-print-object ((object cl-structure-object) stream) (if (and cl-print--depth (natnump print-level) (> cl-print--depth print-level)) diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index 90811199f25..cb8c59b05a2 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -505,6 +505,13 @@ This has 2 uses: "OClosure function to access a specific slot of an object." type slot) +(defun oclosure--accessor-cl-print (object stream) + (princ "#f(accessor " stream) + (prin1 (accessor--type object) stream) + (princ "." stream) + (prin1 (accessor--slot object) stream) + (princ ")" stream)) + (defun oclosure--accessor-docstring (f) ;; This would like to be a (cl-defmethod function-documentation ...) ;; but for circularity reason the defmethod is in `simple.el'. diff --git a/test/lisp/emacs-lisp/nadvice-tests.el b/test/lisp/emacs-lisp/nadvice-tests.el index f21624cfd87..1185bee447b 100644 --- a/test/lisp/emacs-lisp/nadvice-tests.el +++ b/test/lisp/emacs-lisp/nadvice-tests.el @@ -153,13 +153,13 @@ function being an around advice." (ert-deftest advice-test-call-interactively () "Check interaction between advice on call-interactively and called-interactively-p." - (defun sm-test7.4 () (interactive) (cons 1 (called-interactively-p))) - (let ((old (symbol-function 'call-interactively))) + (let ((sm-test7.4 (lambda () (interactive) (cons 1 (called-interactively-p)))) + (old (symbol-function 'call-interactively))) (unwind-protect (progn (advice-add 'call-interactively :before #'ignore) - (should (equal (sm-test7.4) '(1 . nil))) - (should (equal (call-interactively 'sm-test7.4) '(1 . t)))) + (should (equal (funcall sm-test7.4) '(1 . nil))) + (should (equal (call-interactively sm-test7.4) '(1 . t)))) (advice-remove 'call-interactively #'ignore) (should (eq (symbol-function 'call-interactively) old))))) -- cgit v1.2.3 From 4dba7c31a225950198482fe1eb558aac7a36d964 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 26 Apr 2022 17:31:13 -0400 Subject: Use `advice--cd*r` where applicable * lisp/emacs-lisp/bytecomp.el (byte-compile--function-signature): * lisp/emacs-lisp/advice.el (ad-get-orig-definition): * lisp/help.el (help-function-arglist): Use `advice--cd*r`. --- lisp/emacs-lisp/advice.el | 3 +-- lisp/emacs-lisp/bytecomp.el | 2 +- lisp/help.el | 2 +- 3 files changed, 3 insertions(+), 4 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 8e43ae68072..86a42b208e7 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -1814,8 +1814,7 @@ Redefining advices affect the construction of an advised definition." (if (symbolp function) (setq function (if (fboundp function) (advice--strip-macro (symbol-function function))))) - (while (advice--p function) (setq function (advice--cdr function))) - function) + (advice--cd*r function)) (defun ad-clear-advicefunname-definition (function) (let ((advicefunname (ad-get-advice-info-field function 'advicefunname))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 28237d67d29..c0dffe544cf 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1439,7 +1439,7 @@ when printing the error message." (and (eq 'macro (car-safe f)) (setq f (cdr f))) ;; Advice wrappers have "catch all" args, so fetch the actual underlying ;; function to find the real arguments. - (while (advice--p f) (setq f (advice--cdr f))) + (setq f (advice--cd*r f)) (if (eq (car-safe f) 'declared) (byte-compile-arglist-signature (nth 1 f)) (condition-case nil diff --git a/lisp/help.el b/lisp/help.el index c5de59d6bc7..2d08ceb86c7 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -2039,7 +2039,7 @@ the same names as used in the original source code, when possible." (if (and (symbolp def) (fboundp def)) (setq def (indirect-function def))) ;; Advice wrappers have "catch all" args, so fetch the actual underlying ;; function to find the real arguments. - (while (advice--p def) (setq def (advice--cdr def))) + (setq def (advice--cd*r def)) ;; If definition is a macro, find the function inside it. (if (eq (car-safe def) 'macro) (setq def (cdr def))) (cond -- cgit v1.2.3 From bc9be5449e1127bc1b05a6cad8471c6eba52c8e9 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 26 Apr 2022 16:28:54 -0400 Subject: nadvice.el: Rename "where" to "how" * lisp/emacs-lisp/nadvice.el (advice--how-alist): Rename from `advice--where-alist`. (advice--how): Rename from `advice--where` and keep obsolete alias. (add-function, advice-add): Rename `where` arg to `how`. * lisp/emacs-lisp/cl-print.el (cl-print-object): Use `advice--how` name. --- lisp/emacs-lisp/cl-print.el | 4 +-- lisp/emacs-lisp/nadvice.el | 81 +++++++++++++++++++++++---------------------- 2 files changed, 43 insertions(+), 42 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index eaf2532da39..457ef506bc6 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -230,8 +230,8 @@ into a button whose action shows the function's disassembly.") (if (not (advice--p object)) (cl-call-next-method) (princ "#f(advice-wrapper " stream) - (when (fboundp 'advice--where) - (princ (advice--where object) stream) + (when (fboundp 'advice--how) + (princ (advice--how object) stream) (princ " " stream)) (cl-print-object (advice--cdr object) stream) (princ " " stream) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 77e140dda19..be6eafd1b66 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -43,7 +43,7 @@ (push (purecopy '(nadvice 1 0)) package--builtin-versions) ;;;; Lightweight advice/hook -(defvar advice--where-alist +(defvar advice--how-alist '((:around "\300\301\302\003#\207" 5) (:before "\300\301\002\"\210\300\302\002\"\207" 4) (:after "\300\302\002\"\300\301\003\"\210\207" 5) @@ -55,12 +55,12 @@ (:filter-args "\300\302\301\003!\"\207" 5) (:filter-return "\301\300\302\003\"!\207" 5)) "List of descriptions of how to add a function. -Each element has the form (WHERE BYTECODE STACK) where: - WHERE is a keyword indicating where the function is added. +Each element has the form (HOW BYTECODE STACK) where: + HOW is a keyword indicating where the function is added. BYTECODE is the corresponding byte-code that will be used. STACK is the amount of stack space needed by the byte-code.") -(defvar advice--bytecodes (mapcar #'cadr advice--where-alist)) +(defvar advice--bytecodes (mapcar #'cadr advice--how-alist)) (defun advice--p (object) (and (byte-code-function-p object) @@ -78,19 +78,20 @@ Each element has the form (WHERE BYTECODE STACK) where: (setq f (advice--cdr f))) f) -(defun advice--where (f) +(define-obsolete-function-alias 'advice--where #'advice--how "29.1") +(defun advice--how (f) (let ((bytecode (aref f 1)) - (where nil)) - (dolist (elem advice--where-alist) - (if (eq bytecode (cadr elem)) (setq where (car elem)))) - where)) + (how nil)) + (dolist (elem advice--how-alist) + (if (eq bytecode (cadr elem)) (setq how (car elem)))) + how)) (defun advice--make-single-doc (flist function macrop) - (let ((where (advice--where flist))) + (let ((how (advice--how flist))) (concat (format "This %s has %s advice: " (if macrop "macro" "function") - where) + how) (let ((fun (advice--car flist))) (if (symbolp fun) (format-message "`%S'." fun) (let* ((name (cdr (assq 'name (advice--props flist)))) @@ -192,19 +193,19 @@ Each element has the form (WHERE BYTECODE STACK) where: (when adv-sig (puthash advice adv-sig advertised-signature-table)) advice)) -(defun advice--make (where function main props) - "Build a function value that adds FUNCTION to MAIN at WHERE. -WHERE is a symbol to select an entry in `advice--where-alist'." +(defun advice--make (how function main props) + "Build a function value that adds FUNCTION to MAIN at HOW. +HOW is a symbol to select an entry in `advice--how-alist'." (let ((fd (or (cdr (assq 'depth props)) 0)) (md (if (advice--p main) (or (cdr (assq 'depth (advice--props main))) 0)))) (if (and md (> fd md)) ;; `function' should go deeper. - (let ((rest (advice--make where function (advice--cdr main) props))) + (let ((rest (advice--make how function (advice--cdr main) props))) (advice--make-1 (aref main 1) (aref main 3) (advice--car main) rest (advice--props main))) - (let ((desc (assq where advice--where-alist))) - (unless desc (error "Unknown add-function location `%S'" where)) + (let ((desc (assq how advice--how-alist))) + (unless desc (error "Unknown add-function location `%S'" how)) (advice--make-1 (nth 1 desc) (nth 2 desc) function main props))))) @@ -274,9 +275,9 @@ different, but `function-equal' will hopefully ignore those differences.") (t place)))) ;;;###autoload -(defmacro add-function (where place function &optional props) +(defmacro add-function (how place function &optional props) ;; TODO: - ;; - maybe let `where' specify some kind of predicate and use it + ;; - maybe let `how' specify some kind of predicate and use it ;; to implement things like mode-local or eieio-defmethod. ;; Of course, that only makes sense if the predicates of all advices can ;; be combined and made more efficient. @@ -285,8 +286,8 @@ different, but `function-equal' will hopefully ignore those differences.") ;; :before-until is like add-hook on run-hook-with-args-until-success. ;; Same with :after-* but for (add-hook ... 'append). "Add a piece of advice on the function stored at PLACE. -FUNCTION describes the code to add. WHERE describes where to add it. -WHERE can be explained by showing the resulting new function, as the +FUNCTION describes the code to add. HOW describes where to add it. +HOW can be explained by showing the resulting new function, as the result of combining FUNCTION and the previous value of PLACE, which we call OLDFUN here: `:before' (lambda (&rest r) (apply FUNCTION r) (apply OLDFUN r)) @@ -326,13 +327,13 @@ is also interactive. There are 3 cases: ;;(indent 2) (debug (form [&or symbolp ("local" form) ("var" sexp) gv-place] form &optional form))) - `(advice--add-function ,where (gv-ref ,(advice--normalize-place place)) + `(advice--add-function ,how (gv-ref ,(advice--normalize-place place)) ,function ,props)) (declare-function comp-subr-trampoline-install "comp") ;;;###autoload -(defun advice--add-function (where ref function props) +(defun advice--add-function (how ref function props) (when (and (featurep 'native-compile) (subr-primitive-p (gv-deref ref))) (let ((subr-name (intern (subr-name (gv-deref ref))))) @@ -357,7 +358,7 @@ is also interactive. There are 3 cases: (advice--remove-function (gv-deref ref) (or name (advice--car a))))) (setf (gv-deref ref) - (advice--make where function (gv-deref ref) props)))) + (advice--make how function (gv-deref ref) props)))) ;;;###autoload (defmacro remove-function (place function) @@ -456,7 +457,7 @@ of the piece of advice." (funcall fsetfun symbol newdef)))) ;;;###autoload -(defun advice-add (symbol where function &optional props) +(defun advice-add (symbol how function &optional props) "Like `add-function' but for the function named SYMBOL. Contrary to `add-function', this will properly handle the cases where SYMBOL is defined as a macro, alias, command, ..." @@ -467,18 +468,18 @@ is defined as a macro, alias, command, ..." (let* ((f (symbol-function symbol)) (nf (advice--normalize symbol f))) (unless (eq f nf) (fset symbol nf)) - (add-function where (cond - ((eq (car-safe nf) 'macro) (cdr nf)) - ;; Reasons to delay installation of the advice: - ;; - If the function is not yet defined, installing - ;; the advice would affect `fboundp'ness. - ;; - the symbol-function slot of an autoloaded - ;; function is not itself a function value. - ;; - `autoload' does nothing if the function is - ;; not an autoload or undefined. - ((or (not nf) (autoloadp nf)) - (get symbol 'advice--pending)) - (t (symbol-function symbol))) + (add-function how (cond + ((eq (car-safe nf) 'macro) (cdr nf)) + ;; Reasons to delay installation of the advice: + ;; - If the function is not yet defined, installing + ;; the advice would affect `fboundp'ness. + ;; - the symbol-function slot of an autoloaded + ;; function is not itself a function value. + ;; - `autoload' does nothing if the function is + ;; not an autoload or undefined. + ((or (not nf) (autoloadp nf)) + (get symbol 'advice--pending)) + (t (symbol-function symbol))) function props) ;; FIXME: We could use a defmethod on `function-docstring' instead, ;; except when (or (not nf) (autoloadp nf))! @@ -517,12 +518,12 @@ See `advice-add' and `add-function' for explanation on the arguments. Note if NAME is nil the advice is anonymous; otherwise it is named `SYMBOL@NAME'. -\(fn SYMBOL (WHERE LAMBDA-LIST &optional NAME DEPTH) &rest BODY)" +\(fn SYMBOL (HOW LAMBDA-LIST &optional NAME DEPTH) &rest BODY)" (declare (indent 2) (doc-string 3) (debug (sexp sexp def-body))) (or (listp args) (signal 'wrong-type-argument (list 'listp args))) (or (<= 2 (length args) 4) (signal 'wrong-number-of-arguments (list 2 4 (length args)))) - (let* ((where (nth 0 args)) + (let* ((how (nth 0 args)) (lambda-list (nth 1 args)) (name (nth 2 args)) (depth (nth 3 args)) @@ -532,7 +533,7 @@ otherwise it is named `SYMBOL@NAME'. (intern (format "%s@%s" symbol name))) (t (error "Unrecognized name spec `%S'" name))))) `(prog1 ,@(and (symbolp advice) `((defun ,advice ,lambda-list ,@body))) - (advice-add ',symbol ,where #',advice ,@(and props `(',props)))))) + (advice-add ',symbol ,how #',advice ,@(and props `(',props)))))) (defun advice-mapc (fun symbol) "Apply FUN to every advice function in SYMBOL. -- cgit v1.2.3 From f30625943edefbd88ebf84acbc254ed88db27beb Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 26 Apr 2022 16:39:41 -0400 Subject: nadvice.el: Use OClosures * lisp/emacs-lisp/nadvice.el (advice): New OClosure type. (advice--how-alist): Make it hold prototype OClosures rather than bytecode strings. (advice--bytecodes): Delete var. (advice--where): Make it an obsolete alias of new `advice--how`. (oclosure-interactive-form, cl-print-object) : New methods. (advice--make-1): Delete function. (advice--make): Use `advice-copy` and `advice-cons`. (advice--tweak): Use `advice-cons`. (add-function, advice-add): Rename `where` arg to `how`. * lisp/emacs-lisp/cl-print.el (cl-print-object) <:extra "nadvice">: Remove now-redundant ad-hoc method. * test/lisp/emacs-lisp/nadvice-tests.el (advice-test-print): New test. --- lisp/emacs-lisp/cl-print.el | 21 ------- lisp/emacs-lisp/nadvice.el | 108 +++++++++++++++++----------------- test/lisp/emacs-lisp/nadvice-tests.el | 9 +++ 3 files changed, 64 insertions(+), 74 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index 457ef506bc6..30d7e6525a4 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -221,27 +221,6 @@ into a button whose action shows the function's disassembly.") 'byte-code-function object))))) (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--how) - (princ (advice--how 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))) - ;; This belongs in oclosure.el, of course, but some load-ordering issues make it ;; complicated. (cl-defmethod cl-print-object ((object accessor) stream) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index be6eafd1b66..efc345c62cc 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -42,36 +42,37 @@ ;; as this one), so we have to do it by hand! (push (purecopy '(nadvice 1 0)) package--builtin-versions) +(oclosure-define (advice + (:predicate advice--p) + (:copier advice--cons (cdr)) + (:copier advice--copy (car cdr how props))) + car cdr how props) + ;;;; Lightweight advice/hook (defvar advice--how-alist - '((:around "\300\301\302\003#\207" 5) - (:before "\300\301\002\"\210\300\302\002\"\207" 4) - (:after "\300\302\002\"\300\301\003\"\210\207" 5) - (:override "\300\301\002\"\207" 4) - (:after-until "\300\302\002\"\206\013\000\300\301\002\"\207" 4) - (:after-while "\300\302\002\"\205\013\000\300\301\002\"\207" 4) - (:before-until "\300\301\002\"\206\013\000\300\302\002\"\207" 4) - (:before-while "\300\301\002\"\205\013\000\300\302\002\"\207" 4) - (:filter-args "\300\302\301\003!\"\207" 5) - (:filter-return "\301\300\302\003\"!\207" 5)) + `((:around ,(oclosure-lambda (advice (how :around)) (&rest args) + (apply car cdr args))) + (:before ,(oclosure-lambda (advice (how :before)) (&rest args) + (apply car args) (apply cdr args))) + (:after ,(oclosure-lambda (advice (how :after)) (&rest args) + (apply cdr args) (apply car args))) + (:override ,(oclosure-lambda (advice (how :override)) (&rest args) + (apply car args))) + (:after-until ,(oclosure-lambda (advice (how :after-until)) (&rest args) + (or (apply cdr args) (apply car args)))) + (:after-while ,(oclosure-lambda (advice (how :after-while)) (&rest args) + (and (apply cdr args) (apply car args)))) + (:before-until ,(oclosure-lambda (advice (how :before-until)) (&rest args) + (or (apply car args) (apply cdr args)))) + (:before-while ,(oclosure-lambda (advice (how :before-while)) (&rest args) + (and (apply car args) (apply cdr args)))) + (:filter-args ,(oclosure-lambda (advice (how :filter-args)) (&rest args) + (apply cdr (funcall car args)))) + (:filter-return ,(oclosure-lambda (advice (how :filter-return)) (&rest args) + (funcall car (apply cdr args))))) "List of descriptions of how to add a function. -Each element has the form (HOW BYTECODE STACK) where: - HOW is a keyword indicating where the function is added. - BYTECODE is the corresponding byte-code that will be used. - STACK is the amount of stack space needed by the byte-code.") - -(defvar advice--bytecodes (mapcar #'cadr advice--how-alist)) - -(defun advice--p (object) - (and (byte-code-function-p object) - (eq 128 (aref object 0)) - (memq (length object) '(5 6)) - (memq (aref object 1) advice--bytecodes) - (eq #'apply (aref (aref object 2) 0)))) - -(defsubst advice--car (f) (aref (aref f 2) 1)) -(defsubst advice--cdr (f) (aref (aref f 2) 2)) -(defsubst advice--props (f) (aref (aref f 2) 3)) +Each element has the form (HOW OCL) where HOW is a keyword and +OCL is a \"prototype\" function of type `advice'.") (defun advice--cd*r (f) (while (advice--p f) @@ -79,12 +80,6 @@ Each element has the form (HOW BYTECODE STACK) where: f) (define-obsolete-function-alias 'advice--where #'advice--how "29.1") -(defun advice--how (f) - (let ((bytecode (aref f 1)) - (how nil)) - (dolist (elem advice--how-alist) - (if (eq bytecode (cadr elem)) (setq how (car elem)))) - how)) (defun advice--make-single-doc (flist function macrop) (let ((how (advice--how flist))) @@ -181,17 +176,26 @@ Each element has the form (HOW BYTECODE STACK) where: `(funcall ',fspec ',(cadr ifm)) (cadr (or iff ifm))))) -(defun advice--make-1 (byte-code stack-depth function main props) - "Build a function value that adds FUNCTION to MAIN." - (let ((adv-sig (gethash main advertised-signature-table)) - (advice - (apply #'make-byte-code 128 byte-code - (vector #'apply function main props) stack-depth nil - (and (or (commandp function) (commandp main)) - (list (advice--make-interactive-form - function main)))))) - (when adv-sig (puthash advice adv-sig advertised-signature-table)) - advice)) + +(cl-defmethod oclosure-interactive-form ((ad advice) &optional _) + (let ((car (advice--car ad)) + (cdr (advice--cdr ad))) + (when (or (commandp car) (commandp cdr)) + `(interactive ,(advice--make-interactive-form car cdr))))) + +(cl-defmethod cl-print-object ((object advice) stream) + (cl-assert (advice--p object)) + (princ "#f(advice " stream) + (cl-print-object (advice--car object) stream) + (princ " " stream) + (princ (advice--how object) stream) + (princ " " stream) + (cl-print-object (advice--cdr object) stream) + (let ((props (advice--props object))) + (when props + (princ " " stream) + (cl-print-object props stream))) + (princ ")" stream)) (defun advice--make (how function main props) "Build a function value that adds FUNCTION to MAIN at HOW. @@ -202,12 +206,11 @@ HOW is a symbol to select an entry in `advice--how-alist'." (if (and md (> fd md)) ;; `function' should go deeper. (let ((rest (advice--make how function (advice--cdr main) props))) - (advice--make-1 (aref main 1) (aref main 3) - (advice--car main) rest (advice--props main))) - (let ((desc (assq how advice--how-alist))) - (unless desc (error "Unknown add-function location `%S'" how)) - (advice--make-1 (nth 1 desc) (nth 2 desc) - function main props))))) + (advice--cons main rest)) + (let ((proto (assq how advice--how-alist))) + (unless proto (error "Unknown add-function location `%S'" how)) + (advice--copy (cadr proto) + function main how props))))) (defun advice--member-p (function use-name definition) (let ((found nil)) @@ -233,8 +236,7 @@ HOW is a symbol to select an entry in `advice--how-alist'." (if val (car val) (let ((nrest (advice--tweak rest tweaker))) (if (eq rest nrest) flist - (advice--make-1 (aref flist 1) (aref flist 3) - first nrest props)))))))) + (advice--cons flist nrest)))))))) ;;;###autoload (defun advice--remove-function (flist function) @@ -286,7 +288,7 @@ different, but `function-equal' will hopefully ignore those differences.") ;; :before-until is like add-hook on run-hook-with-args-until-success. ;; Same with :after-* but for (add-hook ... 'append). "Add a piece of advice on the function stored at PLACE. -FUNCTION describes the code to add. HOW describes where to add it. +FUNCTION describes the code to add. HOW describes how to add it. HOW can be explained by showing the resulting new function, as the result of combining FUNCTION and the previous value of PLACE, which we call OLDFUN here: diff --git a/test/lisp/emacs-lisp/nadvice-tests.el b/test/lisp/emacs-lisp/nadvice-tests.el index 1185bee447b..a675986b90b 100644 --- a/test/lisp/emacs-lisp/nadvice-tests.el +++ b/test/lisp/emacs-lisp/nadvice-tests.el @@ -204,6 +204,15 @@ function being an around advice." (remove-function (var sm-test10) sm-advice) (should (equal (funcall sm-test10 5) 15)))) +(ert-deftest advice-test-print () + (let ((x (list 'cdr))) + (add-function :after (car x) 'car) + (should (equal (cl-prin1-to-string (car x)) + "#f(advice car :after cdr)")) + (add-function :before (car x) 'first) + (should (equal (cl-prin1-to-string (car x)) + "#f(advice first :before #f(advice car :after cdr))")))) + ;; Local Variables: ;; no-byte-compile: t ;; End: -- cgit v1.2.3 From 92e49944a39ce6372a80430f65913c4c8b531677 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 26 Apr 2022 17:09:03 -0400 Subject: nadvice.el: Auto-generate the doc describing the "how" arg * lisp/emacs-lisp/nadvice.el (advice--make-how-alist): New macro. (advice--how-alist): Use it. (nadvice--make-docstring): New function. (add-function, advice-add): Use it to auto-generate the table describing the accepted values for `how`. --- lisp/emacs-lisp/nadvice.el | 97 ++++++++++++++++++++++++++++++---------------- 1 file changed, 63 insertions(+), 34 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index efc345c62cc..b3778c07bc0 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -48,31 +48,41 @@ (:copier advice--copy (car cdr how props))) car cdr how props) +(eval-when-compile + (defmacro advice--make-how-alist (&rest args) + `(list + ,@(mapcar + (lambda (arg) + (pcase-let ((`(,how . ,body) arg)) + `(list ,how + (oclosure-lambda (advice (how ,how)) (&rest r) + ,@body) + ,(replace-regexp-in-string + "\\" "FUNCTION" + (replace-regexp-in-string + "\\" "OLDFUN" + (format "%S" `(lambda (&rest r) ,@body)) + t t) + t t)))) + args)))) + ;;;; Lightweight advice/hook (defvar advice--how-alist - `((:around ,(oclosure-lambda (advice (how :around)) (&rest args) - (apply car cdr args))) - (:before ,(oclosure-lambda (advice (how :before)) (&rest args) - (apply car args) (apply cdr args))) - (:after ,(oclosure-lambda (advice (how :after)) (&rest args) - (apply cdr args) (apply car args))) - (:override ,(oclosure-lambda (advice (how :override)) (&rest args) - (apply car args))) - (:after-until ,(oclosure-lambda (advice (how :after-until)) (&rest args) - (or (apply cdr args) (apply car args)))) - (:after-while ,(oclosure-lambda (advice (how :after-while)) (&rest args) - (and (apply cdr args) (apply car args)))) - (:before-until ,(oclosure-lambda (advice (how :before-until)) (&rest args) - (or (apply car args) (apply cdr args)))) - (:before-while ,(oclosure-lambda (advice (how :before-while)) (&rest args) - (and (apply car args) (apply cdr args)))) - (:filter-args ,(oclosure-lambda (advice (how :filter-args)) (&rest args) - (apply cdr (funcall car args)))) - (:filter-return ,(oclosure-lambda (advice (how :filter-return)) (&rest args) - (funcall car (apply cdr args))))) + (advice--make-how-alist + (:around (apply car cdr r)) + (:before (apply car r) (apply cdr r)) + (:after (apply cdr r) (apply car r)) + (:override (apply car r)) + (:after-until (or (apply cdr r) (apply car r))) + (:after-while (and (apply cdr r) (apply car r))) + (:before-until (or (apply car r) (apply cdr r))) + (:before-while (and (apply car r) (apply cdr r))) + (:filter-args (apply cdr (funcall car r))) + (:filter-return (funcall car (apply cdr r)))) "List of descriptions of how to add a function. -Each element has the form (HOW OCL) where HOW is a keyword and -OCL is a \"prototype\" function of type `advice'.") +Each element has the form (HOW OCL DOC) where HOW is a keyword, +OCL is a \"prototype\" function of type `advice', and +DOC is a string where \"FUNCTION\" and \"OLDFUN\" are expected.") (defun advice--cd*r (f) (while (advice--p f) @@ -276,6 +286,29 @@ different, but `function-equal' will hopefully ignore those differences.") ((symbolp place) `(default-value ',place)) (t place)))) +(defun nadvice--make-docstring (sym) + (let* ((main (documentation (symbol-function sym) 'raw)) + (ud (help-split-fundoc main 'pcase)) + (doc (or (cdr ud) main)) + (col1width (apply #'max (mapcar (lambda (x) + (string-width (symbol-name (car x)))) + advice--how-alist))) + (table (mapconcat (lambda (x) + (format (format " %%-%ds %%s" col1width) + (car x) (nth 2 x))) + advice--how-alist "\n")) + (table (if global-prettify-symbols-mode + (replace-regexp-in-string "(lambda\\>" "(λ" table t t) + table)) + (combined-doc + (if (not (string-match "<<>>" doc)) + doc + (replace-match table t t doc)))) + (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc))) + +(put 'add-function 'function-documentation + '(nadvice--make-docstring 'add-function)) + ;;;###autoload (defmacro add-function (how place function &optional props) ;; TODO: @@ -292,16 +325,7 @@ FUNCTION describes the code to add. HOW describes how to add it. HOW can be explained by showing the resulting new function, as the result of combining FUNCTION and the previous value of PLACE, which we call OLDFUN here: -`:before' (lambda (&rest r) (apply FUNCTION r) (apply OLDFUN r)) -`:after' (lambda (&rest r) (prog1 (apply OLDFUN r) (apply FUNCTION r))) -`:around' (lambda (&rest r) (apply FUNCTION OLDFUN r)) -`:override' (lambda (&rest r) (apply FUNCTION r)) -`:before-while' (lambda (&rest r) (and (apply FUNCTION r) (apply OLDFUN r))) -`:before-until' (lambda (&rest r) (or (apply FUNCTION r) (apply OLDFUN r))) -`:after-while' (lambda (&rest r) (and (apply OLDFUN r) (apply FUNCTION r))) -`:after-until' (lambda (&rest r) (or (apply OLDFUN r) (apply FUNCTION r))) -`:filter-args' (lambda (&rest r) (apply OLDFUN (funcall FUNCTION r))) -`:filter-return'(lambda (&rest r) (funcall FUNCTION (apply OLDFUN r))) +<<>> If FUNCTION was already added, do nothing. PROPS is an alist of additional properties, among which the following have a special meaning: @@ -458,11 +482,16 @@ of the piece of advice." (put symbol 'advice--pending (advice--subst-main oldadv nil))) (funcall fsetfun symbol newdef)))) +(put 'advice-add 'function-documentation + '(nadvice--make-docstring 'advice-add)) + ;;;###autoload (defun advice-add (symbol how function &optional props) "Like `add-function' but for the function named SYMBOL. Contrary to `add-function', this will properly handle the cases where SYMBOL -is defined as a macro, alias, command, ..." +is defined as a macro, alias, command, ... +HOW can be one of: +<<>>" ;; TODO: ;; - record the advice location, to display in describe-function. ;; - change all defadvice in lisp/**/*.el. @@ -483,7 +512,7 @@ is defined as a macro, alias, command, ..." (get symbol 'advice--pending)) (t (symbol-function symbol))) function props) - ;; FIXME: We could use a defmethod on `function-docstring' instead, + ;; FIXME: We could use a defmethod on `function-documentation' instead, ;; except when (or (not nf) (autoloadp nf))! (put symbol 'function-documentation `(advice--make-docstring ',symbol)) (add-function :around (get symbol 'defalias-fset-function) -- cgit v1.2.3 From 799c7e277fc6a37bd8b86fea7494ff6df63f3eb1 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 28 Apr 2022 09:38:58 -0400 Subject: * lisp/emacs-lisp/nadvice.el: Fix bug#55149 --- lisp/emacs-lisp/nadvice.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index b3778c07bc0..b20415a2d3b 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -71,7 +71,7 @@ (advice--make-how-alist (:around (apply car cdr r)) (:before (apply car r) (apply cdr r)) - (:after (apply cdr r) (apply car r)) + (:after (prog1 (apply cdr r) (apply car r))) (:override (apply car r)) (:after-until (or (apply cdr r) (apply car r))) (:after-while (and (apply cdr r) (apply car r))) -- cgit v1.2.3 From acc985ae7cab66ceb4e81ab403e39e933e851d9e Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 29 Apr 2022 15:29:35 -0400 Subject: CL types: Accept both `byte-code-function` and `compiled-function` `type-of` returns `compiled-function` for bytecode functions, but the predicate for those objects is called `byte-code-function-p`, So accept both `compiled-function` and `byte-code-function` as type names for those objects. * lisp/emacs-lisp/cl-preloaded.el (cl--typeof-types): Add `byte-code-function`. * lisp/emacs-lisp/cl-macs.el (byte-code-function, compiled-function, subr): New types. --- lisp/emacs-lisp/cl-macs.el | 3 +++ lisp/emacs-lisp/cl-preloaded.el | 12 +++++++++++- lisp/emacs-lisp/nadvice.el | 2 +- 3 files changed, 15 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index c2f8c4d009c..a9d422929f1 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3403,9 +3403,11 @@ Of course, we really can't know that for sure, so it's just a heuristic." (boolean . booleanp) (bool-vector . bool-vector-p) (buffer . bufferp) + (byte-code-function . byte-code-function-p) (character . natnump) (char-table . char-table-p) (command . commandp) + (compiled-function . byte-code-function-p) (hash-table . hash-table-p) (cons . consp) (fixnum . fixnump) @@ -3419,6 +3421,7 @@ Of course, we really can't know that for sure, so it's just a heuristic." (null . null) (real . numberp) (sequence . sequencep) + (subr . subrp) (string . stringp) (symbol . symbolp) (vector . vectorp) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 93713f506d2..ab7c56c4e00 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -59,7 +59,17 @@ ;; accepted, pretty much. (marker number-or-marker atom) (overlay atom) (float number atom) (window-configuration atom) - (process atom) (window atom) (subr atom) (compiled-function function atom) + (process atom) (window atom) + ;; FIXME: We'd want to put `function' here, but that's only true + ;; for those `subr's which aren't special forms! + (subr atom) + ;; FIXME: We should probably reverse the order between + ;; `compiled-function' and `byte-code-function' since arguably + ;; `subr' and also "compiled functions" but not "byte code functions", + ;; but it would require changing the value returned by `type-of' for + ;; byte code objects, which risks breaking existing code, which doesn't + ;; seem worth the trouble. + (compiled-function byte-code-function function atom) (module-function function atom) (buffer atom) (char-table array sequence atom) (bool-vector array sequence atom) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index b20415a2d3b..00c9e5438b8 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -513,7 +513,7 @@ HOW can be one of: (t (symbol-function symbol))) function props) ;; FIXME: We could use a defmethod on `function-documentation' instead, - ;; except when (or (not nf) (autoloadp nf))! + ;; except when (autoloadp nf)! (put symbol 'function-documentation `(advice--make-docstring ',symbol)) (add-function :around (get symbol 'defalias-fset-function) #'advice--defalias-fset)) -- cgit v1.2.3 From 73088b30cf5447c7aa459437c2f521ea9b443b0c Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 29 Apr 2022 22:13:20 -0400 Subject: * lisp/emacs-lisp/cl-preloaded.el (cl--typeof-types): Add `symbol-with-pos` --- lisp/emacs-lisp/cl-preloaded.el | 2 +- src/data.c | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index ab7c56c4e00..2b32bc4844a 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -53,7 +53,7 @@ (defconst cl--typeof-types ;; Hand made from the source code of `type-of'. '((integer number number-or-marker atom) - (symbol atom) (string array sequence atom) + (symbol-with-pos symbol atom) (symbol atom) (string array sequence atom) (cons list sequence) ;; Markers aren't `numberp', yet they are accepted wherever integers are ;; accepted, pretty much. diff --git a/src/data.c b/src/data.c index 0347ff363c1..72dcf6f878d 100644 --- a/src/data.c +++ b/src/data.c @@ -211,6 +211,7 @@ for example, (type-of 1) returns `integer'. */) return Qcons; case Lisp_Vectorlike: + /* WARNING!! Keep 'cl--typeof-types' in sync with this code!! */ switch (PSEUDOVECTOR_TYPE (XVECTOR (object))) { case PVEC_NORMAL_VECTOR: return Qvector; -- cgit v1.2.3 From 08108a856a544a80d11b1e9e437fe6c45e25adec Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 29 Apr 2022 22:18:09 -0400 Subject: debug-early: Print bytecode in a more manageable way * lisp/emacs-lisp/debug-early.el (debug-early-backtrace): Escape newlines to and bytecodes to make backtraces slightly more readable. Use `cl-prin1` when available. --- lisp/emacs-lisp/debug-early.el | 44 +++++++++++++++++++++++------------------- 1 file changed, 24 insertions(+), 20 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/debug-early.el b/lisp/emacs-lisp/debug-early.el index 85ed5f2176c..4f1f4b81557 100644 --- a/lisp/emacs-lisp/debug-early.el +++ b/lisp/emacs-lisp/debug-early.el @@ -35,30 +35,34 @@ (defalias 'debug-early-backtrace #'(lambda () - "Print a trace of Lisp function calls currently active. + "Print a trace of Lisp function calls currently active. The output stream used is the value of `standard-output'. This is a simplified version of the standard `backtrace' function, intended for use in debugging the early parts of the build process." - (princ "\n") - (mapbacktrace - #'(lambda (evald func args _flags) - (let ((args args)) - (if evald - (progn - (princ " ") - (prin1 func) - (princ "(")) - (progn - (princ " (") - (setq args (cons func args)))) - (if args - (while (progn - (prin1 (car args)) - (setq args (cdr args))) - (princ " "))) - (princ ")\n")))))) + (princ "\n") + (let ((print-escape-newlines t) + (print-escape-control-characters t) + (print-escape-nonascii t) + (prin1 (if (fboundp 'cl-prin1) #'cl-prin1 #'prin1))) + (mapbacktrace + #'(lambda (evald func args _flags) + (let ((args args)) + (if evald + (progn + (princ " ") + (funcall prin1 func) + (princ "(")) + (progn + (princ " (") + (setq args (cons func args)))) + (if args + (while (progn + (funcall prin1 (car args)) + (setq args (cdr args))) + (princ " "))) + (princ ")\n"))))))) (defalias 'debug-early #'(lambda (&rest args) @@ -76,7 +80,7 @@ superseded by `debug' after enough Lisp has been loaded to support the latter, except in batch mode which always uses `debug-early'. -(In versions of Emacs prior to Emacs 29, no backtrace was +\(In versions of Emacs prior to Emacs 29, no backtrace was available before `debug' was usable.)" (princ "\nError: ") (prin1 (car (car (cdr args)))) ; The error symbol. -- cgit v1.2.3 From b05a103ea7a26b2f4099a613015d9f1abdc39a4d Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 30 Apr 2022 16:42:44 +0200 Subject: Move the when-let family of macros to subr.el * lisp/subr.el (internal--build-binding) (internal--build-bindings): Moved from subr-x.el and rewritten to not use the threading macro. (if-let*, when-let*, and-let*, if-let, when-let): Moved from subr-x.el. This avoids breaking the build every time somebody uses these macros in functions that end up being called during bootstrap. --- lisp/emacs-lisp/subr-x.el | 110 ---------------------------------------------- lisp/subr.el | 96 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 96 insertions(+), 110 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index abf85ab6c67..6c763bd04d9 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -81,116 +81,6 @@ Note how the single `-' got converted into a list before threading." (declare (indent 0) (debug thread-first)) `(internal--thread-argument nil ,@forms)) - -(defsubst internal--listify (elt) - "Wrap ELT in a list if it is not one. -If ELT is of the form ((EXPR)), listify (EXPR) with a dummy symbol." - (cond - ((symbolp elt) (list elt elt)) - ((null (cdr elt)) - (list (make-symbol "s") (car elt))) - (t elt))) - -(defsubst internal--check-binding (binding) - "Check BINDING is properly formed." - (when (> (length binding) 2) - (signal - 'error - (cons "`let' bindings can have only one value-form" binding))) - binding) - -(defsubst internal--build-binding-value-form (binding prev-var) - "Build the conditional value form for BINDING using PREV-VAR." - (let ((var (car binding))) - `(,var (and ,prev-var ,(cadr binding))))) - -(defun internal--build-binding (binding prev-var) - "Check and build a single BINDING with PREV-VAR." - (thread-first - binding - internal--listify - internal--check-binding - (internal--build-binding-value-form prev-var))) - -(defun internal--build-bindings (bindings) - "Check and build conditional value forms for BINDINGS." - (let ((prev-var t)) - (mapcar (lambda (binding) - (let ((binding (internal--build-binding binding prev-var))) - (setq prev-var (car binding)) - binding)) - bindings))) - -(defmacro if-let* (varlist then &rest else) - "Bind variables according to VARLIST and evaluate THEN or ELSE. -This is like `if-let' but doesn't handle a VARLIST of the form -\(SYMBOL SOMETHING) specially." - (declare (indent 2) - (debug ((&rest [&or symbolp (symbolp form) (form)]) - body))) - (if varlist - `(let* ,(setq varlist (internal--build-bindings varlist)) - (if ,(caar (last varlist)) - ,then - ,@else)) - `(let* () ,then))) - -(defmacro when-let* (varlist &rest body) - "Bind variables according to VARLIST and conditionally evaluate BODY. -This is like `when-let' but doesn't handle a VARLIST of the form -\(SYMBOL SOMETHING) specially." - (declare (indent 1) (debug if-let*)) - (list 'if-let* varlist (macroexp-progn body))) - -(defmacro and-let* (varlist &rest body) - "Bind variables according to VARLIST and conditionally evaluate BODY. -Like `when-let*', except if BODY is empty and all the bindings -are non-nil, then the result is non-nil." - (declare (indent 1) (debug if-let*)) - (let (res) - (if varlist - `(let* ,(setq varlist (internal--build-bindings varlist)) - (when ,(setq res (caar (last varlist))) - ,@(or body `(,res)))) - `(let* () ,@(or body '(t)))))) - -;;;###autoload -(defmacro if-let (spec then &rest else) - "Bind variables according to SPEC and evaluate THEN or ELSE. -Evaluate each binding in turn, as in `let*', stopping if a -binding value is nil. If all are non-nil return the value of -THEN, otherwise the last form in ELSE. - -Each element of SPEC is a list (SYMBOL VALUEFORM) that binds -SYMBOL to the value of VALUEFORM. An element can additionally be -of the form (VALUEFORM), which is evaluated and checked for nil; -i.e. SYMBOL can be omitted if only the test result is of -interest. It can also be of the form SYMBOL, then the binding of -SYMBOL is checked for nil. - -As a special case, interprets a SPEC of the form \(SYMBOL SOMETHING) -like \((SYMBOL SOMETHING)). This exists for backward compatibility -with an old syntax that accepted only one binding." - (declare (indent 2) - (debug ([&or (symbolp form) ; must be first, Bug#48489 - (&rest [&or symbolp (symbolp form) (form)])] - body))) - (when (and (<= (length spec) 2) - (not (listp (car spec)))) - ;; Adjust the single binding case - (setq spec (list spec))) - (list 'if-let* spec then (macroexp-progn else))) - -;;;###autoload -(defmacro when-let (spec &rest body) - "Bind variables according to SPEC and conditionally evaluate BODY. -Evaluate each binding in turn, stopping if a binding value is nil. -If all are non-nil, return the value of the last form in BODY. - -The variable list SPEC is the same as in `if-let'." - (declare (indent 1) (debug if-let)) - (list 'if-let spec (macroexp-progn body))) - (defsubst hash-table-empty-p (hash-table) "Check whether HASH-TABLE is empty (has 0 elements)." (zerop (hash-table-count hash-table))) diff --git a/lisp/subr.el b/lisp/subr.el index 5fadac6e16c..d4f5d0d23bc 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -2371,6 +2371,102 @@ Affects only hooks run in the current buffer." (let ((delay-mode-hooks t)) ,@body))) +;;; `when-let' and friends. + +(defun internal--build-binding (binding prev-var) + "Check and build a single BINDING with PREV-VAR." + (setq binding + (cond + ((symbolp binding) + (list binding binding)) + ((null (cdr binding)) + (list (make-symbol "s") (car binding))) + (t binding))) + (when (> (length binding) 2) + (signal 'error + (cons "`let' bindings can have only one value-form" binding))) + (let ((var (car binding))) + `(,var (and ,prev-var ,(cadr binding))))) + +(defun internal--build-bindings (bindings) + "Check and build conditional value forms for BINDINGS." + (let ((prev-var t)) + (mapcar (lambda (binding) + (let ((binding (internal--build-binding binding prev-var))) + (setq prev-var (car binding)) + binding)) + bindings))) + +(defmacro if-let* (varlist then &rest else) + "Bind variables according to VARLIST and evaluate THEN or ELSE. +This is like `if-let' but doesn't handle a VARLIST of the form +\(SYMBOL SOMETHING) specially." + (declare (indent 2) + (debug ((&rest [&or symbolp (symbolp form) (form)]) + body))) + (if varlist + `(let* ,(setq varlist (internal--build-bindings varlist)) + (if ,(caar (last varlist)) + ,then + ,@else)) + `(let* () ,then))) + +(defmacro when-let* (varlist &rest body) + "Bind variables according to VARLIST and conditionally evaluate BODY. +This is like `when-let' but doesn't handle a VARLIST of the form +\(SYMBOL SOMETHING) specially." + (declare (indent 1) (debug if-let*)) + (list 'if-let* varlist (macroexp-progn body))) + +(defmacro and-let* (varlist &rest body) + "Bind variables according to VARLIST and conditionally evaluate BODY. +Like `when-let*', except if BODY is empty and all the bindings +are non-nil, then the result is non-nil." + (declare (indent 1) (debug if-let*)) + (let (res) + (if varlist + `(let* ,(setq varlist (internal--build-bindings varlist)) + (when ,(setq res (caar (last varlist))) + ,@(or body `(,res)))) + `(let* () ,@(or body '(t)))))) + +(defmacro if-let (spec then &rest else) + "Bind variables according to SPEC and evaluate THEN or ELSE. +Evaluate each binding in turn, as in `let*', stopping if a +binding value is nil. If all are non-nil return the value of +THEN, otherwise the last form in ELSE. + +Each element of SPEC is a list (SYMBOL VALUEFORM) that binds +SYMBOL to the value of VALUEFORM. An element can additionally be +of the form (VALUEFORM), which is evaluated and checked for nil; +i.e. SYMBOL can be omitted if only the test result is of +interest. It can also be of the form SYMBOL, then the binding of +SYMBOL is checked for nil. + +As a special case, interprets a SPEC of the form \(SYMBOL SOMETHING) +like \((SYMBOL SOMETHING)). This exists for backward compatibility +with an old syntax that accepted only one binding." + (declare (indent 2) + (debug ([&or (symbolp form) ; must be first, Bug#48489 + (&rest [&or symbolp (symbolp form) (form)])] + body))) + (when (and (<= (length spec) 2) + (not (listp (car spec)))) + ;; Adjust the single binding case + (setq spec (list spec))) + (list 'if-let* spec then (macroexp-progn else))) + +(defmacro when-let (spec &rest body) + "Bind variables according to SPEC and conditionally evaluate BODY. +Evaluate each binding in turn, stopping if a binding value is nil. +If all are non-nil, return the value of the last form in BODY. + +The variable list SPEC is the same as in `if-let'." + (declare (indent 1) (debug if-let)) + (list 'if-let spec (macroexp-progn body))) + + + ;; PUBLIC: find if the current mode derives from another. (defun provided-mode-derived-p (mode &rest modes) -- cgit v1.2.3 From 95dbe4b6ae2e88213835a8ded3928b6769d78f2c Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 30 Apr 2022 20:34:35 +0200 Subject: Make load-path-shadows-mode a special mode * lisp/emacs-lisp/shadow.el (load-path-shadows-mode): Make the mode inherit from special-mode so that the `q' command works. --- lisp/emacs-lisp/shadow.el | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index 8cd371321ae..2343a9b589f 100644 --- a/lisp/emacs-lisp/shadow.el +++ b/lisp/emacs-lisp/shadow.el @@ -177,12 +177,11 @@ See the documentation for `list-load-path-shadows' for further information." . (1 font-lock-warning-face))) "Keywords to highlight in `load-path-shadows-mode'.") -(define-derived-mode load-path-shadows-mode fundamental-mode "LP-Shadows" +(define-derived-mode load-path-shadows-mode special-mode "LP-Shadows" "Major mode for `load-path' shadows buffer." (setq-local font-lock-defaults '((load-path-shadows-font-lock-keywords))) - (setq buffer-undo-list t - buffer-read-only t)) + (setq buffer-undo-list t)) ;; TODO use text-properties instead, a la dired. (define-button-type 'load-path-shadows-find-file -- cgit v1.2.3 From 7c8bec9e1ffe087918f6f218fc4560fc968aebb2 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 1 May 2022 13:40:13 +0200 Subject: Don't enter the debugger from *Backtrace* or edebug on eval errors * doc/lispref/debugging.texi (Error Debugging): Document it. * doc/lispref/edebug.texi (Edebug Eval): Mention it. * lisp/emacs-lisp/debug.el (debug-allow-recursive-debug): New user option (bug#36145). (debugger-eval-expression): Use it. * lisp/emacs-lisp/edebug.el (edebug-eval-expression): Ditto. This patch is based on a patch by Noam Postavsky. --- doc/lispref/debugging.texi | 18 +++++++++++++++++- doc/lispref/edebug.texi | 8 ++++++-- etc/NEWS | 8 ++++++++ lisp/emacs-lisp/debug.el | 13 ++++++++++++- lisp/emacs-lisp/edebug.el | 5 ++++- 5 files changed, 47 insertions(+), 5 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/debugging.texi b/doc/lispref/debugging.texi index c258a9adc0e..058c9319544 100644 --- a/doc/lispref/debugging.texi +++ b/doc/lispref/debugging.texi @@ -194,6 +194,17 @@ If you set @code{debug-on-message} to a regular expression, Emacs will enter the debugger if it displays a matching message in the echo area. For example, this can be useful when trying to find the cause of a particular message. +@end defvar + +@defvar debug-allow-recursive-debug +You can evaluate forms in the current stack frame in the +@samp{*Backtrace*} buffer with the @key{e} command, and while +edebugging you can use the @key{e} and @key{C-x C-e} commands to do +something similar. By default, the debugger is inhibited by these +commands (because (re-)entering the debugger at this point will +usually take you out of the debugging context you're in). Set +@code{debug-allow-recursive-debug} to a non-@code{nil} value to allow +these commands to enter the debugger recursively. @end defvar To debug an error that happens during loading of the init @@ -520,6 +531,7 @@ Flag the current frame like @kbd{b}. Then continue execution like @kbd{c}, but temporarily disable break-on-entry for all functions that are set up to do so by @code{debug-on-entry}. +@vindex debug-allow-recursive-debug @item e Read a Lisp expression in the minibuffer, evaluate it (with the relevant lexical environment, if applicable), and print the @@ -528,7 +540,11 @@ variables, and the current buffer, as part of its operation; @kbd{e} temporarily restores their values from outside the debugger, so you can examine and change them. This makes the debugger more transparent. By contrast, @kbd{M-:} does nothing special in the debugger; it shows you -the variable values within the debugger. +the variable values within the debugger. By default, this command +suppresses the debugger during evaluation, so that an error in the +evaluated expression won't add a new error on top of the existing one. +Set the @code{debug-allow-recursive-debug} user option to a +non-@code{nil} value to override this. @item R Like @kbd{e}, but also save the result of evaluation in the diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi index eff9621628e..0fc5271d5ad 100644 --- a/doc/lispref/edebug.texi +++ b/doc/lispref/edebug.texi @@ -700,8 +700,12 @@ on this process. @table @kbd @item e @var{exp} @key{RET} Evaluate expression @var{exp} in the context outside of Edebug -(@code{edebug-eval-expression}). That is, Edebug tries to minimize its -interference with the evaluation. +(@code{edebug-eval-expression}). That is, Edebug tries to minimize +its interference with the evaluation. By default, this command +suppresses the debugger during evaluation, so that an error in the +evaluated expression won't add a new error on top of the existing one. +Set the @code{debug-allow-recursive-debug} user option to a +non-@code{nil} value to override this. @item M-: @var{exp} @key{RET} Evaluate expression @var{exp} in the context of Edebug itself diff --git a/etc/NEWS b/etc/NEWS index 88b4e59e267..090d0b6dddc 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -686,6 +686,14 @@ script that was used in ancient South Asia. A new input method, * Changes in Specialized Modes and Packages in Emacs 29.1 +** Debugging + +*** New user option 'debug-allow-recursive-debug'. +This user option controls whether the 'e' (in a *Backtrace* +buffer or while edebugging) and 'C-x C-e' (while edebugging) commands +lead to a (further) backtrace. By default, this variable is nil, +which is a change in behaviour from previous Emacs versions. + ** Compile +++ diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 46b0306d64f..91e9b0716d0 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -90,6 +90,11 @@ The value used here is passed to `quit-restore-window'." :group 'debugger :version "24.3") +(defcustom debug-allow-recursive-debug nil + "If non-nil, erroring in debug and edebug won't recursively debug." + :type 'boolean + :version "29.1") + (defvar debugger-step-after-exit nil "Non-nil means \"single-step\" after the debugger exits.") @@ -534,7 +539,13 @@ The environment used is the one when entering the activation frame at point." (error 0)))) ;; If on first line. (base (debugger--backtrace-base))) (debugger-env-macro - (let ((val (backtrace-eval exp nframe base))) + (let ((val (if debug-allow-recursive-debug + (backtrace-eval exp nframe base) + (condition-case err + (backtrace-eval exp nframe base) + (error (format "%s: %s" + (get (car err) 'error-message) + (car (cdr err)))))))) (prog1 (debugger--print val t) (let ((str (eval-expression-print-format val))) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 722283b88ff..85545f9f351 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -57,6 +57,7 @@ (require 'cl-lib) (require 'seq) (eval-when-compile (require 'pcase)) +(require 'debug) ;;; Options @@ -3713,7 +3714,9 @@ Print result in minibuffer." (interactive (list (read--expression "Eval: "))) (princ (edebug-outside-excursion - (let ((result (edebug-eval expr))) + (let ((result (if debug-allow-recursive-debug + (edebug-eval expr) + (edebug-safe-eval expr)))) (values--store-value result) (concat (edebug-safe-prin1-to-string result) (eval-expression-print-format result)))))) -- cgit v1.2.3 From f639fa9f9e2acfe9d02e2afc57f7a2cc96390f5f Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Mon, 2 May 2022 13:55:56 +0200 Subject: Make non-recursive error messages in edebug prettier * lisp/emacs-lisp/edebug.el (edebug-eval-expression): Make the error message (when recursive debugging is off) prettier. --- lisp/emacs-lisp/edebug.el | 27 +++++++++++++++++++-------- 1 file changed, 19 insertions(+), 8 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 85545f9f351..d8b0a13c305 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -3712,14 +3712,25 @@ Return the result of the last expression." If interactive, prompt for the expression. Print result in minibuffer." (interactive (list (read--expression "Eval: "))) - (princ - (edebug-outside-excursion - (let ((result (if debug-allow-recursive-debug - (edebug-eval expr) - (edebug-safe-eval expr)))) - (values--store-value result) - (concat (edebug-safe-prin1-to-string result) - (eval-expression-print-format result)))))) + (let* ((errored nil) + (result + (edebug-outside-excursion + (let ((result (if debug-allow-recursive-debug + (edebug-eval expr) + (condition-case err + (edebug-eval expr) + (error + (setq errored + (format "%s: %s" + (get (car err) 'error-message) + (car (cdr err))))))))) + (unless errored + (values--store-value result) + (concat (edebug-safe-prin1-to-string result) + (eval-expression-print-format result))))))) + (if errored + (message "Error: %s" errored) + (princ result)))) (defun edebug-eval-last-sexp (&optional no-truncate) "Evaluate sexp before point in the outside environment. -- cgit v1.2.3 From bcdcaf0219906862d02f1e6ab83972c8f4d3c0ba Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Mon, 2 May 2022 13:59:11 +0200 Subject: Make the eval-in-debug error message prettier in non-recursive errors * lisp/emacs-lisp/debug.el (debugger-eval-expression): Make the error message (when recursive debugging is off) prettier. --- lisp/emacs-lisp/debug.el | 28 +++++++++++++++++----------- 1 file changed, 17 insertions(+), 11 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 91e9b0716d0..6c172d6c31d 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -539,17 +539,23 @@ The environment used is the one when entering the activation frame at point." (error 0)))) ;; If on first line. (base (debugger--backtrace-base))) (debugger-env-macro - (let ((val (if debug-allow-recursive-debug - (backtrace-eval exp nframe base) - (condition-case err - (backtrace-eval exp nframe base) - (error (format "%s: %s" - (get (car err) 'error-message) - (car (cdr err)))))))) - (prog1 - (debugger--print val t) - (let ((str (eval-expression-print-format val))) - (if str (princ str t)))))))) + (let* ((errored nil) + (val (if debug-allow-recursive-debug + (backtrace-eval exp nframe base) + (condition-case err + (backtrace-eval exp nframe base) + (error (setq errored + (format "%s: %s" + (get (car err) 'error-message) + (car (cdr err))))))))) + (if errored + (progn + (message "Error: %s" errored) + nil) + (prog1 + (debugger--print val t) + (let ((str (eval-expression-print-format val))) + (if str (princ str t))))))))) (define-obsolete-function-alias 'debugger-toggle-locals 'backtrace-toggle-locals "28.1") -- cgit v1.2.3 From 0916fd3aaacf62e641414fb2b474c86888116487 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 3 May 2022 18:00:32 +0200 Subject: Add new command 'package-update' * doc/emacs/package.texi (Package Installation): Mention it. * lisp/emacs-lisp/package.el (package-update): New command (bug#18790). --- doc/emacs/package.texi | 5 ++++- etc/NEWS | 7 +++++++ lisp/emacs-lisp/package.el | 25 +++++++++++++++++++++++++ 3 files changed, 36 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/emacs/package.texi b/doc/emacs/package.texi index caa65bf33b6..bd3ae2aa6ad 100644 --- a/doc/emacs/package.texi +++ b/doc/emacs/package.texi @@ -320,10 +320,13 @@ version of the package, a newer version is also installed. @section Package Installation @findex package-install +@findex package-update Packages are most conveniently installed using the package menu (@pxref{Package Menu}), but you can also use the command @kbd{M-x package-install}. This prompts for the name of a package with the -@samp{available} status, then downloads and installs it. +@samp{available} status, then downloads and installs it. Similarly, +if you want to update a package, you can use the @kbd{M-x +package-update} command. @cindex package requirements A package may @dfn{require} certain other packages to be installed, diff --git a/etc/NEWS b/etc/NEWS index f897158afd0..b6a47326330 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -707,6 +707,13 @@ script that was used in ancient South Asia. A new input method, * Changes in Specialized Modes and Packages in Emacs 29.1 +** Package + ++++ +*** New command 'package-update'. +This command allows you to upgrade packages without using 'M-x +list-packages'. + ** Miscellaneous +++ diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 7f2c427c2ee..58c1349e1c2 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2136,6 +2136,31 @@ to install it but still mark it as selected." (message "Package `%s' installed." name)) (message "`%s' is already installed" name)))) +;;;###autoload +(defun package-update (name) + "Update package NAME if a newer version exists." + (interactive + (progn + ;; Initialize the package system to get the list of package + ;; symbols for completion. + (package--archives-initialize) + (list (completing-read + "Update package: " + (mapcar + #'car + (seq-filter + (lambda (elt) + (let ((available + (assq (car elt) package-archive-contents))) + (and available + (version-list-< + (package-desc-priority-version (cadr elt)) + (package-desc-priority-version (cadr available)))))) + package-alist)) + nil t)))) + (package-delete (cadr (assq (intern name) package-alist)) 'force) + (package-install (intern name) 'dont-select)) + (defun package-strip-rcs-id (str) "Strip RCS version ID from the version string STR. If the result looks like a dotted numeric version, return it. -- cgit v1.2.3 From 59353ec7b579213de3c70950d5d938b7540ce72f Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 3 May 2022 21:22:53 +0200 Subject: Add new macro with-buffer-unmodified-if-unchanged * lisp/emacs-lisp/subr-x.el (with-buffer-unmodified-if-unchanged): New macro. * lisp/textmodes/fill.el (fill-paragraph): Macro code copied from here. Adjust and use the macro. --- etc/NEWS | 6 +++ lisp/emacs-lisp/subr-x.el | 25 +++++++++ lisp/textmodes/fill.el | 132 ++++++++++++++++++++++------------------------ 3 files changed, 94 insertions(+), 69 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/etc/NEWS b/etc/NEWS index 15c7ce8a908..b0758b60a09 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1625,6 +1625,12 @@ functions. * Lisp Changes in Emacs 29.1 +--- +** New macro 'with-buffer-unmodified-if-unchanged'. +If the buffer is marked as unmodified, and code does modifications +that, in total, means that the buffer is identical to the buffer +before, mark the buffer as unmodified again. + --- ** New function 'malloc-trim'. This function allows returning unused memory back to the operating diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 6c763bd04d9..afa0423d90e 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -416,6 +416,31 @@ this defaults to the current buffer." (error "No process selected")) process))) +(defmacro with-buffer-unmodified-if-unchanged (&rest body) + "Like `progn', but change buffer modification status only if buffer is changed. +That is, if the buffer is marked as unmodified before BODY, and +BODY does modifications that, in total, means that the buffer is +identical to the buffer before BODY, mark the buffer as +unmodified again. In other words, this won't change buffer +modification status: + + (with-buffer-unmodified-if-unchanged + (insert \"a\") + (delete-char -1))" + (declare (debug t) (indent 0)) + (let ((hash (gensym))) + `(let ((,hash (and (not (buffer-modified-p)) + (buffer-hash)))) + (prog1 + (progn + ,@body) + ;; If we didn't change anything in the buffer (and the buffer + ;; was previously unmodified), then flip the modification status + ;; back to "unchanged". + (when (and ,hash + (equal ,hash (buffer-hash))) + (set-buffer-modified-p nil)))))) + (provide 'subr-x) ;;; subr-x.el ends here diff --git a/lisp/textmodes/fill.el b/lisp/textmodes/fill.el index d3c832a40da..88a8395c88a 100644 --- a/lisp/textmodes/fill.el +++ b/lisp/textmodes/fill.el @@ -29,6 +29,8 @@ ;;; Code: +(eval-when-compile (require 'subr-x)) + (defgroup fill nil "Indenting and filling text." :link '(custom-manual "(emacs)Filling") @@ -839,75 +841,67 @@ region, instead of just filling the current paragraph." (interactive (progn (barf-if-buffer-read-only) (list (if current-prefix-arg 'full) t))) - (let ((hash (and (not (buffer-modified-p)) - (buffer-hash)))) - (prog1 - (or - ;; 1. Fill the region if it is active when called interactively. - (and region transient-mark-mode mark-active - (not (eq (region-beginning) (region-end))) - (or (fill-region (region-beginning) (region-end) justify) t)) - ;; 2. Try fill-paragraph-function. - (and (not (eq fill-paragraph-function t)) - (or fill-paragraph-function - (and (minibufferp (current-buffer)) - (= 1 (point-min)))) - (let ((function (or fill-paragraph-function - ;; In the minibuffer, don't count - ;; the width of the prompt. - 'fill-minibuffer-function)) - ;; If fill-paragraph-function is set, it probably - ;; takes care of comments and stuff. If not, it - ;; will have to set fill-paragraph-handle-comment - ;; back to t explicitly or return nil. - (fill-paragraph-handle-comment nil) - (fill-paragraph-function t)) - (funcall function justify))) - ;; 3. Try our syntax-aware filling code. - (and fill-paragraph-handle-comment - ;; Our code only handles \n-terminated comments right now. - comment-start (equal comment-end "") - (let ((fill-paragraph-handle-comment nil)) - (fill-comment-paragraph justify))) - ;; 4. If it all fails, default to the good ol' text paragraph filling. - (let ((before (point)) - (paragraph-start paragraph-start) - ;; Fill prefix used for filling the paragraph. - fill-pfx) - ;; Try to prevent code sections and comment sections from being - ;; filled together. - (when (and fill-paragraph-handle-comment comment-start-skip) - (setq paragraph-start - (concat paragraph-start "\\|[ \t]*\\(?:" - comment-start-skip "\\)"))) - (save-excursion - ;; To make sure the return value of forward-paragraph is - ;; meaningful, we have to start from the beginning of - ;; line, otherwise skipping past the last few chars of a - ;; paragraph-separator would count as a paragraph (and - ;; not skipping any chars at EOB would not count as a - ;; paragraph even if it is). - (move-to-left-margin) - (if (not (zerop (fill-forward-paragraph 1))) - ;; There's no paragraph at or after point: give up. - (setq fill-pfx "") - (let ((end (point)) - (beg (progn (fill-forward-paragraph -1) (point)))) - (goto-char before) - (setq fill-pfx - (if use-hard-newlines - ;; Can't use fill-region-as-paragraph, since this - ;; paragraph may still contain hard newlines. See - ;; fill-region. - (fill-region beg end justify) - (fill-region-as-paragraph beg end justify)))))) - fill-pfx)) - ;; If we didn't change anything in the buffer (and the buffer - ;; was previously unmodified), then flip the modification status - ;; back to "unchanged". - (when (and hash - (equal hash (buffer-hash))) - (set-buffer-modified-p nil))))) + (with-buffer-unmodified-if-unchanged + (or + ;; 1. Fill the region if it is active when called interactively. + (and region transient-mark-mode mark-active + (not (eq (region-beginning) (region-end))) + (or (fill-region (region-beginning) (region-end) justify) t)) + ;; 2. Try fill-paragraph-function. + (and (not (eq fill-paragraph-function t)) + (or fill-paragraph-function + (and (minibufferp (current-buffer)) + (= 1 (point-min)))) + (let ((function (or fill-paragraph-function + ;; In the minibuffer, don't count + ;; the width of the prompt. + 'fill-minibuffer-function)) + ;; If fill-paragraph-function is set, it probably + ;; takes care of comments and stuff. If not, it + ;; will have to set fill-paragraph-handle-comment + ;; back to t explicitly or return nil. + (fill-paragraph-handle-comment nil) + (fill-paragraph-function t)) + (funcall function justify))) + ;; 3. Try our syntax-aware filling code. + (and fill-paragraph-handle-comment + ;; Our code only handles \n-terminated comments right now. + comment-start (equal comment-end "") + (let ((fill-paragraph-handle-comment nil)) + (fill-comment-paragraph justify))) + ;; 4. If it all fails, default to the good ol' text paragraph filling. + (let ((before (point)) + (paragraph-start paragraph-start) + ;; Fill prefix used for filling the paragraph. + fill-pfx) + ;; Try to prevent code sections and comment sections from being + ;; filled together. + (when (and fill-paragraph-handle-comment comment-start-skip) + (setq paragraph-start + (concat paragraph-start "\\|[ \t]*\\(?:" + comment-start-skip "\\)"))) + (save-excursion + ;; To make sure the return value of forward-paragraph is + ;; meaningful, we have to start from the beginning of + ;; line, otherwise skipping past the last few chars of a + ;; paragraph-separator would count as a paragraph (and + ;; not skipping any chars at EOB would not count as a + ;; paragraph even if it is). + (move-to-left-margin) + (if (not (zerop (fill-forward-paragraph 1))) + ;; There's no paragraph at or after point: give up. + (setq fill-pfx "") + (let ((end (point)) + (beg (progn (fill-forward-paragraph -1) (point)))) + (goto-char before) + (setq fill-pfx + (if use-hard-newlines + ;; Can't use fill-region-as-paragraph, since this + ;; paragraph may still contain hard newlines. See + ;; fill-region. + (fill-region beg end justify) + (fill-region-as-paragraph beg end justify)))))) + fill-pfx)))) (declare-function comment-search-forward "newcomment" (limit &optional noerror)) (declare-function comment-string-strip "newcomment" (str beforep afterp)) -- cgit v1.2.3 From b5db5a64435b86de6e5277d1d173c57784783e5e Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 3 May 2022 15:35:47 -0400 Subject: with-buffer-unmodified-if-unchanged: Tweak the implementation * lisp/emacs-lisp/subr-x.el (with-buffer-unmodified-if-unchanged): Skip the hash if the buffer was not modified at all. Use `restore-buffer-modified-p`. Also mention that it's imperative that the current buffer is preserved. --- lisp/emacs-lisp/subr-x.el | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index afa0423d90e..8e763b613ee 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -426,7 +426,9 @@ modification status: (with-buffer-unmodified-if-unchanged (insert \"a\") - (delete-char -1))" + (delete-char -1)) + +BODY must preserve the current buffer." (declare (debug t) (indent 0)) (let ((hash (gensym))) `(let ((,hash (and (not (buffer-modified-p)) @@ -437,9 +439,9 @@ modification status: ;; If we didn't change anything in the buffer (and the buffer ;; was previously unmodified), then flip the modification status ;; back to "unchanged". - (when (and ,hash + (when (and ,hash (buffer-modified-p) (equal ,hash (buffer-hash))) - (set-buffer-modified-p nil)))))) + (restore-buffer-modified-p nil)))))) (provide 'subr-x) -- cgit v1.2.3 From b7ddd0f2fd08c9dca0b75493e9e809bb5dab40d9 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 3 May 2022 22:04:39 +0200 Subject: Make with-buffer-unmodified-if-unchanged more resilient * lisp/emacs-lisp/subr-x.el (with-buffer-unmodified-if-unchanged): Make more resilient. --- lisp/emacs-lisp/subr-x.el | 18 ++++++++++-------- test/lisp/sort-tests.el | 33 +++++++++++++++++++++++++++++++++ 2 files changed, 43 insertions(+), 8 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 8e763b613ee..a416059df62 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -426,22 +426,24 @@ modification status: (with-buffer-unmodified-if-unchanged (insert \"a\") - (delete-char -1)) - -BODY must preserve the current buffer." + (delete-char -1))." (declare (debug t) (indent 0)) - (let ((hash (gensym))) + (let ((hash (gensym)) + (buffer (gensym))) `(let ((,hash (and (not (buffer-modified-p)) - (buffer-hash)))) + (buffer-hash))) + (,buffer (current-buffer))) (prog1 (progn ,@body) ;; If we didn't change anything in the buffer (and the buffer ;; was previously unmodified), then flip the modification status ;; back to "unchanged". - (when (and ,hash (buffer-modified-p) - (equal ,hash (buffer-hash))) - (restore-buffer-modified-p nil)))))) + (when (buffer-live-p ,buffer) + (with-current-buffer ,buffer + (when (and ,hash (buffer-modified-p) + (equal ,hash (buffer-hash))) + (restore-buffer-modified-p nil)))))))) (provide 'subr-x) diff --git a/test/lisp/sort-tests.el b/test/lisp/sort-tests.el index 7f49cc38d1b..5fcae308d6a 100644 --- a/test/lisp/sort-tests.el +++ b/test/lisp/sort-tests.el @@ -106,5 +106,38 @@ reversing the sort." :generator (lambda (n) (concat (sort-tests-random-word n) " " (sort-tests-random-word n))) :less-pred (lambda (a b) (string< (field-n a 2) (field-n b 2)))))) +(defun test-with-buffer-unmodified-if-unchanged () + (with-temp-buffer + (with-buffer-unmodified-if-unchanged + (insert "t")) + (should (buffer-modified-p))) + + (with-temp-buffer + (with-buffer-unmodified-if-unchanged + (insert "t") + (delete-char -1)) + (should (not (buffer-modified-p)))) + + ;; Shouldn't error. + (should + (with-temp-buffer + (let ((inner (current-buffer))) + (with-buffer-unmodified-if-unchanged + (insert "t") + (delete-char -1) + (kill-buffer (current-buffer)) + t)))) + + (with-temp-buffer + (let ((outer (current-buffer))) + (with-temp-buffer + (let ((inner (current-buffer))) + (with-buffer-unmodified-if-unchanged + (insert "t") + (delete-char -1) + (set-buffer outer)) + (with-current-buffer inner + (should (not (buffer-modified-p))))))))) + (provide 'sort-tests) ;;; sort-tests.el ends here -- cgit v1.2.3 From 0a2f0e7f8c1ba54d160322c52865feef3e67d79c Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 3 May 2022 22:06:31 +0200 Subject: Make with-buffer-unmodified-if-unchanged more efficient * lisp/emacs-lisp/subr-x.el (with-buffer-unmodified-if-unchanged): Make more efficient. --- lisp/emacs-lisp/subr-x.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index a416059df62..298d370cb25 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -439,9 +439,9 @@ modification status: ;; If we didn't change anything in the buffer (and the buffer ;; was previously unmodified), then flip the modification status ;; back to "unchanged". - (when (buffer-live-p ,buffer) + (when (and ,hash (buffer-live-p ,buffer)) (with-current-buffer ,buffer - (when (and ,hash (buffer-modified-p) + (when (and (buffer-modified-p) (equal ,hash (buffer-hash))) (restore-buffer-modified-p nil)))))))) -- cgit v1.2.3 From 69521ffcb0f2a28f84e24137bfc789ffd0ec3f2f Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Wed, 4 May 2022 11:46:01 +0300 Subject: Clarify the doc string of 'with-buffer-unmodified-if-unchanged' * lisp/emacs-lisp/subr-x.el (with-buffer-unmodified-if-unchanged): Describe better what is meant by "buffer changes". (Bug#4587) --- lisp/emacs-lisp/subr-x.el | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 298d370cb25..9339acc9096 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -417,16 +417,23 @@ this defaults to the current buffer." process))) (defmacro with-buffer-unmodified-if-unchanged (&rest body) - "Like `progn', but change buffer modification status only if buffer is changed. -That is, if the buffer is marked as unmodified before BODY, and -BODY does modifications that, in total, means that the buffer is -identical to the buffer before BODY, mark the buffer as -unmodified again. In other words, this won't change buffer -modification status: + "Like `progn', but change buffer-modified status only if buffer text changes. +If the buffer was unmodified before execution of BODY, and +buffer text after execution of BODY is identical to what it was +before, ensure that buffer is still marked unmodified afterwards. +For example, the following won't change the buffer's modification +status: (with-buffer-unmodified-if-unchanged (insert \"a\") - (delete-char -1))." + (delete-char -1)) + +Note that only changes in the raw byte sequence of the buffer text, +as stored in the internal representation, are monitored for the +purpose of detecting the lack of changes in buffer text. Any other +changes that are normally perceived as \"buffer modifications\", such +as changes in text properties, `buffer-file-coding-system', buffer +multibytenes, etc. -- will still cause the buffer to become modified." (declare (debug t) (indent 0)) (let ((hash (gensym)) (buffer (gensym))) -- cgit v1.2.3 From 1a72248901cc0cdb2e8d09dee68483d808c57d4e Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Wed, 4 May 2022 13:08:53 +0300 Subject: ; Fix last change in doc string of 'with-buffer-unmodified-if-unchanged'. --- lisp/emacs-lisp/subr-x.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 9339acc9096..5d604be4aed 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -433,7 +433,8 @@ as stored in the internal representation, are monitored for the purpose of detecting the lack of changes in buffer text. Any other changes that are normally perceived as \"buffer modifications\", such as changes in text properties, `buffer-file-coding-system', buffer -multibytenes, etc. -- will still cause the buffer to become modified." +multibytenes, etc. -- will not be noticed, and the buffer will still +be marked unmodified, effectively ignoring those changes." (declare (debug t) (indent 0)) (let ((hash (gensym)) (buffer (gensym))) -- cgit v1.2.3 From eaa198cd75ad9cbe4c07532747bcb08516dcc0b2 Mon Sep 17 00:00:00 2001 From: Robert Pluim Date: Wed, 4 May 2022 14:53:34 +0200 Subject: ; Re-fix last change in doc of 'with-buffer-unmodified-if-unchanged'. --- lisp/emacs-lisp/subr-x.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 5d604be4aed..9cd793d05c5 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -433,7 +433,7 @@ as stored in the internal representation, are monitored for the purpose of detecting the lack of changes in buffer text. Any other changes that are normally perceived as \"buffer modifications\", such as changes in text properties, `buffer-file-coding-system', buffer -multibytenes, etc. -- will not be noticed, and the buffer will still +multibyteness, etc. -- will not be noticed, and the buffer will still be marked unmodified, effectively ignoring those changes." (declare (debug t) (indent 0)) (let ((hash (gensym)) -- cgit v1.2.3 From 7e9d364b663613fd907f92de31e996463ef7d03c Mon Sep 17 00:00:00 2001 From: "James N. V. Cash" Date: Thu, 5 May 2022 21:15:51 +0300 Subject: * lisp/emacs-lisp/crm.el: Set completion-list-insert-choice-function. * lisp/emacs-lisp/crm.el (completing-read-multiple): Set buffer-local completion-list-insert-choice-function that handles string values of args. https://lists.gnu.org/archive/html/emacs-devel/2022-05/msg00017.html --- lisp/emacs-lisp/crm.el | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index f3e1981732c..8a5c3d3730c 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -254,6 +254,23 @@ with empty strings removed." 'crm--choose-completion-string nil 'local) (setq-local minibuffer-completion-table #'crm--collection-fn) (setq-local minibuffer-completion-predicate predicate) + (setq-local completion-list-insert-choice-function + (lambda (start end choice) + (if (and (stringp start) (stringp end)) + (let* ((beg (save-excursion + (goto-char (minibuffer-prompt-end)) + (or (search-forward start nil t) + (search-forward-regexp crm-separator nil t) + (minibuffer-prompt-end)))) + (end (save-excursion + (goto-char (point-max)) + (or (search-backward end nil t) + (progn + (goto-char beg) + (search-forward-regexp crm-separator nil t)) + (point-max))))) + (completion--replace beg end choice)) + (completion--replace start end choice)))) ;; see completing_read in src/minibuf.c (setq-local minibuffer-completion-confirm (unless (eq require-match t) require-match)) -- cgit v1.2.3 From b13356487fc3eaf82bfe51bee24ddf70c27c5834 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 6 May 2022 13:10:45 +0200 Subject: Add new helper macros for minor modes to restore variables * doc/lispref/modes.texi (Defining Minor Modes): Document it. * lisp/emacs-lisp/easy-mmode.el (buffer-local-set-state): New macro. (buffer-local-set-state--get): Helper function. (buffer-local-restore-state): New function. * lisp/textmodes/word-wrap-mode.el (word-wrap-whitespace-mode): Use it to simplify code. --- doc/lispref/modes.texi | 9 +++++++++ etc/NEWS | 6 ++++++ lisp/emacs-lisp/easy-mmode.el | 33 ++++++++++++++++++++++++++++++++ lisp/textmodes/word-wrap-mode.el | 25 +++++++----------------- test/lisp/emacs-lisp/easy-mmode-tests.el | 12 +++++++++++- 5 files changed, 66 insertions(+), 19 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi index ff09a787490..bfd9724173b 100644 --- a/doc/lispref/modes.texi +++ b/doc/lispref/modes.texi @@ -1912,6 +1912,15 @@ This means ``use in modes derived from @code{text-mode}, but nowhere else''. (There's an implicit @code{nil} element at the end.) @end defmac +@defmac buffer-local-set-state variable value... +Minor modes often set buffer-local variables that alters some features +in Emacs. When a minor mode is switched off, the mode is expected to +restore the previous state of these variables. This convenience macro +helps with doing that: It works much like @code{setq-local}, but +returns an object that can be used to restore these values back to +their previous values/states (with the +@code{buffer-local-restore-state} function). +@end defmac @node Mode Line Format @section Mode Line Format diff --git a/etc/NEWS b/etc/NEWS index 6637eda00c8..fa7e2c4dcca 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1636,6 +1636,12 @@ functions. * Lisp Changes in Emacs 29.1 ++++ +** New macro 'buffer-local-set-state'. +This is a helper macro to be used by minor modes that wish to restore +buffer-local variables back to their original states when the mode is +switched off. + --- ** New macro 'with-buffer-unmodified-if-unchanged'. If the buffer is marked as unmodified, and code does modifications diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 8a76eaf58cf..33c0472ea87 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -825,6 +825,39 @@ Interactively, COUNT is the prefix numeric argument, and defaults to 1." ,@body)) (put ',prev-sym 'definition-name ',base)))) + +(defmacro buffer-local-set-state (&rest pairs) + "Like `setq-local', but return an object that allows restoring previous state. +Use `buffer-local-restore-state' on the returned object to +restore the state. + +\(fn [VARIABLE VALUE]...)" + (declare (debug setq)) + (unless (zerop (mod (length pairs) 2)) + (error "PAIRS must have an even number of variable/value members")) + `(prog1 + (buffer-local-set-state--get ',pairs) + (setq-local ,@pairs))) + +(defun buffer-local-set-state--get (pairs) + (let ((states nil)) + (while pairs + (push (list (car pairs) + (and (boundp (car pairs)) + (local-variable-p (car pairs))) + (and (boundp (car pairs)) + (symbol-value (car pairs)))) + states) + (setq pairs (cddr pairs))) + (nreverse states))) + +(defun buffer-local-restore-state (states) + "Restore buffer local variable values in STATES. +STATES is an object returned by `buffer-local-set-state'." + (pcase-dolist (`(,variable ,local ,value) states) + (if local + (set variable value) + (kill-local-variable variable)))) (provide 'easy-mmode) diff --git a/lisp/textmodes/word-wrap-mode.el b/lisp/textmodes/word-wrap-mode.el index 1459a3395ca..c354fc773a7 100644 --- a/lisp/textmodes/word-wrap-mode.el +++ b/lisp/textmodes/word-wrap-mode.el @@ -60,26 +60,15 @@ The characters to break on are defined by `word-wrap-whitespace-characters'." (if word-wrap-whitespace-mode (progn (setq-local word-wrap-mode--previous-state - (list (category-table) - (local-variable-p 'word-wrap-by-category) - word-wrap-by-category - (local-variable-p 'word-wrap) - word-wrap)) + (cons (category-table) + (buffer-local-set-state + word-wrap-by-category t + word-wrap t))) (set-category-table (copy-category-table)) (dolist (char word-wrap-whitespace-characters) - (modify-category-entry char ?|)) - (setq-local word-wrap-by-category t - word-wrap t)) - (pcase-let ((`(,table ,lby-cat ,by-cat - ,lwrap ,wrap) - word-wrap-mode--previous-state)) - (if lby-cat - (setq-local word-wrap-by-category by-cat) - (kill-local-variable 'word-wrap-by-category)) - (if lwrap - (setq-local word-wrap wrap) - (kill-local-variable 'word-wrap)) - (set-category-table table)))) + (modify-category-entry char ?|))) + (set-category-table (car word-wrap-mode--previous-state)) + (buffer-local-restore-state (cdr word-wrap-mode--previous-state)))) ;;;###autoload (define-globalized-minor-mode global-word-wrap-whitespace-mode diff --git a/test/lisp/emacs-lisp/easy-mmode-tests.el b/test/lisp/emacs-lisp/easy-mmode-tests.el index 0a3bbb189ba..697bf6c2152 100644 --- a/test/lisp/emacs-lisp/easy-mmode-tests.el +++ b/test/lisp/emacs-lisp/easy-mmode-tests.el @@ -60,6 +60,16 @@ (easy-mmode-test-mode 'toggle) (should (eq easy-mmode-test-mode t)))) -(provide 'easy-mmode-tests) +(ert-deftest test-local-set-state () + (setq global 1) + (with-temp-buffer + (setq-local local 2) + (let ((state (buffer-local-set-state global 10 + local 20 + unexist 30))) + (buffer-local-restore-state state) + (should (= global 1)) + (should (= local 2)) + (should-not (boundp 'unexist))))) ;;; easy-mmode-tests.el ends here -- cgit v1.2.3 From b6bced1a66969e7645f96c36030eb4e9d90a6dc0 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 6 May 2022 13:20:47 +0200 Subject: Autoload the buffer-local-set* things * lisp/emacs-lisp/easy-mmode.el (buffer-local-set-state--get) (buffer-local-restore-state): Autoload. Perhaps it would be better to move these functions to subr.el or something... --- lisp/emacs-lisp/easy-mmode.el | 2 ++ 1 file changed, 2 insertions(+) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 33c0472ea87..bade14ec3d8 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -839,6 +839,7 @@ restore the state. (buffer-local-set-state--get ',pairs) (setq-local ,@pairs))) +;;;###autoload (defun buffer-local-set-state--get (pairs) (let ((states nil)) (while pairs @@ -851,6 +852,7 @@ restore the state. (setq pairs (cddr pairs))) (nreverse states))) +;;;###autoload (defun buffer-local-restore-state (states) "Restore buffer local variable values in STATES. STATES is an object returned by `buffer-local-set-state'." -- cgit v1.2.3 From 92bbe911e99968c04509c553767fa83bfdcbeb18 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Fri, 6 May 2022 15:15:27 +0300 Subject: ; Improve documentation of 'buffer-local-set-state' * lisp/emacs-lisp/easy-mmode.el (buffer-local-set-state) (buffer-local-restore-state): Doc fixes. * doc/lispref/modes.texi (Defining Minor Modes): Fix a typo and improve wording and indexing. --- doc/lispref/modes.texi | 7 ++++--- lisp/emacs-lisp/easy-mmode.el | 10 +++++----- 2 files changed, 9 insertions(+), 8 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi index bfd9724173b..a0c1c488fe7 100644 --- a/doc/lispref/modes.texi +++ b/doc/lispref/modes.texi @@ -1912,14 +1912,15 @@ This means ``use in modes derived from @code{text-mode}, but nowhere else''. (There's an implicit @code{nil} element at the end.) @end defmac +@findex buffer-local-restore-state @defmac buffer-local-set-state variable value... -Minor modes often set buffer-local variables that alters some features +Minor modes often set buffer-local variables that affect some features in Emacs. When a minor mode is switched off, the mode is expected to restore the previous state of these variables. This convenience macro helps with doing that: It works much like @code{setq-local}, but returns an object that can be used to restore these values back to -their previous values/states (with the -@code{buffer-local-restore-state} function). +their previous values/states (using the companion function +@code{buffer-local-restore-state}). @end defmac @node Mode Line Format diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index bade14ec3d8..2568eaeb76a 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -827,9 +827,9 @@ Interactively, COUNT is the prefix numeric argument, and defaults to 1." (defmacro buffer-local-set-state (&rest pairs) - "Like `setq-local', but return an object that allows restoring previous state. -Use `buffer-local-restore-state' on the returned object to -restore the state. + "Like `setq-local', but allow restoring the previous state of locals later. +This macro returns an object that can be passed to `buffer-local-restore-state' +in order to restore the state of the local variables set via this macro. \(fn [VARIABLE VALUE]...)" (declare (debug setq)) @@ -854,8 +854,8 @@ restore the state. ;;;###autoload (defun buffer-local-restore-state (states) - "Restore buffer local variable values in STATES. -STATES is an object returned by `buffer-local-set-state'." + "Restore values of buffer-local variables recorded in STATES. +STATES should be an object returned by `buffer-local-set-state'." (pcase-dolist (`(,variable ,local ,value) states) (if local (set variable value) -- cgit v1.2.3 From afc14e4f661194969ef1622e2d9310cfbf662aff Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 6 May 2022 16:09:38 +0200 Subject: Move buffer-local-set-state to subr because it's used at runtime * lisp/subr.el (buffer-local-set-state) (buffer-local-set-state--get, buffer-local-restore-state): Moved from easy-mmode.el because they have to be available run-time. --- lisp/emacs-lisp/easy-mmode.el | 36 -------------------------------- lisp/ldefs-boot.el | 13 +----------- lisp/subr.el | 33 +++++++++++++++++++++++++++++ test/lisp/emacs-lisp/easy-mmode-tests.el | 12 ----------- test/lisp/subr-tests.el | 12 +++++++++++ 5 files changed, 46 insertions(+), 60 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 2568eaeb76a..54cac116168 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -825,42 +825,6 @@ Interactively, COUNT is the prefix numeric argument, and defaults to 1." ,@body)) (put ',prev-sym 'definition-name ',base)))) - -(defmacro buffer-local-set-state (&rest pairs) - "Like `setq-local', but allow restoring the previous state of locals later. -This macro returns an object that can be passed to `buffer-local-restore-state' -in order to restore the state of the local variables set via this macro. - -\(fn [VARIABLE VALUE]...)" - (declare (debug setq)) - (unless (zerop (mod (length pairs) 2)) - (error "PAIRS must have an even number of variable/value members")) - `(prog1 - (buffer-local-set-state--get ',pairs) - (setq-local ,@pairs))) - -;;;###autoload -(defun buffer-local-set-state--get (pairs) - (let ((states nil)) - (while pairs - (push (list (car pairs) - (and (boundp (car pairs)) - (local-variable-p (car pairs))) - (and (boundp (car pairs)) - (symbol-value (car pairs)))) - states) - (setq pairs (cddr pairs))) - (nreverse states))) - -;;;###autoload -(defun buffer-local-restore-state (states) - "Restore values of buffer-local variables recorded in STATES. -STATES should be an object returned by `buffer-local-set-state'." - (pcase-dolist (`(,variable ,local ,value) states) - (if local - (set variable value) - (kill-local-variable variable)))) - (provide 'easy-mmode) ;;; easy-mmode.el ends here diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index c0a16f9198a..b79c6b2a08b 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -8852,18 +8852,7 @@ CSS contains a list of syntax specifications of the form (CHAR . SYNTAX). (function-put 'easy-mmode-defsyntax 'lisp-indent-function '1) -(autoload 'buffer-local-set-state--get "easy-mmode" "\ - - -\(fn PAIRS)" nil nil) - -(autoload 'buffer-local-restore-state "easy-mmode" "\ -Restore buffer local variable values in STATES. -STATES is an object returned by `buffer-local-set-state'. - -\(fn STATES)" nil nil) - -(register-definition-prefixes "easy-mmode" '("buffer-local-set-state" "easy-mmode-")) +(register-definition-prefixes "easy-mmode" '("easy-mmode-")) ;;;*** diff --git a/lisp/subr.el b/lisp/subr.el index dec3b9190ed..5af802fa18d 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -207,6 +207,39 @@ Also see `local-variable-p'." (:success t) (void-variable nil))) +(defmacro buffer-local-set-state (&rest pairs) + "Like `setq-local', but allow restoring the previous state of locals later. +This macro returns an object that can be passed to `buffer-local-restore-state' +in order to restore the state of the local variables set via this macro. + +\(fn [VARIABLE VALUE]...)" + (declare (debug setq)) + (unless (zerop (mod (length pairs) 2)) + (error "PAIRS must have an even number of variable/value members")) + `(prog1 + (buffer-local-set-state--get ',pairs) + (setq-local ,@pairs))) + +(defun buffer-local-set-state--get (pairs) + (let ((states nil)) + (while pairs + (push (list (car pairs) + (and (boundp (car pairs)) + (local-variable-p (car pairs))) + (and (boundp (car pairs)) + (symbol-value (car pairs)))) + states) + (setq pairs (cddr pairs))) + (nreverse states))) + +(defun buffer-local-restore-state (states) + "Restore values of buffer-local variables recorded in STATES. +STATES should be an object returned by `buffer-local-set-state'." + (pcase-dolist (`(,variable ,local ,value) states) + (if local + (set variable value) + (kill-local-variable variable)))) + (defmacro push (newelt place) "Add NEWELT to the list stored in the generalized variable PLACE. This is morally equivalent to (setf PLACE (cons NEWELT PLACE)), diff --git a/test/lisp/emacs-lisp/easy-mmode-tests.el b/test/lisp/emacs-lisp/easy-mmode-tests.el index 697bf6c2152..f6d07196727 100644 --- a/test/lisp/emacs-lisp/easy-mmode-tests.el +++ b/test/lisp/emacs-lisp/easy-mmode-tests.el @@ -60,16 +60,4 @@ (easy-mmode-test-mode 'toggle) (should (eq easy-mmode-test-mode t)))) -(ert-deftest test-local-set-state () - (setq global 1) - (with-temp-buffer - (setq-local local 2) - (let ((state (buffer-local-set-state global 10 - local 20 - unexist 30))) - (buffer-local-restore-state state) - (should (= global 1)) - (should (= local 2)) - (should-not (boundp 'unexist))))) - ;;; easy-mmode-tests.el ends here diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 3725f180f3a..6bcac2a5eba 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -1058,5 +1058,17 @@ final or penultimate step during initialization.")) (should (equal (kbd "C-x ( C-d C-x )") "")) (should (equal (kbd "C-x ( C-x )") ""))) +(ert-deftest test-local-set-state () + (setq global 1) + (with-temp-buffer + (setq-local local 2) + (let ((state (buffer-local-set-state global 10 + local 20 + unexist 30))) + (buffer-local-restore-state state) + (should (= global 1)) + (should (= local 2)) + (should-not (boundp 'unexist))))) + (provide 'subr-tests) ;;; subr-tests.el ends here -- cgit v1.2.3 From 1cda7cfb390c9612caf73e977d64d9e0eff5735c Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 6 May 2022 16:21:07 +0200 Subject: Respect help-window-keep-selected in shortdoc buttons * lisp/help-fns.el (help-fns--mention-shortdoc-groups): Respect help-window-keep-selected. * lisp/emacs-lisp/shortdoc.el (shortdoc-display-group): Allow reusing the window. --- lisp/emacs-lisp/shortdoc.el | 10 +++++++--- lisp/help-fns.el | 3 ++- 2 files changed, 9 insertions(+), 4 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index ebf3c6b1fe9..340fe766c1e 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -1298,16 +1298,20 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :eval (keymap-lookup (current-global-map) "C-x x g"))) ;;;###autoload -(defun shortdoc-display-group (group &optional function) +(defun shortdoc-display-group (group &optional function same-window) "Pop to a buffer with short documentation summary for functions in GROUP. -If FUNCTION is non-nil, place point on the entry for FUNCTION (if any)." +If FUNCTION is non-nil, place point on the entry for FUNCTION (if any). +If SAME-WINDOW, don't pop to a new window." (interactive (list (completing-read "Show summary for functions in: " (mapcar #'car shortdoc--groups)))) (when (stringp group) (setq group (intern group))) (unless (assq group shortdoc--groups) (error "No such documentation group %s" group)) - (pop-to-buffer (format "*Shortdoc %s*" group)) + (funcall (if same-window + #'pop-to-buffer-same-window + #'pop-to-buffer) + (format "*Shortdoc %s*" group)) (let ((inhibit-read-only t) (prev nil)) (erase-buffer) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 0cb2c6d5d77..927a4f0d2c4 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -837,7 +837,8 @@ the C sources, too." (insert-text-button (symbol-name group) 'action (lambda (_) - (shortdoc-display-group group object)) + (shortdoc-display-group group object + help-window-keep-selected)) 'follow-link t 'help-echo (purecopy "mouse-1, RET: show documentation group"))) groups) -- cgit v1.2.3 From 7deaa2e36bafefd5bcd1278444f93212c68ddc19 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 6 May 2022 11:09:58 -0400 Subject: * lisp/emacs-lisp/smie.el (smie-auto-fill): Fix bug#19342 --- lisp/emacs-lisp/smie.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index 2bab1319132..61d52026b38 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -1846,7 +1846,9 @@ to which that point should be aligned, if we were to reindent it.") (move-to-column fc) (syntax-ppss)))) (while - (and (with-demoted-errors "SMIE Error: %S" + ;; We silence the error completely since errors are "normal" in + ;; some cases and an error message would be annoying (bug#19342). + (and (ignore-error scan-error (save-excursion (let ((end (point)) (bsf nil) ;Best-so-far. -- cgit v1.2.3 From 0b3b295776ce723885c9997ab26d57314db2a5df Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 6 May 2022 21:13:32 +0200 Subject: Make down-list signal an error if called inside a string * lisp/emacs-lisp/lisp.el (down-list): Signal an error inside a string (bug#5588). --- lisp/emacs-lisp/lisp.el | 2 ++ 1 file changed, 2 insertions(+) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index 4aeca9c6b00..ffca0dcf4f5 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -171,6 +171,8 @@ This command assumes point is not in a string or comment. If INTERACTIVE is non-nil, as it is interactively, report errors as appropriate for this kind of usage." (interactive "^p\nd") + (when (ppss-comment-or-string-start (syntax-ppss)) + (user-error "This command doesn't work in strings or comments")) (if interactive (condition-case _ (down-list arg nil) -- cgit v1.2.3