diff options
Diffstat (limited to 'lisp/emacs-lisp')
41 files changed, 1955 insertions, 750 deletions
diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el index 03bef072709..aec6f420708 100644 --- a/lisp/emacs-lisp/backtrace.el +++ b/lisp/emacs-lisp/backtrace.el @@ -33,7 +33,6 @@ (eval-when-compile (require 'cl-lib)) (eval-when-compile (require 'pcase)) -(eval-when-compile (require 'subr-x)) ; if-let (require 'find-func) (require 'help-mode) ; Define `help-function-def' button type. (require 'lisp-mode) @@ -202,6 +201,7 @@ frames where the source code location is known.") "+" #'backtrace-multi-line "-" #'backtrace-single-line "." #'backtrace-expand-ellipses + "C-]" #'abort-recursive-edit "<follow-link>" 'mouse-face "<mouse-2>" #'mouse-select-window diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 88f98c0c6a2..f063c351e28 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -483,7 +483,7 @@ There can be multiple entries for the same NAME if it has several aliases.") `(,fn ,name . ,optimized-rest))) ((guard (when for-effect - (if-let ((tmp (byte-opt--fget fn 'side-effect-free))) + (if-let* ((tmp (byte-opt--fget fn 'side-effect-free))) (or byte-compile-delete-errors (eq tmp 'error-free))))) (byte-compile-log " %s called for effect; deleted" fn) @@ -1789,6 +1789,8 @@ See Info node `(elisp) Integer Basics'." tool-bar-pixel-width window-system ;; fringe.c fringe-bitmaps-at-pos + ;; json.c + json-serialize json-parse-string ;; keyboard.c posn-at-point posn-at-x-y ;; keymap.c @@ -1979,6 +1981,8 @@ See Info node `(elisp) Integer Basics'." length> member memq memql nth nthcdr proper-list-p rassoc rassq safe-length string-bytes string-distance string-equal string-lessp string-search string-version-lessp take value< + ;; json.c + json-serialize json-parse-string ;; search.c regexp-quote ;; syntax.c diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 366423904db..7f6723aa189 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -222,12 +222,27 @@ So far, FUNCTION can only be a symbol, not a lambda expression." (cadr elem))) val))))) +(defalias 'byte-run--anonymize-arg-list + #'(lambda (arg-list) + (mapcar (lambda (x) + (if (memq x '(&optional &rest)) + x + t)) + arg-list))) + (defalias 'byte-run--set-function-type - #'(lambda (f _args val &optional f2) + #'(lambda (f args val &optional f2) (when (and f2 (not (eq f2 f))) (error "`%s' does not match top level function `%s' inside function type \ declaration" f2 f)) + (unless (and (length= val 3) + (eq (car val) 'function) + (listp (car (cdr val)))) + (error "Type `%s' is not valid a function type" val)) + (unless (equal (byte-run--anonymize-arg-list args) + (byte-run--anonymize-arg-list (car (cdr val)))) + (error "Type `%s' incompatible with function arguments `%s'" val args)) (list 'function-put (list 'quote f) ''function-type (list 'quote val)))) @@ -556,7 +571,8 @@ See the docstrings of `defalias' and `make-obsolete' for more details." &optional access-type) "Make the byte-compiler warn that OBSOLETE-NAME is obsolete. The warning will say that CURRENT-NAME should be used instead. -If CURRENT-NAME is a string, that is the `use instead' message. +If CURRENT-NAME is a string, that is the `use instead' message. If it +is a string, it is passed through `substitute-command-keys'. WHEN should be a string indicating when the variable was first made obsolete, for example a date or a release number. ACCESS-TYPE if non-nil should specify the kind of access that will trigger diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 594052ad263..63aa9567283 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2713,7 +2713,7 @@ Call from the source buffer." (let ((newdocs (byte-compile--docstring docs kind name))) (unless (eq docs newdocs) (setq form (byte-compile--list-with-n form 3 newdocs))))) - form)) + (byte-compile-keep-pending form))) (put 'require 'byte-hunk-handler 'byte-compile-file-form-require) (defun byte-compile-file-form-require (form) @@ -5361,6 +5361,59 @@ FORM is used to provide location, `bytecomp--cus-function' and (bytecomp--cus-warn type "`%s' is not a valid type" type)) ))) +(defun bytecomp--check-cus-face-spec (spec) + "Check for mistakes in a `defface' SPEC argument." + (when (consp spec) + (dolist (sp spec) + (let ((display (car-safe sp)) + (atts (cdr-safe sp))) + (cond ((listp display) + (dolist (condition display) + (unless (memq (car-safe condition) + '(type class background min-colors supports)) + (bytecomp--cus-warn + (list sp spec) + "Bad face display condition `%S'" (car condition))))) + ((not (memq display '(t default))) + (bytecomp--cus-warn + (list sp spec) "Bad face display `%S'" display))) + (when (and (consp atts) (null (cdr atts))) + (setq atts (car atts))) ; old (DISPLAY ATTS) syntax + (while atts + (let ((attr (car atts)) + (val (cadr atts))) + (cond + ((not (keywordp attr)) + (bytecomp--cus-warn + (list atts sp spec) + "Non-keyword in face attribute list: `%S'" attr)) + ((null (cdr atts)) + (bytecomp--cus-warn + (list atts sp spec) "Missing face attribute `%s' value" attr)) + ((memq attr '( :inherit :extend + :family :foundry :width :height :weight :slant + :foreground :distant-foreground :background + :underline :overline :strike-through :box + :inverse-video :stipple :font + ;; FIXME: obsolete keywords, warn about them too? + :bold ; :bold t = :weight bold + :italic ; :italic t = :slant italic + )) + (when (eq (car-safe val) 'quote) + (bytecomp--cus-warn + (list val atts sp spec) + "Value for face attribute `%s' should not be quoted" attr))) + ((eq attr :reverse-video) + (bytecomp--cus-warn + (list atts sp spec) + (concat "Face attribute `:reverse-video' has been removed;" + " use `:inverse-video' instead"))) + (t + (bytecomp--cus-warn + (list atts sp spec) + "`%s' is not a valid face attribute keyword" attr)))) + (setq atts (cddr atts))))))) + ;; Unified handler for multiple functions with similar arguments: ;; (NAME SOMETHING DOC KEYWORD-ARGS...) (byte-defop-compiler-1 define-widget bytecomp--custom-declare) @@ -5394,6 +5447,13 @@ FORM is used to provide location, `bytecomp--cus-function' and (eq (car-safe type-arg) 'quote)) (bytecomp--check-cus-type (cadr type-arg))))))) + (when (eq fun 'custom-declare-face) + (let ((face-arg (nth 2 form))) + (when (and (eq (car-safe face-arg) 'quote) + (consp (cdr face-arg)) + (null (cddr face-arg))) + (bytecomp--check-cus-face-spec (nth 1 face-arg))))) + ;; Check :group (when (cond ((memq fun '(custom-declare-variable custom-declare-face)) @@ -5407,7 +5467,13 @@ FORM is used to provide location, `bytecomp--cus-function' and (when (and name byte-compile-current-file ; only when compiling a whole file (eq fun 'custom-declare-group)) - (setq byte-compile-current-group name)))) + (setq byte-compile-current-group name)) + + ;; Check :local + (when-let* ((val (and (eq fun 'custom-declare-variable) + (plist-get keyword-args :local))) + (_ (not (member val '(t 'permanent 'permanent-only))))) + (bytecomp--cus-warn form ":local keyword does not accept %S" val)))) (byte-compile-normal-call form)) @@ -5983,8 +6049,8 @@ and corresponding effects." :buffer :host :service :type :family :local :remote :coding :nowait :noquery :stop :filter :filter-multibyte :sentinel :log :plist :tls-parameters :server :broadcast :dontroute - :keepalive :linger :oobinline :priority :reuseaddr :bindtodevice - :use-external-socket) + :keepalive :linger :oobinline :priority :reuseaddr :nodelay + :bindtodevice :use-external-socket) '(:name :service)))) (provide 'byte-compile) diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el index 67b81ddee43..6f2f85fc765 100644 --- a/lisp/emacs-lisp/chart.el +++ b/lisp/emacs-lisp/chart.el @@ -652,7 +652,7 @@ argument to `chart-sort' to sort the lists if desired." "Compute total size of files in directory DIR and its subdirectories. DIR is assumed to be a directory, verified by the caller." (let ((size 0)) - (dolist (file (directory-files-recursively dir "." t)) + (dolist (file (directory-files-recursively dir "" t)) (let ((fsize (nth 7 (file-attributes file)))) (if (> fsize 0) (setq size diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index e6c2b8306be..dd3da9ae8c0 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -290,6 +290,7 @@ made in the style guide relating to order." Currently, all recognized keywords must be on `finder-known-keywords'." :version "25.1" :type 'boolean) +;;;###autoload(put 'checkdoc-package-keywords-flag 'safe-local-variable #'booleanp) (defvar checkdoc-style-functions nil "Hook run after the standard style check is completed. @@ -308,11 +309,12 @@ problem discovered. This is useful for adding additional checks.") (defvar checkdoc-diagnostic-buffer "*Style Warnings*" "Name of warning message buffer.") -(defcustom checkdoc-verb-check-experimental-flag t +(defcustom checkdoc-verb-check-experimental-flag nil "Non-nil means to attempt to check the voice of the doc string. This check keys off some words which are commonly misused. See the variable `checkdoc-common-verbs-wrong-voice' if you wish to add your own." - :type 'boolean) + :type 'boolean + :version "31.1") ;;;###autoload(put 'checkdoc-verb-check-experimental-flag 'safe-local-variable #'booleanp) (defvar checkdoc-generate-compile-warnings-flag nil @@ -346,6 +348,7 @@ See Info node `(elisp) Documentation Tips' for background." ;; (setq checkdoc--argument-missing-flag nil) ; optional ;; (setq checkdoc--disambiguate-symbol-flag nil) ; optional ;; (setq checkdoc--interactive-docstring-flag nil) ; optional +;; (setq checkdoc-permit-comma-termination-flag t) ; optional ;; (setq checkdoc-verb-check-experimental-flag nil) ;; Then use `M-x find-dired' ("-name '*.el'") and `M-x checkdoc-dired' @@ -1085,7 +1088,7 @@ Optional argument TAKE-NOTES causes all errors to be logged." Evaluation is done first so the form will be read before the documentation is checked. If there is a documentation error, then the display of what was evaluated will be overwritten by the diagnostic message." - (interactive) + (interactive nil emacs-lisp-mode) (call-interactively #'eval-defun) (checkdoc-defun)) @@ -1096,7 +1099,7 @@ Call `error' if the doc string has problems. If NO-ERROR is non-nil, then do not call error, but call `message' instead. If the doc string passes the test, then check the function for rogue white space at the end of each line." - (interactive) + (interactive nil emacs-lisp-mode) (save-excursion (beginning-of-defun) (when (checkdoc--next-docstring) @@ -2134,7 +2137,7 @@ Examples of recognized abbreviations: \"e.g.\", \"i.e.\", \"cf.\"." (seq (any "cC") "f") ; cf. (seq (any "eE") ".g") ; e.g. (seq (any "iI") "." (any "eE")) ; i.e. - "a.k.a" "etc" "vs" "N.B" + "a.k.a" "etc" "vs" "N.B" "U.S" ;; Some non-standard or less common ones that we ;; might as well accept. "Inc" "Univ" "misc" "resp") @@ -2473,25 +2476,33 @@ Code:, and others referenced in the style guide." (setq err (or - ;; * A footer. Not compartmentalized from lm-verify: too bad. - ;; The following is partially clipped from lm-verify + ;; * Library footer (save-excursion (goto-char (point-max)) - (if (not (re-search-backward - ;; This should match the requirement in - ;; `package-buffer-info'. - (concat "^;;; " (regexp-quote (concat fn fe)) " ends here") - nil t)) - (if (checkdoc-y-or-n-p "No identifiable footer! Add one?") - (progn - (goto-char (point-max)) - (insert "\n(provide '" fn ")\n\n;;; " fn fe " ends here\n")) - (checkdoc-create-error - (format "The footer should be: (provide '%s)\\n;;; %s%s ends here" - fn fn fe) - ;; The buffer may be empty. - (max (point-min) (1- (point-max))) - (point-max))))) + (let* ((footer-line (lm-package-needs-footer-line))) + (if (not (re-search-backward + ;; This should match the requirement in + ;; `package-buffer-info'. + (if footer-line + (concat "^;;; " (regexp-quote (concat fn fe)) " ends here") + (concat "\n(provide '" fn ")\n")) + nil t)) + (if (checkdoc-y-or-n-p (if footer-line + "No identifiable footer! Add one?" + "No `provide' statement! Add one?")) + (progn + (goto-char (point-max)) + (insert (if footer-line + (concat "\n(provide '" fn ")\n\n;;; " fn fe " ends here\n") + (concat "\n(provide '" fn ")\n")))) + (checkdoc-create-error + (if footer-line + (format "The footer should be: (provide '%s)\\n;;; %s%s ends here" + fn fn fe) + (format "The footer should be: (provide '%s)\\n" fn)) + ;; The buffer may be empty. + (max (point-min) (1- (point-max))) + (point-max)))))) err)) ;; The below checks will not return errors if the user says NO @@ -2532,14 +2543,18 @@ Code:, and others referenced in the style guide." "Search between BEG and END for a style error with message text. Optional arguments BEG and END represent the boundary of the check. The default boundary is the entire buffer." - (let ((e nil) - (type nil)) + (let ((e nil)) (if (not (or beg end)) (setq beg (point-min) end (point-max))) (goto-char beg) - (while (setq type (checkdoc-message-text-next-string end)) + (while-let ((type (checkdoc-message-text-next-string end))) (setq e (checkdoc-message-text-engine type))) e)) +(defvar checkdoc--warning-function-re + (rx (or "display-warning" "org-display-warning" + "warn" "lwarn" + "message-box"))) + (defun checkdoc-message-text-next-string (end) "Move cursor to the next checkable message string after point. Return the message classification. @@ -2552,6 +2567,7 @@ Argument END is the maximum bounds to search in." (group (or (seq (* (or wordchar (syntax symbol))) "error") + (regexp checkdoc--warning-function-re) (seq (* (or wordchar (syntax symbol))) (or "y-or-n-p" "yes-or-no-p") (? "-with-timeout")) @@ -2559,8 +2575,13 @@ Argument END is the maximum bounds to search in." (+ (any "\n\t "))) end t)) (let* ((fn (match-string 1)) - (type (cond ((string-match "error" fn) - 'error) + (type (cond ((string-match "error" fn) + 'error) + ((string-match (rx bos + (regexp checkdoc--warning-function-re) + eos) + fn) + 'warning) (t 'y-or-n-p)))) (if (string-match "checkdoc-autofix-ask-replace" fn) (progn (forward-sexp 2) @@ -2630,30 +2651,33 @@ should not end with a period, and should start with a capital letter. The function `y-or-n-p' has similar constraints. Argument TYPE specifies the type of question, such as `error' or `y-or-n-p'." ;; If type is nil, then attempt to derive it. - (if (not type) - (save-excursion - (up-list -1) - (if (looking-at "(format") - (up-list -1)) - (setq type - (cond ((looking-at "(error") - 'error) - (t 'y-or-n-p))))) + (unless type + (save-excursion + (up-list -1) + (when (looking-at "(format") + (up-list -1)) + (setq type + (cond ((looking-at "(error") + 'error) + ((looking-at + (rx "(" (regexp checkdoc--warning-function-re) + (syntax whitespace))) + 'warning) + (t 'y-or-n-p))))) (let ((case-fold-search nil)) (or ;; From the documentation of the symbol `error': ;; In Emacs, the convention is that error messages start with a capital ;; letter but *do not* end with a period. Please follow this convention ;; for the sake of consistency. - (if (and (checkdoc--error-bad-format-p) - (not (checkdoc-autofix-ask-replace - (match-beginning 1) (match-end 1) - "Capitalize your message text?" - (capitalize (match-string 1)) - t))) - (checkdoc-create-error "Messages should start with a capital letter" - (match-beginning 1) (match-end 1)) - nil) + (when (and (checkdoc--error-bad-format-p) + (not (checkdoc-autofix-ask-replace + (match-beginning 1) (match-end 1) + "Capitalize your message text?" + (capitalize (match-string 1)) + t))) + (checkdoc-create-error "Messages should start with a capital letter" + (match-beginning 1) (match-end 1))) ;; In general, sentences should have two spaces after the period. (checkdoc-sentencespace-region-engine (point) (save-excursion (forward-sexp 1) @@ -2663,19 +2687,18 @@ Argument TYPE specifies the type of question, such as `error' or `y-or-n-p'." (save-excursion (forward-sexp 1) (point))) ;; Here are message type specific questions. - (if (and (eq type 'error) - (save-excursion (forward-sexp 1) - (forward-char -2) - (looking-at "\\.")) - (not (checkdoc-autofix-ask-replace (match-beginning 0) - (match-end 0) - "Remove period from error?" - "" - t))) - (checkdoc-create-error - "Error messages should *not* end with a period" - (match-beginning 0) (match-end 0)) - nil) + (when (and (eq type 'error) + (save-excursion (forward-sexp 1) + (forward-char -2) + (looking-at "\\.")) + (not (checkdoc-autofix-ask-replace (match-beginning 0) + (match-end 0) + "Remove period from error?" + "" + t))) + (checkdoc-create-error + "Error messages should *not* end with a period" + (match-beginning 0) (match-end 0))) ;; From `(elisp) Programming Tips': "A question asked in the ;; minibuffer with `yes-or-no-p' or `y-or-n-p' should start with ;; a capital letter and end with '?'." @@ -2828,7 +2851,7 @@ function called to create the messages." ;;;###autoload (defun checkdoc-package-keywords () "Find package keywords that aren't in `finder-known-keywords'." - (interactive) + (interactive nil emacs-lisp-mode) (require 'finder) (let ((unrecognized-keys (cl-remove-if diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 1d2c8bf1f0d..ce48eb02978 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -733,6 +733,8 @@ PROPLIST is a list of the sort returned by `symbol-plist'. Call `cl--find-class' to get TYPE's propname `cl--class'" (cl--find-class type)) +(declare-function help-fns--setup-xref-backend "help-fns" ()) + ;;;###autoload (defun cl-describe-type (type &optional _buf _frame) "Display the documentation for type TYPE (a symbol)." @@ -753,6 +755,7 @@ Call `cl--find-class' to get TYPE's propname `cl--class'" ;; cl-deftype). (user-error "Unknown type %S" type)))) (with-current-buffer standard-output + (help-fns--setup-xref-backend) ;; Return the text we displayed. (buffer-string))))) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index b07a881ba48..01e7b35cc52 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2071,7 +2071,8 @@ Each definition can take the form (FUNC EXP) where FUNC is the function name, and EXP is an expression that returns the function value to which it should be bound, or it can take the more common form (FUNC ARGLIST BODY...) which is a shorthand -for (FUNC (lambda ARGLIST BODY)). +for (FUNC (lambda ARGLIST BODY)) where BODY is wrapped in +a `cl-block' named FUNC. FUNC is defined only within FORM, not BODY, so you can't write recursive function definitions. Use `cl-labels' for that. See @@ -2096,15 +2097,22 @@ info node `(cl) Function Bindings' for details. cl-declarations body))) (let ((binds ()) (newenv macroexpand-all-environment)) (dolist (binding bindings) - (let ((var (make-symbol (format "--cl-%s--" (car binding)))) - (args-and-body (cdr binding))) - (if (and (= (length args-and-body) 1) - (macroexp-copyable-p (car args-and-body))) + (let* ((var (make-symbol (format "--cl-%s--" (car binding)))) + (args-and-body (cdr binding)) + (args (car args-and-body)) + (body (cdr args-and-body))) + (if (and (null body) + (macroexp-copyable-p args)) ;; Optimize (cl-flet ((fun var)) body). - (setq var (car args-and-body)) - (push (list var (if (= (length args-and-body) 1) - (car args-and-body) - `(cl-function (lambda . ,args-and-body)))) + (setq var args) + (push (list var (if (null body) + args + (let ((parsed-body (macroexp-parse-body body))) + `(cl-function + (lambda ,args + ,@(car parsed-body) + (cl-block ,(car binding) + ,@(cdr parsed-body))))))) binds)) (push (cons (car binding) (lambda (&rest args) @@ -2247,22 +2255,43 @@ Like `cl-flet' but the definitions can refer to previous ones. . ,optimized-body)) ,retvar))))))) +(defun cl--self-tco-on-form (var form) + ;; Apply self-tco to the function returned by FORM, assuming that + ;; it will be bound to VAR. + (pcase form + (`(function (lambda ,fargs . ,ebody)) form + (pcase-let* ((`(,decls . ,body) (macroexp-parse-body ebody)) + (`(,ofargs . ,obody) (cl--self-tco var fargs body))) + `(function (lambda ,ofargs ,@decls . ,obody)))) + (`(let ,bindings ,form) + `(let ,bindings ,(cl--self-tco-on-form var form))) + (`(if ,cond ,exp1 ,exp2) + `(if ,cond ,(cl--self-tco-on-form var exp1) + ,(cl--self-tco-on-form var exp2))) + (`(oclosure--fix-type ,exp1 ,exp2) + `(oclosure--fix-type ,exp1 ,(cl--self-tco-on-form var exp2))) + (_ form))) + ;;;###autoload (defmacro cl-labels (bindings &rest body) "Make local (recursive) function definitions. -BINDINGS is a list of definitions of the form (FUNC ARGLIST BODY...) where +BINDINGS is a list of definitions of the form either (FUNC EXP) +where EXP is a form that should return the function to bind to the +function name FUNC, or (FUNC ARGLIST BODY...) where FUNC is the function name, ARGLIST its arguments, and BODY the -forms of the function body. FUNC is defined in any BODY, as well -as FORM, so you can write recursive and mutually recursive -function definitions. See info node `(cl) Function Bindings' for -details. +forms of the function body. BODY is wrapped in a `cl-block' named FUNC. +FUNC is in scope in any BODY or EXP, as well as in FORM, so you can write +recursive and mutually recursive function definitions, with the caveat +that EXPs are evaluated in sequence and you cannot call a FUNC before its +EXP has been evaluated. +See info node `(cl) Function Bindings' for details. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" (declare (indent 1) (debug cl-flet)) (let ((binds ()) (newenv macroexpand-all-environment)) (dolist (binding bindings) (let ((var (make-symbol (format "--cl-%s--" (car binding))))) - (push (cons var (cdr binding)) binds) + (push (cons var binding) binds) (push (cons (car binding) (lambda (&rest args) (if (eq (car args) cl--labels-magic) @@ -2273,18 +2302,22 @@ details. (unless (assq 'function newenv) (push (cons 'function #'cl--labels-convert) newenv)) ;; Perform self-tail call elimination. - (setq binds (mapcar - (lambda (bind) - (pcase-let* - ((`(,var ,sargs . ,sbody) bind) - (`(function (lambda ,fargs . ,ebody)) - (macroexpand-all `(cl-function (lambda ,sargs . ,sbody)) - newenv)) - (`(,ofargs . ,obody) - (cl--self-tco var fargs ebody))) - `(,var (function (lambda ,ofargs . ,obody))))) - (nreverse binds))) - `(letrec ,binds + `(letrec ,(mapcar + (lambda (bind) + (pcase-let* ((`(,var ,fun ,sargs . ,sbody) bind)) + `(,var ,(cl--self-tco-on-form + var (macroexpand-all + (if (null sbody) + sargs ;A (FUNC EXP) definition. + (let ((parsed-body + (macroexp-parse-body sbody))) + `(cl-function + (lambda ,sargs + ,@(car parsed-body) + (cl-block ,fun + ,@(cdr parsed-body)))))) + newenv))))) + (nreverse binds)) . ,(macroexp-unprogn (macroexpand-all (macroexp-progn body) diff --git a/lisp/emacs-lisp/comp-common.el b/lisp/emacs-lisp/comp-common.el index 0eeda8cef54..bffadd9bd09 100644 --- a/lisp/emacs-lisp/comp-common.el +++ b/lisp/emacs-lisp/comp-common.el @@ -510,13 +510,13 @@ comes from `comp-primitive-type-specifiers' or the function type declaration itself." (let ((kind 'declared) type-spec) - (when-let ((res (assoc function comp-primitive-type-specifiers))) + (when-let* ((res (assoc function comp-primitive-type-specifiers))) ;; Declared primitive (setf type-spec (cadr res))) (let ((f (and (symbolp function) (symbol-function function)))) (when (and f (null type-spec)) - (if-let ((delc-type (function-get function 'function-type))) + (if-let* ((delc-type (function-get function 'function-type))) ;; Declared Lisp function (setf type-spec delc-type) (when (native-comp-function-p f) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 52ed73ff5c3..3d46cc8c6ae 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -89,10 +89,10 @@ Integer values are handled in the `range' slot.") "Return all non built-in type names currently defined." (let (res) (mapatoms (lambda (x) - (when-let ((class (cl-find-class x)) - ;; Ignore EIEIO classes as they can be - ;; redefined at runtime. - (gate (not (eq 'eieio--class (type-of class))))) + (when-let* ((class (cl-find-class x)) + ;; Ignore EIEIO classes as they can be + ;; redefined at runtime. + (gate (not (eq 'eieio--class (type-of class))))) (push x res))) obarray) res)) @@ -528,8 +528,8 @@ Return them as multiple value." `(with-comp-cstr-accessors (if (or (neg src1) (neg src2)) (setf (typeset ,dst) '(number)) - (when-let ((r1 (range ,src1)) - (r2 (range ,src2))) + (when-let* ((r1 (range ,src1)) + (r2 (range ,src2))) (let* ((l1 (comp-cstr-smallest-in-range r1)) (l2 (comp-cstr-smallest-in-range r2)) (h1 (comp-cstr-greatest-in-range r1)) @@ -620,7 +620,7 @@ DST is returned." ;; Check first if we are in the simple case of all input non-negate ;; or negated so we don't have to cons. - (when-let ((res (comp--cstrs-homogeneous srcs))) + (when-let* ((res (comp--cstrs-homogeneous srcs))) (apply #'comp--cstr-union-homogeneous range dst srcs) (cl-return-from comp--cstr-union-1-no-mem dst)) @@ -805,7 +805,7 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (range dst) () (neg dst) nil) (cl-return-from comp-cstr-intersection-no-mem dst))) - (when-let ((res (comp--cstrs-homogeneous srcs))) + (when-let* ((res (comp--cstrs-homogeneous srcs))) (if (eq res 'neg) (apply #'comp--cstr-union-homogeneous t dst srcs) (apply #'comp-cstr-intersection-homogeneous dst srcs)) @@ -917,7 +917,7 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (when (and (null (neg cstr)) (null (valset cstr)) (null (typeset cstr))) - (when-let (range (range cstr)) + (when-let* ((range (range cstr))) (let* ((low (caar range)) (high (cdar (last range)))) (unless (or (eq low '-) @@ -926,15 +926,6 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (> high most-positive-fixnum)) t)))))) -(defun comp-cstr-symbol-p (cstr) - "Return t if CSTR is certainly a symbol." - (with-comp-cstr-accessors - (and (null (range cstr)) - (null (neg cstr)) - (and (or (null (typeset cstr)) - (equal (typeset cstr) '(symbol))) - (cl-every #'symbolp (valset cstr)))))) - (defsubst comp-cstr-cons-p (cstr) "Return t if CSTR is certainly a cons." (with-comp-cstr-accessors @@ -945,6 +936,8 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (defun comp-cstr-type-p (cstr type) "Return t if CSTR is certainly of type TYPE." + ;; Only basic types are valid input. + (cl-assert (symbolp type)) (when (with-comp-cstr-accessors (cl-case type @@ -956,15 +949,22 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (or (null (typeset cstr)) (equal (typeset cstr) '(integer))))))) (t - (if-let ((pred (get type 'cl-deftype-satisfies))) + (if-let* ((pred (get type 'cl-deftype-satisfies))) (and (null (range cstr)) (null (neg cstr)) - (and (or (null (typeset cstr)) - (equal (typeset cstr) `(,type))) - (cl-every pred (valset cstr)))) + (if (null (typeset cstr)) + (and (valset cstr) + (cl-every pred (valset cstr))) + (when (equal (typeset cstr) `(,type)) + ;; (valset cstr) can be nil as well. + (cl-every pred (valset cstr))))) (error "Unknown predicate for type %s" type))))) t)) +(defun comp-cstr-symbol-p (cstr) + "Return t if CSTR is certainly a symbol." + (comp-cstr-type-p cstr 'symbol)) + ;; Move to comp.el? (defsubst comp-cstr-cl-tag-p (cstr) "Return non-nil if CSTR is a CL tag." diff --git a/lisp/emacs-lisp/comp-run.el b/lisp/emacs-lisp/comp-run.el index e11ca19b0f6..984b93100f3 100644 --- a/lisp/emacs-lisp/comp-run.el +++ b/lisp/emacs-lisp/comp-run.el @@ -186,8 +186,7 @@ processes from `comp-async-compilations'" (max 1 (/ (num-processors) 2)))) native-comp-async-jobs-number)) -(defvar comp-last-scanned-async-output nil) -(make-variable-buffer-local 'comp-last-scanned-async-output) +(defvar-local comp-last-scanned-async-output nil) ;; From warnings.el (defvar warning-suppress-types) (defun comp--accept-and-process-async-output (process) @@ -371,8 +370,8 @@ Return the trampoline if found or nil otherwise." (memq subr-name native-comp-never-optimize-functions) (gethash subr-name comp-installed-trampolines-h)) (cl-assert (subr-primitive-p subr)) - (when-let ((trampoline (or (comp--trampoline-search subr-name) - (comp-trampoline-compile subr-name)))) + (when-let* ((trampoline (or (comp--trampoline-search subr-name) + (comp-trampoline-compile subr-name)))) (comp--install-trampoline subr-name trampoline))))) ;;;###autoload @@ -424,7 +423,7 @@ bytecode definition was not changed in the meantime)." (t (signal 'native-compiler-error (list "Not a file nor directory" file-or-dir))))) (dolist (file file-list) - (if-let ((entry (seq-find (lambda (x) (string= file (car x))) comp-files-queue))) + (if-let* ((entry (seq-find (lambda (x) (string= file (car x))) comp-files-queue))) ;; Most likely the byte-compiler has requested a deferred ;; compilation, so update `comp-files-queue' to reflect that. (unless (or (null load) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e2abd6dbc5b..269eae315e4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -164,6 +164,7 @@ Can be one of: `d-default', `d-impure' or `d-ephemeral'. See `comp-ctxt'.") comp--ipa-pure comp--add-cstrs comp--fwprop + comp--type-check-optim comp--tco comp--fwprop comp--remove-type-hints @@ -200,9 +201,9 @@ Useful to hook into pass checkers.") "Given FUNCTION return the corresponding `comp-constraint'." (when (symbolp function) (or (gethash function comp-primitive-func-cstr-h) - (when-let ((type (or (when-let ((f (comp--symbol-func-to-fun function))) - (comp-func-declared-type f)) - (function-get function 'function-type)))) + (when-let* ((type (or (when-let* ((f (comp--symbol-func-to-fun function))) + (comp-func-declared-type f)) + (function-get function 'function-type)))) (comp-type-spec-to-cstr type))))) ;; Keep it in sync with the `cl-deftype-satisfies' property set in @@ -616,7 +617,7 @@ In use by the back-end." (defun comp--function-pure-p (f) "Return t if F is pure." (or (get f 'pure) - (when-let ((func (comp--symbol-func-to-fun f))) + (when-let* ((func (comp--symbol-func-to-fun f))) (comp-func-pure func)))) (defun comp--alloc-class-to-container (alloc-class) @@ -792,25 +793,33 @@ clashes." :byte-func byte-code))) (maphash #'comp--intern-func-in-ctxt byte-to-native-lambdas-h))) -(cl-defmethod comp--spill-lap-function ((form list)) - "Byte-compile FORM, spilling data from the byte compiler." - (unless (memq (car-safe form) '(lambda closure)) - (signal 'native-compiler-error - '("Cannot native-compile, form is not a lambda or closure"))) +(defun comp--spill-lap-single-function (function) + "Byte-compile FUNCTION, spilling data from the byte compiler." (unless (comp-ctxt-output comp-ctxt) (setf (comp-ctxt-output comp-ctxt) (make-temp-file "comp-lambda-" nil ".eln"))) - (let* ((byte-code (byte-compile form)) + (let* ((byte-code (byte-compile function)) (c-name (comp-c-func-name "anonymous-lambda" "F"))) - (setf (comp-ctxt-top-level-forms comp-ctxt) - (list (make-byte-to-native-func-def :name '--anonymous-lambda - :c-name c-name - :byte-func byte-code))) - (maphash #'comp--intern-func-in-ctxt byte-to-native-lambdas-h))) + (setf (comp-ctxt-top-level-forms comp-ctxt) + (list (make-byte-to-native-func-def :name '--anonymous-lambda + :c-name c-name + :byte-func byte-code))) + (maphash #'comp--intern-func-in-ctxt byte-to-native-lambdas-h))) + +(cl-defmethod comp--spill-lap-function ((form list)) + "Byte-compile FORM, spilling data from the byte compiler." + (unless (eq (car-safe form) 'lambda) + (signal 'native-compiler-error + '("Cannot native-compile, form is not a lambda"))) + (comp--spill-lap-single-function form)) + +(cl-defmethod comp--spill-lap-function ((fun interpreted-function)) + "Spill data from the byte compiler for the interpreted-function FUN." + (comp--spill-lap-single-function fun)) (defun comp--intern-func-in-ctxt (_ obj) "Given OBJ of type `byte-to-native-lambda', create a function in `comp-ctxt'." - (when-let ((byte-func (byte-to-native-lambda-byte-func obj))) + (when-let* ((byte-func (byte-to-native-lambda-byte-func obj))) (let* ((lap (byte-to-native-lambda-lap obj)) (top-l-form (cl-loop for form in (comp-ctxt-top-level-forms comp-ctxt) @@ -1696,7 +1705,7 @@ into the C code forwarding the compilation unit." ;; FIXME Actually we could have another hash for this. (cl-flet ((pred (bb) (equal (comp-block-lap-addr bb) addr))) - (if-let ((pending (cl-find-if #'pred + (if-let* ((pending (cl-find-if #'pred (comp-limplify-pending-blocks comp-pass)))) (comp-block-name pending) (cl-loop for bb being the hash-value in (comp-func-blocks comp-func) @@ -1873,9 +1882,9 @@ The assume is emitted at the beginning of the block BB." rhs))) (comp-block-insns bb)))) ((pred comp--arithm-cmp-fun-p) - (when-let ((kind (if negated - (comp--negate-arithm-cmp-fun kind) - kind))) + (when-let* ((kind (if negated + (comp--negate-arithm-cmp-fun kind) + kind))) (push `(assume ,(make--comp-mvar :slot lhs-slot) (,kind ,lhs ,(if-let* ((vld (comp-cstr-imm-vld-p rhs)) @@ -1891,10 +1900,10 @@ The assume is emitted at the beginning of the block BB." (defun comp--maybe-add-vmvar (op cmp-res insns-seq) "If CMP-RES is clobbering OP emit a new constrained mvar and return it. Return OP otherwise." - (if-let ((match (eql (comp-mvar-slot op) (comp-mvar-slot cmp-res))) - (new-mvar (make--comp-mvar - :slot - (- (cl-incf (comp-func-vframe-size comp-func)))))) + (if-let* ((match (eql (comp-mvar-slot op) (comp-mvar-slot cmp-res))) + (new-mvar (make--comp-mvar + :slot + (- (cl-incf (comp-func-vframe-size comp-func)))))) (progn (push `(assume ,new-mvar ,op) (cdr insns-seq)) new-mvar) @@ -1965,7 +1974,11 @@ TARGET-BB-SYM is the symbol name of the target block." (defun comp--add-cond-cstrs-simple () "`comp--add-cstrs' worker function for each selected function." (cl-loop - for b being each hash-value of (comp-func-blocks comp-func) + ;; Don't iterate over hash values directly as + ;; `comp--add-cond-cstrs-target-block' can modify the hash table + ;; content. + for b in (cl-loop for b being each hash-value of (comp-func-blocks comp-func) + collect b) do (cl-loop named in-the-basic-block @@ -2126,14 +2139,14 @@ TARGET-BB-SYM is the symbol name of the target block." for bb being each hash-value of (comp-func-blocks comp-func) do (comp--loop-insn-in-block bb - (when-let ((match - (pcase insn - (`(set ,lhs (,(pred comp--call-op-p) ,f . ,args)) - (when-let ((cstr-f (comp--get-function-cstr f))) - (cl-values f cstr-f lhs args))) - (`(,(pred comp--call-op-p) ,f . ,args) - (when-let ((cstr-f (comp--get-function-cstr f))) - (cl-values f cstr-f nil args)))))) + (when-let* ((match + (pcase insn + (`(set ,lhs (,(pred comp--call-op-p) ,f . ,args)) + (when-let* ((cstr-f (comp--get-function-cstr f))) + (cl-values f cstr-f lhs args))) + (`(,(pred comp--call-op-p) ,f . ,args) + (when-let* ((cstr-f (comp--get-function-cstr f))) + (cl-values f cstr-f nil args)))))) (cl-multiple-value-bind (f cstr-f lhs args) match (cl-loop with gen = (comp--lambda-list-gen (comp-cstr-f-args cstr-f)) @@ -2327,14 +2340,14 @@ blocks." finger2 (comp-block-post-num b2)))) b1)) (first-processed (l) - (if-let ((p (cl-find-if #'comp-block-idom l))) + (if-let* ((p (cl-find-if #'comp-block-idom l))) p (signal 'native-ice '("can't find first preprocessed"))))) - (when-let ((blocks (comp-func-blocks comp-func)) - (entry (gethash 'entry blocks)) - ;; No point to go on if the only bb is 'entry'. - (bb0 (gethash 'bb_0 blocks))) + (when-let* ((blocks (comp-func-blocks comp-func)) + (entry (gethash 'entry blocks)) + ;; No point to go on if the only bb is 'entry'. + (bb0 (gethash 'bb_0 blocks))) (cl-loop with rev-bb-list = (comp--collect-rev-post-order entry) with changed = t @@ -2437,7 +2450,7 @@ blocks." PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (when pre-lambda (funcall pre-lambda bb)) - (when-let ((out-edges (comp-block-out-edges bb))) + (when-let* ((out-edges (comp-block-out-edges bb))) (cl-loop for ed in out-edges for child = (comp-edge-dst ed) when (eq bb (comp-block-idom child)) @@ -2495,7 +2508,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." do (comp--ssa-rename-insn insn in-frame)) (setf (comp-block-final-frame bb) (copy-sequence in-frame)) - (when-let ((out-edges (comp-block-out-edges bb))) + (when-let* ((out-edges (comp-block-out-edges bb))) (cl-loop for ed in out-edges for child = (comp-edge-dst ed) @@ -2540,26 +2553,29 @@ Return t when one or more block was removed, nil otherwise." ret t) finally return ret)) +(defun comp--ssa-function (function) + "Port into minimal SSA FUNCTION." + (let* ((comp-func function) + (ssa-status (comp-func-ssa-status function))) + (unless (eq ssa-status t) + (cl-loop + when (eq ssa-status 'dirty) + do (comp--clean-ssa function) + do (comp--compute-edges) + (comp--compute-dominator-tree) + until (null (comp--remove-unreachable-blocks))) + (comp--compute-dominator-frontiers) + (comp--log-block-info) + (comp--place-phis) + (comp--ssa-rename) + (comp--finalize-phis) + (comp--log-func comp-func 3) + (setf (comp-func-ssa-status function) t)))) + (defun comp--ssa () - "Port all functions into minimal SSA form." - (maphash (lambda (_ f) - (let* ((comp-func f) - (ssa-status (comp-func-ssa-status f))) - (unless (eq ssa-status t) - (cl-loop - when (eq ssa-status 'dirty) - do (comp--clean-ssa f) - do (comp--compute-edges) - (comp--compute-dominator-tree) - until (null (comp--remove-unreachable-blocks))) - (comp--compute-dominator-frontiers) - (comp--log-block-info) - (comp--place-phis) - (comp--ssa-rename) - (comp--finalize-phis) - (comp--log-func comp-func 3) - (setf (comp-func-ssa-status f) t)))) - (comp-ctxt-funcs-h comp-ctxt))) + "Port all functions into minimal SSA all functions." + (cl-loop for f being the hash-value in (comp-ctxt-funcs-h comp-ctxt) + do (comp--ssa-function f))) ;;; propagate pass specific code. @@ -2652,7 +2668,7 @@ Return non-nil if the function is folded successfully." ;; should do basic block pruning in order to be sure that this ;; is not dead-code. This is now left to gcc, to be ;; implemented only if we want a reliable diagnostic here. - (let* ((f (if-let (f-in-ctxt (comp--symbol-func-to-fun f)) + (let* ((f (if-let* ((f-in-ctxt (comp--symbol-func-to-fun f))) ;; If the function is IN the compilation ctxt ;; and know to be pure. (comp-func-byte-func f-in-ctxt) @@ -2669,7 +2685,7 @@ Fold the call in case." (comp-cstr-imm-vld-p (car args))) (setf f (comp-cstr-imm (car args)) args (cdr args))) - (when-let ((cstr-f (comp--get-function-cstr f))) + (when-let* ((cstr-f (comp--get-function-cstr f))) (let ((cstr (comp-cstr-f-ret cstr-f))) (when (comp-cstr-empty-p cstr) ;; Store it to be rewritten as non local exit. @@ -2802,6 +2818,69 @@ Return t if something was changed." (comp-ctxt-funcs-h comp-ctxt))) +;;; Type check optimizer pass specific code. + +;; This pass optimize-out unnecessary type checks, that is calls to +;; `type-of' and corresponding conditional branches. +;; +;; This is often advantageous in cases where a function manipulates an +;; object with several slot accesses like: +;; +;; (cl-defstruct foo a b c) +;; (defun bar (x) +;; (setf (foo-a x) 3) +;; (+ (foo-b x) (foo-c x))) +;; +;; After x is accessed and type checked once, it's proved to be of type +;; foo, and no other type checks are required. + +;; At present running this pass over the whole Emacs codebase triggers +;; the optimization of 1972 type checks. + +(defun comp--type-check-optim-block (block) + "Optimize conditional branches in BLOCK when possible." + (cl-loop + named in-the-basic-block + for insns-seq on (comp-block-insns block) + do (pcase insns-seq + (`((set ,(and (pred comp-mvar-p) mvar-tested-copy) + ,(and (pred comp-mvar-p) mvar-tested)) + (set ,(and (pred comp-mvar-p) mvar-1) + (call type-of ,(and (pred comp-mvar-p) mvar-tested-copy))) + (set ,(and (pred comp-mvar-p) mvar-2) + (call symbol-value ,(and (pred comp-cstr-cl-tag-p) mvar-tag))) + (set ,(and (pred comp-mvar-p) mvar-3) + (call memq ,(and (pred comp-mvar-p) mvar-1) ,(and (pred comp-mvar-p) mvar-2))) + (cond-jump ,(and (pred comp-mvar-p) mvar-3) ,(pred comp-mvar-p) ,bb1 ,bb2)) + (cl-assert (comp-cstr-imm-vld-p mvar-tag)) + (when (comp-cstr-type-p mvar-tested (comp-cstr-cl-tag mvar-tag)) + (comp-log (format "Optimizing conditional branch %s in function: %s" + bb1 + (comp-func-name comp-func)) + 3) + (setf (car insns-seq) '(comment "optimized by comp--type-check-optim") + (cdr insns-seq) `((jump ,bb2)) + ;; Set the SSA status as dirty so + ;; `comp--ssa-function' will remove the unreachable + ;; branches later. + (comp-func-ssa-status comp-func) 'dirty)))))) + +(defun comp--type-check-optim (_) + "Optimize conditional branches when possible." + (cl-loop + for f being each hash-value of (comp-ctxt-funcs-h comp-ctxt) + for comp-func = f + when (>= (comp-func-speed f) 2) + do (cl-loop + for b being each hash-value of (comp-func-blocks f) + do (comp--type-check-optim-block b) + finally + (progn + (when (eq (comp-func-ssa-status f) 'dirty) + (comp--ssa-function f)) + (comp--log-func comp-func 3))))) + + ;;; Call optimizer pass specific code. ;; This pass is responsible for the following optimizations: ;; - Call to subrs that are in defined in the C source and are passing through @@ -2889,14 +2968,14 @@ FUNCTION can be a function-name or byte compiled function." do (comp--loop-insn-in-block b (pcase insn (`(set ,lval (callref funcall ,f . ,rest)) - (when-let ((ok (comp-cstr-imm-vld-p f)) - (new-form (comp--call-optim-form-call - (comp-cstr-imm f) rest))) + (when-let* ((ok (comp-cstr-imm-vld-p f)) + (new-form (comp--call-optim-form-call + (comp-cstr-imm f) rest))) (setf insn `(set ,lval ,new-form)))) (`(callref funcall ,f . ,rest) - (when-let ((ok (comp-cstr-imm-vld-p f)) - (new-form (comp--call-optim-form-call - (comp-cstr-imm f) rest))) + (when-let* ((ok (comp-cstr-imm-vld-p f)) + (new-form (comp--call-optim-form-call + (comp-cstr-imm f) rest))) (setf insn new-form))))))) (defun comp--call-optim (_) @@ -3509,7 +3588,6 @@ the deferred compilation mechanism." do (comp-log (format "Pass %s took: %fs." pass time) 0)))) - (native-compiler-skip) (t (let ((err-val (cdr err))) ;; If we are doing an async native compilation print the @@ -3565,31 +3643,37 @@ the deferred compilation mechanism." Search happens in `native-comp-eln-load-path'." (cl-loop with eln-filename = (comp-el-to-eln-rel-filename filename) - for dir in native-comp-eln-load-path - for f = (expand-file-name eln-filename - (expand-file-name comp-native-version-dir - (expand-file-name - dir - invocation-directory))) + for dir in (comp-eln-load-path-eff) + for f = (expand-file-name eln-filename dir) when (file-exists-p f) do (cl-return f))) ;;;###autoload (defun native-compile (function-or-file &optional output) "Compile FUNCTION-OR-FILE into native code. -This is the synchronous entry-point for the Emacs Lisp native -compiler. FUNCTION-OR-FILE is a function symbol, a form, or the -filename of an Emacs Lisp source file. If OUTPUT is non-nil, use -it as the filename for the compiled object. If FUNCTION-OR-FILE -is a filename, if the compilation was successful return the -filename of the compiled object. If FUNCTION-OR-FILE is a -function symbol or a form, if the compilation was successful -return the compiled function." +This is the synchronous entry-point for the Emacs Lisp native compiler. +FUNCTION-OR-FILE is a function symbol, a form, an interpreted-function, +or the filename of an Emacs Lisp source file. If OUTPUT is non-nil, use +it as the filename for the compiled object. If FUNCTION-OR-FILE is a +filename, if the compilation was successful return the filename of the +compiled object. If FUNCTION-OR-FILE is a function symbol or a form, if +the compilation was successful return the compiled function." (declare (ftype (function ((or string symbol) &optional string) (or native-comp-function string)))) (comp--native-compile function-or-file nil output)) ;;;###autoload +(defun native-compile-directory (directory) + "Native compile if necessary all the .el files present in DIRECTORY. +Each .el file is native-compiled if the corresponding .eln file is not +found in any directory mentioned in `native-comp-eln-load-path'. +The search within DIRECTORY is performed recursively." + (mapc (lambda (file) + (unless (comp-lookup-eln file) + (native-compile file))) + (directory-files-recursively directory ".+\\.el\\'"))) + +;;;###autoload (defun batch-native-compile (&optional for-tarball) "Perform batch native compilation of remaining command-line arguments. @@ -3655,6 +3739,7 @@ variable \"NATIVE_DISABLED\" is set, only byte compile." (comp--write-bytecode-file eln-file) (setq command-line-args-left (cdr command-line-args-left))))) +;;;###autoload (defun native-compile-prune-cache () "Remove .eln files that aren't applicable to the current Emacs invocation." (interactive) diff --git a/lisp/emacs-lisp/cond-star.el b/lisp/emacs-lisp/cond-star.el new file mode 100644 index 00000000000..50566c97e70 --- /dev/null +++ b/lisp/emacs-lisp/cond-star.el @@ -0,0 +1,745 @@ +;;; cond-star.el --- Extended form of `cond' construct -*-lexical-binding: t; -*- + +;; Copyright (C) 2024-2025 Free Software Foundation, Inc. + +;; Maintainer: Richard Stallman <rms@gnu.org> +;; Package: emacs + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This library implements `cond*', an alternative to `pcase'. + +;; Here is the list of functions the generated code is known to call: +;; car, cdr, car-safe, cdr-safe, nth, nthcdr, null, eq, equal, eql, =, +;; vectorp, length. +;; It also uses these control and binding primitives: +;; and, or, if, progn, let, let*, setq. +;; For regexp matching only, it can call string-match and match-string. + +;; ??? If a clause starts with a keyword, +;; should the element after the keyword be treated in the usual way +;; as a pattern? Currently `cond*-non-exit-clause-substance' explicitly +;; prevents that by adding t at the front of its value. + +;;; Code: + +(require 'cl-lib) ; for cl-assert + +;;;###autoload +(defmacro cond* (&rest clauses) + "Extended form of traditional Lisp `cond' construct. +A `cond*' construct is a series of clauses, and a clause +normally has the form (CONDITION BODY...). + +CONDITION can be a Lisp expression, as in `cond'. +Or it can be one of `(pcase* PATTERN DATUM)', +`(bind* BINDINGS...)', or `(match* PATTERN DATUM)', + +`(pcase* PATTERN DATUM)' means to match DATUM against the +pattern PATTERN, using the same pattern syntax as `pcase'. +The condition counts as true if PATTERN matches DATUM. + +`(bind* BINDINGS...)' means to bind BINDINGS (as if they were in `let*') +for the body of the clause. As a condition, it counts as true +if the first binding's value is non-nil. All the bindings are made +unconditionally for whatever scope they cover. + +`(match* PATTERN DATUM)' is an alternative to `pcase*' that uses another +syntax for its patterns, see `match*'. + +When a clause's condition is true, and it exits the `cond*' +or is the last clause, the value of the last expression +in its body becomes the return value of the `cond*' construct. + +Non-exit clause: + +If a clause has only one element, or if its first element is +a `bind*' clause, this clause never exits the `cond*' construct. +Instead, control always falls through to the next clause (if any). +All bindings made in CONDITION for the BODY of the non-exit clause +are passed along to the rest of the clauses in this `cond*' construct. + +\\[match*\\] for documentation of the patterns for use in `match*'." + (cond*-convert clauses)) + +(defmacro match* (pattern _datum) + "This specifies matching DATUM against PATTERN. +It is not really a Lisp function, and it is meaningful +only in the CONDITION of a `cond*' clause. + +`_' matches any value. +KEYWORD matches that keyword. +nil matches nil. +t matches t. +SYMBOL matches any value and binds SYMBOL to that value. + If SYMBOL has been matched and bound earlier in this pattern, + it matches here the same value that it matched before. +REGEXP matches a string if REGEXP matches it. + The match must cover the entire string from its first char to its last. +ATOM (meaning any other kind of non-list not described above) + matches anything `equal' to it. +\(rx REGEXP) uses a regexp specified in s-expression form, + as in the function `rx', and matches the data that way. +\(rx REGEXP SYM0 SYM1...) uses a regexp specified in s-expression form, + and binds the symbols SYM0, SYM1, and so on + to (match-string 0 DATUM), (match-string 1 DATUM), and so on. + You can use as many SYMs as regexp matching supports. + +`OBJECT matches any value `equal' to OBJECT. +\(cons CARPAT CDRPAT) + matches a cons cell if CARPAT matches its car and CDRPAT matches its cdr. +\(list ELTPATS...) + matches a list if the ELTPATS match its elements. + The first ELTPAT should match the list's first element. + The second ELTPAT should match the list's second element. And so on. +\(vector ELTPATS...) + matches a vector if the ELTPATS match its elements. + The first ELTPAT should match the vector's first element. + The second ELTPAT should match the vector's second element. And so on. +\(cdr PATTERN) matches PATTERN with strict checking of cdrs. + That means that `list' patterns verify that the final cdr is nil. + Strict checking is the default. +\(cdr-safe PATTERN) matches PATTERN with lax checking of cdrs. + That means that `list' patterns do not examine the final cdr. +\(and CONJUNCTS...) matches each of the CONJUNCTS against the same data. + If all of them match, this pattern succeeds. + If one CONJUNCT fails, this pattern fails and does not try more CONJUNCTS. +\(or DISJUNCTS...) matches each of the DISJUNCTS against the same data. + If one DISJUNCT succeeds, this pattern succeeds + and does not try more DISJUNCTs. + If all of them fail, this pattern fails. +\(COND*-EXPANDER ...) + Here the car is a symbol that has a `cond*-expander' property + which defines how to handle it in a pattern. The property value + is a function. Trying to match such a pattern calls that + function with one argument, the pattern in question (including its car). + The function should return an equivalent pattern + to be matched instead. +\(PREDICATE SYMBOL) + matches datum if (PREDICATE DATUM) is true, + then binds SYMBOL to DATUM. +\(PREDICATE SYMBOL MORE-ARGS...) + matches datum if (PREDICATE DATUM MORE-ARGS...) is true, + then binds SYMBOL to DATUM. + MORE-ARGS... can refer to symbols bound earlier in the pattern. +\(constrain SYMBOL EXP) + matches datum if the form EXP is true. + EXP can refer to symbols bound earlier in the pattern." + ;; FIXME: `byte-compile-warn-x' is not necessarily defined here. + (byte-compile-warn-x pattern "`match*' used other than as a `cond*' condition")) + +(defun cond*-non-exit-clause-p (clause) + "If CLAUSE, a cond* clause, is a non-exit clause, return t." + (or (null (cdr-safe clause)) ;; clause has only one element. + (and (cdr-safe clause) + ;; Starts with t. + (or (eq (car clause) t) + ;; Begins with keyword. + (keywordp (car clause)))) + ;; Ends with keyword. + (keywordp (car (last clause))))) + +(defun cond*-non-exit-clause-substance (clause) + "For a non-exit cond* clause CLAUSE, return its substance. +This removes a final keyword if that's what makes CLAUSE non-exit." + (cond ((null (cdr-safe clause)) ;; clause has only one element. + clause) + ;; Starts with t or a keyword. + ;; Include t as the first element of the substance + ;; so that the following element is not treated as a pattern. + ((and (cdr-safe clause) + (or (eq (car clause) t) + (keywordp (car clause)))) + ;; Standardize on t as the first element. + (cons t (cdr clause))) + + ;; Ends with keyword. + ((keywordp (car (last clause))) + ;; Do NOT include the final keyword. + (butlast clause)))) + +(defun cond*-convert (clauses) + "Process a list of cond* clauses, CLAUSES. +Returns the equivalent Lisp expression." + (if clauses + (cond*-convert-clause (car-safe clauses) (cdr-safe clauses)))) + +(defun cond*-convert-clause (clause rest) + "Process one `cond*' clause, CLAUSE. +REST is the rest of the clauses of this cond* expression." + (if (cond*-non-exit-clause-p clause) + ;; Handle a non-exit clause. Make its bindings active + ;; around the whole rest of this cond*, treating it as + ;; a condition whose value is always t, around the rest + ;; of this cond*. + (let ((substance (cond*-non-exit-clause-substance clause))) + (cond*-convert-condition + ;; Handle the first substantial element in the non-exit clause + ;; as a matching condition. + (car substance) + ;; Any following elements in the + ;; non-exit clause are just expressions. + (cdr substance) + ;; Remaining clauses will be UNCONDIT-CLAUSES: + ;; run unconditionally and handled as a cond* body. + rest + nil nil)) + ;; Handle a normal (conditional exit) clause. + (cond*-convert-condition (car-safe clause) (cdr-safe clause) nil + rest (cond*-convert rest)))) + +(defun cond*-convert-condition (condition true-exps uncondit-clauses rest iffalse) + "Process the condition part of one cond* clause. +TRUE-EXPS is a list of Lisp expressions to be executed if this +condition is true, and inside its bindings. +UNCONDIT-CLAUSES is a list of cond*-clauses to be executed if this +condition is true, and inside its bindings. +This is used for non-exit clauses; it is nil for conditional-exit clauses. + +REST and IFFALSE are non-nil for conditional-exit clauses that are not final. +REST is a list of clauses to process after this one if +this one could have exited but does not exit. +This is used for conditional exit clauses. +IFFALSE is the value to compute after this one if +this one could have exited but does not exit. +This is used for conditional exit clauses." + (if (and uncondit-clauses rest) + (error "Clause is both exiting and non-exit")) + (let ((pat-type (car-safe condition))) + (cond ((eq pat-type 'bind*) + (let* ((bindings (cdr condition)) + (first-binding (car bindings)) + (first-variable (if (symbolp first-binding) first-binding + (car first-binding))) + (first-value (if (symbolp first-binding) nil + (cadr first-binding))) + (init-gensym (gensym "init")) + ;; BINDINGS with the initial value of the first binding + ;; replaced by INIT-GENSYM. + (mod-bindings + (cons (list first-variable init-gensym) (cdr bindings)))) + ;;; ??? Here pull out all nontrivial initial values + ;;; ??? to compute them earlier. + (if rest + ;; bind* starts an exiting clause which is not final. + ;; Therefore, must run IFFALSE. + `(let ((,init-gensym ,first-value)) + (if ,init-gensym + (let* ,mod-bindings + . ,true-exps) + ;; Always calculate all bindings' initial values, + ;; but the bindings must not cover IFFALSE. + (let* ,mod-bindings nil) + ,iffalse)) + (if uncondit-clauses + ;; bind* starts a non-exit clause which is not final. + ;; Run the TRUE-EXPS if condition value is true. + ;; Then always go on to run the UNCONDIT-CLAUSES. + (if true-exps + `(let ((,init-gensym ,first-value)) +;;; ??? Should we make the bindings a second time for the UNCONDIT-CLAUSES. +;;; as the doc string says, for uniformity with match*? + (let* ,mod-bindings + (when ,init-gensym + . ,true-exps) + ,(cond*-convert uncondit-clauses))) + `(let* ,bindings + ,(cond*-convert uncondit-clauses))) + ;; bind* starts a final clause. + ;; If there are TRUE-EXPS, run them if condition succeeded. + ;; Always make the bindings, in case the + ;; initial values have side effects. + `(let ((,init-gensym ,first-value)) + ;; Calculate all binding values unconditionally. + (let* ,mod-bindings + (when ,init-gensym + . ,true-exps))))))) + ((eq pat-type 'pcase*) + (if true-exps + (progn + (when uncondit-clauses + ;; FIXME: This happens in cases like + ;; (cond* ((match* `(,x . ,y) EXP) THEN :non-exit) + ;; (t ELSE)) + ;; where ELSE is supposed to run after THEN also (and + ;; with access to `x' and `y'). + (error ":non-exit not supported with `pcase*'")) + (cl-assert (or (null iffalse) rest)) + `(pcase ,(nth 2 condition) + (,(nth 1 condition) ,@true-exps) + (_ ,iffalse))) + (cl-assert (null iffalse)) + (cl-assert (null rest)) + `(pcase-let ((,(nth 1 condition) ,(nth 2 condition))) + (cond* . ,uncondit-clauses)))) + ((eq pat-type 'match*) + (cond*-match condition true-exps uncondit-clauses iffalse)) + (t + ;; Ordinary Lisp expression is the condition. + (if rest + ;; A nonfinal exiting clause. + ;; If condition succeeds, run the TRUE-EXPS. + ;; There are following clauses, so run IFFALSE + ;; if the condition fails. + `(if ,condition + (progn . ,true-exps) + ,iffalse) + (if uncondit-clauses + ;; A non-exit clause. + ;; If condition succeeds, run the TRUE-EXPS. + ;; Then always go on to run the UNCONDIT-CLAUSES. + `(progn (if ,condition + (progn . ,true-exps)) + ,(cond*-convert uncondit-clauses)) + ;; An exiting clause which is also final. + ;; If there are TRUE-EXPS, run them if CONDITION succeeds. + (if true-exps + `(if ,condition (progn . ,true-exps)) + ;; Run and return CONDITION. + condition))))))) + +(defun cond*-match (matchexp true-exps uncondit-clauses iffalse) + "Generate code to match a match* pattern PATTERN. +Match it against data represented by the expression DATA. +TRUE-EXPS, UNCONDIT-CLAUSES and IFFALSE have the same meanings +as in `cond*-condition'." + (when (or (null matchexp) (null (cdr-safe matchexp)) + (null (cdr-safe (cdr matchexp))) + (cdr-safe (cdr (cdr matchexp)))) + (byte-compile-warn-x matchexp "Malformed (match* ...) expression")) + (let* (raw-result + (pattern (nth 1 matchexp)) + (data (nth 2 matchexp)) + expression + (inner-data data) + ;; Add backtrack aliases for or-subpatterns to cdr of this. + (backtrack-aliases (list nil)) + run-true-exps + store-value-swap-outs retrieve-value-swap-outs + gensym) + ;; For now, always bind a gensym to the data to be matched. + (setq gensym (gensym "d") inner-data gensym) + ;; Process the whole pattern as a subpattern. + (setq raw-result (cond*-subpat pattern nil nil nil backtrack-aliases inner-data)) + (setq expression (cdr raw-result)) + ;; If there are conditional expressions and some + ;; unconditional clauses to follow, + ;; and the pattern bound some variables, + ;; copy their values into special aliases + ;; to be copied back at the start of the unconditional clauses. + (when (and uncondit-clauses true-exps + (car raw-result)) + (dolist (bound-var (car raw-result)) + (push `(setq ,(gensym "ua") ,(car bound-var)) store-value-swap-outs) + (push `(,(car bound-var) ,(gensym "ua")) retrieve-value-swap-outs))) + + ;; Make an expression to run the TRUE-EXPS inside our bindings. + (if store-value-swap-outs + ;; If we have to store those bindings' values in aliases + ;; for the UNCONDIT-CLAUSES, do so inside these bindings. + (setq run-true-exps + (cond*-bind-pattern-syms + (car raw-result) + `(prog1 (progn . ,true-exps) . ,store-value-swap-outs))) + (setq run-true-exps + (cond*-bind-pattern-syms + (car raw-result) + `(progn . ,true-exps)))) + ;; Run TRUE-EXPS if match succeeded. Bind our bindings around it. + (setq expression + (if (and (null run-true-exps) (null iffalse)) + ;; We MUST compute the expression, even when no decision + ;; depends on its value, because it may call functions with + ;; side effects. + expression + `(if ,expression + ,run-true-exps + ;; For a non-final exiting clause, run IFFALSE if match failed. + ;; Don't bind the bindings around it, since + ;; an exiting clause's bindings don't affect later clauses. + ,iffalse))) + ;; For a non-final non-exiting clause, + ;; always run the UNCONDIT-CLAUSES. + (if uncondit-clauses + (setq expression + `(progn ,expression + ,(cond*-bind-pattern-syms + (if retrieve-value-swap-outs + ;; If we saved the bindings' values after the + ;; true-clauses, bind the same variables + ;; here to the values we saved then. + retrieve-value-swap-outs + ;; Otherwise bind them to the values + ;; they matched in the pattern. + (car raw-result)) + (cond*-convert uncondit-clauses))))) + ;; Bind the backtrack-aliases if any. + ;; We need them bound for the TRUE-EXPS. + ;; It is harmless to bind them around IFFALSE + ;; because they are all gensyms anyway. + (if (cdr backtrack-aliases) + (setq expression + `(let ,(mapcar #'cdr (cdr backtrack-aliases)) + ,expression))) + (if retrieve-value-swap-outs + (setq expression + `(let ,(mapcar #'cadr retrieve-value-swap-outs) + ,expression))) + ;; If we used a gensym, wrap on code to bind it. + (if gensym + (if (and (listp expression) (eq (car expression) 'progn)) + `(let ((,gensym ,data)) . ,(cdr expression)) + `(let ((,gensym ,data)) ,expression)) + expression))) + +(defun cond*-bind-pattern-syms (bindings expr) + "Wrap EXPR in code to bind the BINDINGS. +This is used for the bindings specified explicitly in match* patterns." + ;; They can't have side effects. Skip them + ;; if we don't actually need them. + (if (equal expr '(progn)) + nil + (if bindings + (if (eq (car expr) 'progn) + `(let* ,bindings . ,(cdr expr)) + `(let* ,bindings ,expr)) + expr))) + +(defvar cond*-debug-pattern nil) + +;; ??? Structure type patterns not implemented yet. +;; ??? Probably should optimize the `nth' calls in handling `list'. + +(defun cond*-subpat (subpat cdr-ignore bindings inside-or backtrack-aliases data) + "Generate code to match the subpattern within `match*'. +SUBPAT is the subpattern to handle. +CDR-IGNORE if true means don't verify there are no extra elts in a list. +BINDINGS is the list of bindings made by +the containing and previous subpatterns of this pattern. +Each element of BINDINGS must have the form (VAR VALUE). +BACKTRACK-ALIASES is used to pass data upward. Initial call should +pass (list). The cdr of this collects backtracking aliases made for +variables bound within (or...) patterns so that the caller +can bind them etc. Each of them has the form (USER-SYMBOL . GENSYM). +DATA is the expression for the data that this subpattern is +supposed to match against. + +Return Value has the form (BINDINGS . CONDITION), where +BINDINGS is the list of bindings to be made for SUBPAT +plus the subpatterns that contain/precede it. +Each element of BINDINGS has the form (VAR VALUE). +CONDITION is the condition to be tested to decide +whether SUBPAT (as well as the subpatterns that contain/precede it) matches," + (if (equal cond*-debug-pattern subpat) + (debug)) +;;; (push subpat subpat-log) + (cond ((eq subpat '_) + ;; _ as pattern makes no bindings and matches any data. + (cons bindings t)) + ((memq subpat '(nil t)) + (cons bindings `(eq ,subpat ,data))) + ((keywordp subpat) + (cons bindings `(eq ,subpat ,data))) + ((symbolp subpat) + (let ((this-binding (assq subpat bindings)) + (this-alias (assq subpat (cdr backtrack-aliases)))) + (if this-binding + ;; Variable already bound. + ;; Compare what this variable should be bound to + ;; to the data it is supposed to match. + ;; That is because we don't actually bind these bindings + ;; around the condition-testing expression. + (cons bindings `(equal ,(cadr this-binding) ,data)) + (if inside-or + (let (alias-gensym) + (if this-alias + ;; Inside `or' subpattern, if this symbol already + ;; has an alias for backtracking, just use that. + ;; This means the symbol was matched + ;; in a previous arm of the `or'. + (setq alias-gensym (cdr this-alias)) + ;; Inside `or' subpattern, but this symbol has no alias, + ;; make an alias for it. + (setq alias-gensym (gensym "ba")) + (push (cons subpat alias-gensym) (cdr backtrack-aliases))) + ;; Make a binding for the symbol, to its backtrack-alias, + ;; and set the alias (a gensym) to nil. + (cons `((,subpat ,alias-gensym) . ,bindings) + `(setq ,alias-gensym ,data))) + ;; Not inside `or' subpattern: ask for a binding for this symbol + ;; and say it does match whatever datum. + (cons `((,subpat ,data) . ,bindings) + t))))) + ;; Various constants. + ((numberp subpat) + (cons bindings `(eql ,subpat ,data))) + ;; Regular expressions as strings. + ((stringp subpat) + (cons bindings `(string-match ,(concat subpat "\\'") ,data))) + ;; All other atoms match with `equal'. + ((not (consp subpat)) + (cons bindings `(equal ,subpat ,data))) + ((not (consp (cdr subpat))) + (byte-compile-warn-x subpat "%s subpattern with malformed or missing arguments" (car subpat))) + ;; Regular expressions specified as list structure. + ;; (rx REGEXP VARS...) + ((eq (car subpat) 'rx) + (let* ((rxpat (concat (rx-to-string (cadr subpat) t) "\\'")) + (vars (cddr subpat)) setqs (varnum 0) + (match-exp `(string-match ,rxpat ,data))) + (if (null vars) + (cons bindings match-exp) + ;; There are variables to bind to the matched substrings. + (if (> (length vars) 10) + (byte-compile-warn-x vars "Too many variables specified for matched substrings")) + (dolist (elt vars) + (unless (symbolp elt) + (byte-compile-warn-x vars "Non-symbol %s given as name for matched substring" elt))) + ;; Bind these variables to nil, before the pattern. + (setq bindings (nconc (mapcar #'list vars) bindings)) + ;; Make the expressions to set the variables. + (setq setqs (mapcar + (lambda (var) + (prog1 `(setq ,var (match-string ,varnum ,data)) + (setq varnum (1+ varnum)))) + vars)) + (cons bindings `(if ,match-exp + (progn ,@setqs t)))))) + ;; Quoted object as constant to match with `eq' or `equal'. + ((eq (car subpat) 'quote) + (if (symbolp (car-safe (cdr-safe subpat))) + (cons bindings `(eq ,subpat ,data)) + (cons bindings `(equal ,subpat ,data)))) + ;; Match a call to `cons' by destructuring. + ((eq (car subpat) 'cons) + (let (car-result cdr-result car-exp cdr-exp) + (setq car-result + (cond*-subpat (nth 1 subpat) cdr-ignore bindings inside-or backtrack-aliases `(car ,data))) + (setq bindings (car car-result) + car-exp (cdr car-result)) + (setq cdr-result + (cond*-subpat (nth 2 subpat) cdr-ignore bindings inside-or backtrack-aliases `(cdr ,data))) + (setq bindings (car cdr-result) + cdr-exp (cdr cdr-result)) + (cons bindings + (cond*-and `((consp ,data) ,car-exp ,cdr-exp))))) + ;; Match a call to `list' by destructuring. + ((eq (car subpat) 'list) + (let ((i 0) expressions) + ;; Check for bad structure of SUBPAT here? + (dolist (this-elt (cdr subpat)) + (let ((result + (cond*-subpat this-elt cdr-ignore bindings inside-or + backtrack-aliases `(nth ,i ,data)))) + (setq bindings (car result)) + (push `(consp ,(if (zerop i) data `(nthcdr ,i ,data))) + expressions) + (setq i (1+ i)) + (push (cdr result) expressions))) + ;; Verify that list ends here, if we are supposed to check that. + (unless cdr-ignore + (push `(null (nthcdr ,i ,data)) expressions)) + (cons bindings (cond*-and (nreverse expressions))))) + ;; Match (apply 'vector (backquote-list* LIST...)), destructuring. + ((eq (car subpat) 'apply) + ;; We only try to handle the case generated by backquote. + ;; Convert it to a call to `vector' and handle that. + (let ((cleaned-up + `(vector . ,(cond*-un-backquote-list* (cdr (nth 2 subpat)))))) + ;; (cdr (nth 2 subpat)) gets LIST as above. + (cond*-subpat cleaned-up + cdr-ignore bindings inside-or backtrack-aliases data))) + ;; Match a call to `vector' by destructuring. + ((eq (car subpat) 'vector) + (let* ((elts (cdr subpat)) + (length (length elts)) + expressions (i 0)) + (dolist (elt elts) + (let* ((result + (cond*-subpat elt cdr-ignore bindings inside-or + backtrack-aliases `(aref ,i ,data)))) + (setq i (1+ i)) + (setq bindings (car result)) + (push (cdr result) expressions))) + (cons bindings + (cond*-and `((vectorp ,data) (= (length ,data) ,length) + . ,(nreverse expressions)))))) + ;; Subpattern to set the cdr-ignore flag. + ((eq (car subpat) 'cdr-ignore) + (cond*-subpat (cadr subpat) t bindings inside-or backtrack-aliases data)) + ;; Subpattern to clear the cdr-ignore flag. + ((eq (car subpat) 'cdr) + (cond*-subpat (cadr subpat) nil bindings inside-or backtrack-aliases data)) + ;; Handle conjunction subpatterns. + ((eq (car subpat) 'and) + (let (expressions) + ;; Check for bad structure of SUBPAT here? + (dolist (this-elt (cdr subpat)) + (let ((result + (cond*-subpat this-elt cdr-ignore bindings inside-or + backtrack-aliases data))) + (setq bindings (car result)) + (push (cdr result) expressions))) + (cons bindings (cond*-and (nreverse expressions))))) + ;; Handle disjunction subpatterns. + ((eq (car subpat) 'or) + ;; The main complexity is unsetting the pattern variables + ;; that tentatively match in an or-branch that later failed. + (let (expressions + (bindings-before-or bindings) + (aliases-before-or (cdr backtrack-aliases))) + ;; Check for bad structure of SUBPAT here? + (dolist (this-elt (cdr subpat)) + (let* ((bindings bindings-before-or) + bindings-to-clear expression + result) + (setq result + (cond*-subpat this-elt cdr-ignore bindings t + backtrack-aliases data)) + (setq bindings (car result)) + (setq expression (cdr result)) + ;; Were any bindings made by this arm of the disjunction? + (when (not (eq bindings bindings-before-or)) + ;; OK, arrange to clear their backtrack aliases + ;; if this arm does not match. + (setq bindings-to-clear bindings) + (let (clearing) + ;; For each of those bindings, ... + (while (not (eq bindings-to-clear bindings-before-or)) + ;; ... make an expression to set it to nil, in CLEARING. + (let* ((this-variable (caar bindings-to-clear)) + (this-backtrack (assq this-variable + (cdr backtrack-aliases)))) + (push `(setq ,(cdr this-backtrack) nil) clearing)) + (setq bindings-to-clear (cdr bindings-to-clear))) + ;; Wrap EXPRESSION to clear those backtrack aliases + ;; if EXPRESSION is false. + (setq expression + (if (null clearing) + expression + (if (null (cdr clearing)) + `(or ,expression + ,(car clearing)) + `(progn ,@clearing)))))) + (push expression expressions))) + ;; At end of (or...), EACH variable bound by any arm + ;; has a backtrack alias gensym. At run time, that gensym's value + ;; will be what was bound in the successful arm, or nil. + ;; Now make a binding for each variable from its alias gensym. + (let ((aliases (cdr backtrack-aliases))) + (while (not (eq aliases aliases-before-or)) + (push `(,(caar aliases) ,(cdar aliases)) bindings) + (pop aliases))) + (cons bindings `(or . ,(nreverse expressions))))) + ;; Expand cond*-macro call, treat result as a subpattern. + ((get (car subpat) 'cond*-expander) + ;; Treat result as a subpattern. + (cond*-subpat (funcall (get (car subpat) 'cond*-expander) subpat) + cdr-ignore bindings inside-or backtrack-aliases data)) + ((macrop (car subpat)) + (cond*-subpat (macroexpand subpat) cdr-ignore bindings inside-or + backtrack-aliases data)) + ;; Simple constrained variable, as in (symbolp x). + ((functionp (car subpat)) + ;; Without this, nested constrained variables just work. + (unless (symbolp (cadr subpat)) + (byte-compile-warn-x subpat "Complex pattern nested in constrained variable pattern")) + (let* ((rest-args (cddr subpat)) + ;; Process VAR to get a binding for it. + (result (cond*-subpat (cadr subpat) cdr-ignore bindings inside-or backtrack-aliases data)) + (new-bindings (car result)) + (expression (cdr result)) + (combined-exp + (cond*-and (list `(,(car subpat) ,data . ,rest-args) expression)))) + + (cons new-bindings + (cond*-bind-around new-bindings combined-exp)))) + ;; Generalized constrained variable: (constrain VAR EXP) + ((eq (car subpat) 'constrain) + ;; Without this, nested constrained variables just work. + (unless (symbolp (cadr subpat)) + (byte-compile-warn-x subpat "Complex pattern nested in constrained variable pattern")) + ;; Process VAR to get a binding for it. + (let ((result + (cond*-subpat (cadr subpat) cdr-ignore bindings inside-or + backtrack-aliases data))) + (cons (car result) + ;; This is the test condition. + (cond*-bind-around (car result) (nth 2 subpat))))) + (t + (byte-compile-warn-x subpat "Undefined pattern type `%s' in `cond*'" (car subpat))))) + +;;; Subroutines of cond*-subpat. + +(defun cond*-bind-around (bindings exp) + "Wrap a `let*' around EXP, to bind those of BINDINGS used in EXP." + (let ((what-to-bind (cond*-used-within bindings exp))) + (if what-to-bind + `(let* ,(nreverse what-to-bind) ,exp) + exp))) + +(defun cond*-used-within (bindings exp) + "Return the list of those bindings in BINDINGS which EXP refers to. +This operates naively and errs on the side of overinclusion, +and does not distinguish function names from variable names. +That is safe for the purpose this is used for." + (cond ((symbolp exp) + (let ((which (assq exp bindings))) + (if which (list which)))) + ((listp exp) + (let (combined (rest exp)) + ;; Find the bindings used in each element of EXP + ;; and merge them together in COMBINED. + ;; It would be simpler to use dolist at each level, + ;; but this avoids errors from improper lists. + (while rest + (let ((in-this-elt (cond*-used-within bindings (car rest)))) + (while in-this-elt + ;; Don't insert the same binding twice. + (unless (memq (car-safe in-this-elt) combined) + (push (car-safe in-this-elt) combined)) + (pop in-this-elt))) + (pop rest)) + combined)))) + +;; Construct a simplified equivalent to `(and . ,CONJUNCTS), +;; assuming that it will be used only as a truth value. +;; We don't bother checking for nil in CONJUNCTS +;; because that would not normally happen. +(defun cond*-and (conjuncts) + (setq conjuncts (remq t conjuncts)) + (if (null conjuncts) + t + (if (null (cdr conjuncts)) + (car conjuncts) + `(and . ,conjuncts)))) + +;; Convert the arguments in a form that calls `backquote-list*' +;; into equivalent args to pass to `list'. +;; We assume the last argument has the form 'LIST. +;; That means quotify each of that list's elements, +;; and preserve the other arguments in front of them. +(defun cond*-un-backquote-list* (args) + (if (cdr args) + (cons (car args) + (cond*-un-backquote-list* (cdr args))) + (mapcar (lambda (x) (list 'quote x)) (cadr (car args))))) + +(provide 'cond-star) + +;;; cond-star.el ends here diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index f53db48f0b7..35f291dd1a7 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -763,6 +763,59 @@ CSS contains a list of syntax specifications of the form (CHAR . SYNTAX)." ;;; easy-mmode-define-navigation ;;; +(defun easy-mmode--prev (re name count &optional endfun narrowfun) + "Go to the COUNT'th previous occurrence of RE. + +If none, error with NAME. + +ENDFUN and NARROWFUN are treated like in `easy-mmode-define-navigation'." + (unless count (setq count 1)) + (if (< count 0) (easy-mmode--next re name (- count) endfun narrowfun) + (let ((re-narrow (and narrowfun (prog1 (buffer-narrowed-p) (widen))))) + ;; If point is inside a match for RE, move to its beginning like + ;; `backward-sexp' and other movement commands. + (when (and (not (zerop count)) + (save-excursion + ;; Make sure we're out of the current match if any. + (goto-char (if (re-search-backward re nil t 1) + (match-end 0) (point-min))) + (re-search-forward re nil t 1)) + (< (match-beginning 0) (point) (match-end 0))) + (goto-char (match-beginning 0)) + (setq count (1- count))) + (unless (re-search-backward re nil t count) + (user-error "No previous %s" name)) + (when re-narrow (funcall narrowfun))))) + +(defun easy-mmode--next (re name count &optional endfun narrowfun) + "Go to the next COUNT'th occurrence of RE. + +If none, error with NAME. + +ENDFUN and NARROWFUN are treated like in `easy-mmode-define-navigation'." + (unless count (setq count 1)) + (if (< count 0) (easy-mmode--prev re name (- count) endfun narrowfun) + (if (looking-at re) (setq count (1+ count))) + (let ((re-narrow (and narrowfun (prog1 (buffer-narrowed-p) (widen))))) + (if (not (re-search-forward re nil t count)) + (if (looking-at re) + (goto-char (or (if endfun (funcall endfun)) (point-max))) + (user-error "No next %s" name)) + (goto-char (match-beginning 0)) + (when (and (eq (current-buffer) (window-buffer)) + (called-interactively-p 'interactive)) + (let ((endpt (or (save-excursion + (if endfun (funcall endfun) + (re-search-forward re nil t 2))) + (point-max)))) + (unless (pos-visible-in-window-p endpt nil t) + (let ((ws (window-start))) + (recenter '(0)) + (if (< (window-start) ws) + ;; recenter scrolled in the wrong direction! + (set-window-start nil ws))))))) + (when re-narrow (funcall narrowfun))))) + (defmacro easy-mmode-define-navigation (base re &optional name endfun narrowfun &rest body) "Define BASE-next and BASE-prev to navigate in the buffer. @@ -780,53 +833,23 @@ BODY is executed after moving to the destination location." (let* ((base-name (symbol-name base)) (prev-sym (intern (concat base-name "-prev"))) (next-sym (intern (concat base-name "-next"))) - (when-narrowed - (lambda (body) - (if (null narrowfun) body - `(let ((was-narrowed (prog1 (buffer-narrowed-p) (widen)))) - ,body - (when was-narrowed (funcall #',narrowfun))))))) + (endfun (when endfun `#',endfun)) + (narrowfun (when narrowfun `#',narrowfun))) (unless name (setq name base-name)) - ;; FIXME: Move most of those functions's bodies to helper functions! `(progn (defun ,next-sym (&optional count) ,(format "Go to the next COUNT'th %s. Interactively, COUNT is the prefix numeric argument, and defaults to 1." name) (interactive "p") - (unless count (setq count 1)) - (if (< count 0) (,prev-sym (- count)) - (if (looking-at ,re) (setq count (1+ count))) - ,(funcall when-narrowed - `(if (not (re-search-forward ,re nil t count)) - (if (looking-at ,re) - (goto-char (or ,(if endfun `(funcall #',endfun)) (point-max))) - (user-error "No next %s" ,name)) - (goto-char (match-beginning 0)) - (when (and (eq (current-buffer) (window-buffer)) - (called-interactively-p 'interactive)) - (let ((endpt (or (save-excursion - ,(if endfun `(funcall #',endfun) - `(re-search-forward ,re nil t 2))) - (point-max)))) - (unless (pos-visible-in-window-p endpt nil t) - (let ((ws (window-start))) - (recenter '(0)) - (if (< (window-start) ws) - ;; recenter scrolled in the wrong direction! - (set-window-start nil ws)))))))) - ,@body)) + (easy-mmode--next ,re ,name count ,endfun ,narrowfun) + ,@body) (put ',next-sym 'definition-name ',base) (defun ,prev-sym (&optional count) ,(format "Go to the previous COUNT'th %s. -Interactively, COUNT is the prefix numeric argument, and defaults to 1." - (or name base-name)) +Interactively, COUNT is the prefix numeric argument, and defaults to 1." name) (interactive "p") - (unless count (setq count 1)) - (if (< count 0) (,next-sym (- count)) - ,(funcall when-narrowed - `(unless (re-search-backward ,re nil t count) - (user-error "No previous %s" ,name))) - ,@body)) + (easy-mmode--prev ,re ,name count ,endfun ,narrowfun) + ,@body) (put ',prev-sym 'definition-name ',base)))) ;; When deleting these two, also delete them from loaddefs-gen.el. diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 005865168b9..6fcce8d30e0 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1803,12 +1803,21 @@ infinite loops when the code/environment contains a circular object.") (cl-defmethod edebug--match-&-spec-op ((_ (eql '&interpose)) cursor specs) "Compute the specs for `&interpose SPEC FUN ARGS...'. -Extracts the head of the data by matching it against SPEC, -and then matches the rest by calling (FUN HEAD PF ARGS...) -where PF is the parsing function which FUN can call exactly once, -passing it the specs that it needs to match. -Note that HEAD will always be a list, since specs are defined to match -a sequence of elements." +SPECS is a list (SPEC FUN ARGS...), where SPEC is an edebug +specification, FUN is the function from the &interpose form which +transforms the edebug spec, and the optional ARGS is a list of final +arguments to be supplied to FUN. + +Extracts the head of the data by matching it against SPEC, and then +matches the rest by calling (FUN HEAD PF ARGS...). PF is the parsing +function which FUN must call exactly once, passing it one argument, the +specs that it needs to match. FUN's value must be the value of this PF +call, which in turn will be the value of this function. + +Note that HEAD will always be a list, since specs is defined to match a +sequence of elements." + ;; Note: PF is called in FUN rather than in this function, so that it + ;; can use any dynamic bindings created there. (pcase-let* ((`(,spec ,fun . ,args) specs) (exps (edebug-cursor-expressions cursor)) @@ -1817,14 +1826,14 @@ a sequence of elements." (length (edebug-cursor-expressions cursor)))) (head (seq-subseq exps 0 consumed))) (cl-assert (eq (edebug-cursor-expressions cursor) (nthcdr consumed exps))) - (apply fun `(,head - ,(lambda (newspecs) - ;; FIXME: What'd be the difference if we used - ;; `edebug-match-sublist', which is what - ;; `edebug-list-form-args' uses for the similar purpose - ;; when matching "normal" forms? - (append instrumented-head (edebug-match cursor newspecs))) - ,@args)))) + (apply fun head + (lambda (newspecs) + ;; FIXME: What'd be the difference if we used + ;; `edebug-match-sublist', which is what + ;; `edebug-list-form-args' uses for the similar purpose + ;; when matching "normal" forms? + (append instrumented-head (edebug-match cursor newspecs))) + args))) (cl-defmethod edebug--match-&-spec-op ((_ (eql '¬)) cursor specs) ;; If any specs match, then fail @@ -3922,8 +3931,8 @@ be installed in `emacs-lisp-mode-map'.") (define-obsolete-variable-alias 'global-edebug-prefix 'edebug-global-prefix "28.1") (defvar edebug-global-prefix - (when-let ((binding - (car (where-is-internal 'Control-X-prefix (list global-map))))) + (when-let* ((binding + (car (where-is-internal 'Control-X-prefix (list global-map))))) (concat binding [?X])) "Prefix key for global edebug commands, available from any buffer.") @@ -4659,8 +4668,8 @@ instrumentation for, defaulting to all functions." functions))))) ;; Remove instrumentation. (dolist (symbol functions) - (when-let ((unwrapped - (edebug--unwrap*-symbol-function symbol))) + (when-let* ((unwrapped + (edebug--unwrap*-symbol-function symbol))) (edebug--strip-plist symbol) (defalias symbol unwrapped))) (message "Removed edebug instrumentation from %s" diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 8b971b50490..475433bb221 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -769,10 +769,10 @@ dynamically set from ARGS." (let* ((slot (aref slots i)) (slot-name (eieio-slot-descriptor-name slot)) (initform (cl--slot-descriptor-initform slot))) - (unless (or (when-let ((initarg - (car (rassq slot-name - (eieio--class-initarg-tuples - this-class))))) + (unless (or (when-let* ((initarg + (car (rassq slot-name + (eieio--class-initarg-tuples + this-class))))) (plist-get initargs initarg)) ;; Those slots whose initform is constant already have ;; the right value set in the default-object. diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index ff03a365f9e..147787d3d38 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -395,8 +395,8 @@ variable `ert-resource-directory-format'. Before formatting, the file name will be trimmed using `string-trim' with arguments `ert-resource-directory-trim-left-regexp' and `ert-resource-directory-trim-right-regexp'." - `(when-let ((testfile ,(or (macroexp-file-name) - buffer-file-name))) + `(when-let* ((testfile ,(or (macroexp-file-name) + buffer-file-name))) (let ((default-directory (file-name-directory testfile))) (file-truename (if (file-accessible-directory-p "resources/") @@ -526,11 +526,7 @@ The same keyword arguments are supported as in (defun ert-gcc-is-clang-p () "Return non-nil if the `gcc' command actually runs the Clang compiler." - ;; Some macOS machines run llvm when you type gcc. (!) - ;; We can't even check if it's a symlink; it's a binary placed in - ;; "/usr/bin/gcc". So we need to check the output. - (string-match "Apple \\(LLVM\\|[Cc]lang\\)\\|Xcode\\.app" - (shell-command-to-string "gcc --version"))) + (internal--gcc-is-clang-p)) (defvar tramp-default-host-alist) (defvar tramp-methods) diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 02551bad31f..f25ba8a529c 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -328,8 +328,8 @@ DATA is displayed to the user and should state the reason for skipping." (unless (eql ,value ',default-value) (list :value ,value)) (unless (eql ,value ',default-value) - (when-let ((-explainer- - (ert--get-explainer ',fn-name))) + (when-let* ((-explainer- + (ert--get-explainer ',fn-name))) (list :explanation (apply -explainer- ,args))))) value) @@ -1316,13 +1316,9 @@ empty string." (defun ert--pp-with-indentation-and-newline (object) "Pretty-print OBJECT, indenting it to the current column of point. Ensures a final newline is inserted." - (let ((begin (point)) - (cols (current-column)) - (pp-escape-newlines t) + (let ((pp-escape-newlines t) (print-escape-control-characters t)) - (pp object (current-buffer)) - (unless (bolp) (insert "\n")) - (indent-rigidly begin (point) cols))) + (pp object (current-buffer)))) (defun ert--insert-infos (result) "Insert `ert-info' infos from RESULT into current buffer. @@ -1356,10 +1352,10 @@ RESULT must be an `ert-test-result-with-condition'." (defun ert-test-location (test) "Return a string description the source location of TEST." - (when-let ((loc - (ignore-errors - (find-function-search-for-symbol - (ert-test-name test) 'ert-deftest (ert-test-file-name test))))) + (when-let* ((loc + (ignore-errors + (find-function-search-for-symbol + (ert-test-name test) 'ert-deftest (ert-test-file-name test))))) (let* ((buffer (car loc)) (point (cdr loc)) (file (file-relative-name (buffer-file-name buffer))) @@ -1552,11 +1548,11 @@ test packages depend on each other, it might be helpful.") "Write a JUnit test report, generated from STATS." ;; https://www.ibm.com/docs/en/developer-for-zos/14.1.0?topic=formats-junit-xml-format ;; https://llg.cubic.org/docs/junit/ - (when-let ((symbol (car (apropos-internal "" #'ert-test-boundp))) - (test-file (symbol-file symbol 'ert--test)) - (test-report - (file-name-with-extension - (or ert-load-file-name test-file) "xml"))) + (when-let* ((symbol (car (apropos-internal "" #'ert-test-boundp))) + (test-file (symbol-file symbol 'ert--test)) + (test-report + (file-name-with-extension + (or ert-load-file-name test-file) "xml"))) (with-temp-file test-report (insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n") (insert (format "<testsuites name=\"%s\" tests=\"%s\" errors=\"%s\" failures=\"%s\" skipped=\"%s\" time=\"%s\">\n" @@ -2910,10 +2906,10 @@ write erts files." (setq end-before end-after start-after start-before)) ;; Update persistent specs. - (when-let ((point-char (assq 'point-char specs))) + (when-let* ((point-char (assq 'point-char specs))) (setq gen-specs (map-insert gen-specs 'point-char (cdr point-char)))) - (when-let ((code (cdr (assq 'code specs)))) + (when-let* ((code (cdr (assq 'code specs)))) (setq gen-specs (map-insert gen-specs 'code (car (read-from-string code))))) ;; Get the "after" strings. @@ -2921,12 +2917,12 @@ write erts files." (insert-buffer-substring file-buffer start-after end-after) (ert--erts-unquote) ;; Remove the newline at the end of the buffer. - (when-let ((no-newline (cdr (assq 'no-after-newline specs)))) + (when-let* ((no-newline (cdr (assq 'no-after-newline specs)))) (goto-char (point-min)) (when (re-search-forward "\n\\'" nil t) (delete-region (match-beginning 0) (match-end 0)))) ;; Get the expected "after" point. - (when-let ((point-char (cdr (assq 'point-char gen-specs)))) + (when-let* ((point-char (cdr (assq 'point-char gen-specs)))) (goto-char (point-min)) (when (search-forward point-char nil t) (delete-region (match-beginning 0) (match-end 0)) @@ -2937,13 +2933,13 @@ write erts files." (insert-buffer-substring file-buffer start-before end-before) (ert--erts-unquote) ;; Remove the newline at the end of the buffer. - (when-let ((no-newline (cdr (assq 'no-before-newline specs)))) + (when-let* ((no-newline (cdr (assq 'no-before-newline specs)))) (goto-char (point-min)) (when (re-search-forward "\n\\'" nil t) (delete-region (match-beginning 0) (match-end 0)))) (goto-char (point-min)) ;; Place point in the specified place. - (when-let ((point-char (cdr (assq 'point-char gen-specs)))) + (when-let* ((point-char (cdr (assq 'point-char gen-specs)))) (when (search-forward point-char nil t) (delete-region (match-beginning 0) (match-end 0)))) (let ((code (cdr (assq 'code gen-specs)))) diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 0a2717dfc67..0837b37023e 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -26,7 +26,7 @@ ;; The funniest thing about this is that I can't imagine why a package ;; so obviously useful as this hasn't been written before!! ;; ;;; find-func -;; (find-function-setup-keys) +;; (find-function-mode 1) ;; ;; or just: ;; @@ -323,6 +323,8 @@ customizing the candidate completions." (switch-to-buffer (find-file-noselect (find-library-name library))) (run-hooks 'find-function-after-hook))) +(defvar find-function--read-history-library nil) + ;;;###autoload (defun read-library-name () "Read and return a library name, defaulting to the one near point. @@ -351,12 +353,14 @@ if non-nil)." (when (and def (not (test-completion def table))) (setq def nil)) (completing-read (format-prompt "Library name" def) - table nil nil nil nil def)) + table nil nil nil + 'find-function--read-history-library def)) (let ((files (read-library-name--find-files dirs suffixes))) (when (and def (not (member def files))) (setq def nil)) (completing-read (format-prompt "Library name" def) - files nil t nil nil def))))) + files nil t nil + 'find-function--read-history-library def))))) (defun read-library-name--find-files (dirs suffixes) "Return a list of all files in DIRS that match SUFFIXES." @@ -575,6 +579,10 @@ is non-nil, signal an error instead." (let ((func-lib (find-function-library function lisp-only t))) (find-function-search-for-symbol (car func-lib) nil (cdr func-lib)))) +(defvar find-function--read-history-function nil) +(defvar find-function--read-history-variable nil) +(defvar find-function--read-history-face nil) + (defun find-function-read (&optional type) "Read and return an interned symbol, defaulting to the one near point. @@ -597,7 +605,9 @@ otherwise uses `variable-at-point'." (list (intern (completing-read (format-prompt "Find %s" symb prompt-type) obarray predicate - 'lambda nil nil (and symb (symbol-name symb))))))) + 'lambda nil + (intern (format "find-function--read-history-%s" prompt-type)) + (and symb (symbol-name symb))))))) (defun find-function-do-it (symbol type switch-fn) "Find Emacs Lisp SYMBOL in a buffer and display it. @@ -796,20 +806,35 @@ See `find-function-on-key'." (find-variable-other-window symb)))) ;;;###autoload +(define-minor-mode find-function-mode + "Enable some key bindings for the `find-function' family of functions." + :group 'find-function :version "31.1" :global t :lighter nil + ;; For compatibility with the historical behavior of the old + ;; `find-function-setup-keys', define our bindings at the precedence + ;; level of the global map. + :keymap nil + (pcase-dolist (`(,map ,key ,cmd) + `((,ctl-x-map "F" find-function) + (,ctl-x-4-map "F" find-function-other-window) + (,ctl-x-5-map "F" find-function-other-frame) + (,ctl-x-map "K" find-function-on-key) + (,ctl-x-4-map "K" find-function-on-key-other-window) + (,ctl-x-5-map "K" find-function-on-key-other-frame) + (,ctl-x-map "V" find-variable) + (,ctl-x-4-map "V" find-variable-other-window) + (,ctl-x-5-map "V" find-variable-other-frame) + (,ctl-x-map "L" find-library) + (,ctl-x-4-map "L" find-library-other-window) + (,ctl-x-5-map "L" find-library-other-frame))) + (if find-function-mode + (keymap-set map key cmd) + (keymap-unset map key t)))) + +;;;###autoload (defun find-function-setup-keys () - "Define some key bindings for the `find-function' family of functions." - (define-key ctl-x-map "F" 'find-function) - (define-key ctl-x-4-map "F" 'find-function-other-window) - (define-key ctl-x-5-map "F" 'find-function-other-frame) - (define-key ctl-x-map "K" 'find-function-on-key) - (define-key ctl-x-4-map "K" 'find-function-on-key-other-window) - (define-key ctl-x-5-map "K" 'find-function-on-key-other-frame) - (define-key ctl-x-map "V" 'find-variable) - (define-key ctl-x-4-map "V" 'find-variable-other-window) - (define-key ctl-x-5-map "V" 'find-variable-other-frame) - (define-key ctl-x-map "L" 'find-library) - (define-key ctl-x-4-map "L" 'find-library-other-window) - (define-key ctl-x-5-map "L" 'find-library-other-frame)) + "Turn on `find-function-mode', which see." + (find-function-mode 1)) +(make-obsolete 'find-function-setup-keys 'find-function-mode "31.1") (provide 'find-func) diff --git a/lisp/emacs-lisp/icons.el b/lisp/emacs-lisp/icons.el index 70e5f660b7f..83bbfc10cb4 100644 --- a/lisp/emacs-lisp/icons.el +++ b/lisp/emacs-lisp/icons.el @@ -119,7 +119,7 @@ If OBJECT is an icon, return the icon properties." (setq spec (icons--copy-spec spec)) ;; Let the Customize theme override. (unless inhibit-theme - (when-let ((theme-spec (cadr (car (get icon 'theme-icon))))) + (when-let* ((theme-spec (cadr (car (get icon 'theme-icon))))) (setq spec (icons--merge-spec (icons--copy-spec theme-spec) spec)))) ;; Inherit from the parent spec (recursively). (unless inhibit-inheritance @@ -149,15 +149,15 @@ If OBJECT is an icon, return the icon properties." ;; Go through all the variations in this section ;; and return the first one we can display. (dolist (icon (icon-spec-values type-spec)) - (when-let ((result - (icons--create type icon type-keywords))) + (when-let* ((result + (icons--create type icon type-keywords))) (throw 'found - (if-let ((face (plist-get type-keywords :face))) + (if-let* ((face (plist-get type-keywords :face))) (propertize result 'face face) result))))))))) (unless icon-string (error "Couldn't find any way to display the %s icon" name)) - (when-let ((help (plist-get keywords :help-echo))) + (when-let* ((help (plist-get keywords :help-echo))) (setq icon-string (propertize icon-string 'help-echo help))) (propertize icon-string 'rear-nonsticky t))))) @@ -200,18 +200,18 @@ present if the icon is represented by an image." " " 'display (let ((props (append - (if-let ((height (plist-get keywords :height))) + (if-let* ((height (plist-get keywords :height))) (list :height (if (eq height 'line) (window-default-line-height) height))) - (if-let ((width (plist-get keywords :width))) + (if-let* ((width (plist-get keywords :width))) (list :width (if (eq width 'font) (default-font-width) width))) '(:scale 1) - (if-let ((rotation (plist-get keywords :rotation))) + (if-let* ((rotation (plist-get keywords :rotation))) (list :rotation rotation)) - (if-let ((margin (plist-get keywords :margin))) + (if-let* ((margin (plist-get keywords :margin))) (list :margin margin)) (list :ascent (if (plist-member keywords :ascent) (plist-get keywords :ascent) @@ -219,10 +219,10 @@ present if the icon is represented by an image." (apply 'create-image file nil nil props)))))) (cl-defmethod icons--create ((_type (eql 'emoji)) icon _keywords) - (when-let ((font (and (display-multi-font-p) - ;; FIXME: This is not enough for ensuring - ;; display of color Emoji. - (car (internal-char-font nil ?🟠))))) + (when-let* ((font (and (display-multi-font-p) + ;; FIXME: This is not enough for ensuring + ;; display of color Emoji. + (car (internal-char-font nil ?🟠))))) (and (font-has-char-p font (aref icon 0)) icon))) diff --git a/lisp/emacs-lisp/let-alist.el b/lisp/emacs-lisp/let-alist.el index 27ce3e5c137..239a4ad69eb 100644 --- a/lisp/emacs-lisp/let-alist.el +++ b/lisp/emacs-lisp/let-alist.el @@ -36,22 +36,23 @@ ;; symbol inside body is let-bound to their cdrs in the alist. Dotted ;; symbol is any symbol starting with a `.'. Only those present in ;; the body are let-bound and this search is done at compile time. +;; A number will result in a list index. ;; ;; For instance, the following code ;; ;; (let-alist alist -;; (if (and .title .body) +;; (if (and .title.0 .body) ;; .body ;; .site ;; .site.contents)) ;; ;; essentially expands to ;; -;; (let ((.title (cdr (assq 'title alist))) +;; (let ((.title.0 (nth 0 (cdr (assq 'title alist)))) ;; (.body (cdr (assq 'body alist))) ;; (.site (cdr (assq 'site alist))) ;; (.site.contents (cdr (assq 'contents (cdr (assq 'site alist)))))) -;; (if (and .title .body) +;; (if (and .title.0 .body) ;; .body ;; .site ;; .site.contents)) @@ -93,14 +94,17 @@ symbol, and each cdr is the same symbol without the `.'." (if (string-match "\\`\\." name) clean (let-alist--list-to-sexp - (mapcar #'intern (nreverse (split-string name "\\."))) + (mapcar #'read (nreverse (split-string name "\\."))) variable)))) (defun let-alist--list-to-sexp (list var) "Turn symbols LIST into recursive calls to `cdr' `assq' on VAR." - `(cdr (assq ',(car list) - ,(if (cdr list) (let-alist--list-to-sexp (cdr list) var) - var)))) + (let ((sym (car list)) + (rest (if (cdr list) (let-alist--list-to-sexp (cdr list) var) + var))) + (cond + ((numberp sym) `(nth ,sym ,rest)) + (t `(cdr (assq ',sym ,rest)))))) (defun let-alist--remove-dot (symbol) "Return SYMBOL, sans an initial dot." @@ -116,22 +120,23 @@ symbol, and each cdr is the same symbol without the `.'." "Let-bind dotted symbols to their cdrs in ALIST and execute BODY. Dotted symbol is any symbol starting with a `.'. Only those present in BODY are let-bound and this search is done at compile time. +A number will result in a list index. For instance, the following code (let-alist alist - (if (and .title .body) + (if (and .title.0 .body) .body .site .site.contents)) essentially expands to - (let ((.title (cdr (assq \\='title alist))) + (let ((.title (nth 0 (cdr (assq \\='title alist)))) (.body (cdr (assq \\='body alist))) (.site (cdr (assq \\='site alist))) (.site.contents (cdr (assq \\='contents (cdr (assq \\='site alist)))))) - (if (and .title .body) + (if (and .title.0 .body) .body .site .site.contents)) diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index ee1dbd92188..6b50bee6fbb 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -1,7 +1,6 @@ ;;; lisp-mnt.el --- utility functions for Emacs Lisp maintainers -*- lexical-binding:t -*- -;; Copyright (C) 1992, 1994, 1997, 2000-2025 Free Software Foundation, -;; Inc. +;; Copyright (C) 1992-2025 Free Software Foundation, Inc. ;; Author: Eric S. Raymond <esr@thyrsus.com> ;; Maintainer: emacs-devel@gnu.org @@ -106,8 +105,10 @@ ;; * Code line --- exists so Lisp can know where commentary and/or ;; change-log sections end. ;; -;; * Footer line --- marks end-of-file so it can be distinguished from -;; an expanded formfeed or the results of truncation. +;; * Footer line --- marks end-of-file so it can be distinguished +;; from an expanded formfeed or the results of truncation. This is +;; required for a package to be installable by package.el in Emacs 29.1 +;; or earlier, but is optional in later versions. ;;; Code: @@ -467,6 +468,29 @@ package version (a string)." (lm--prepare-package-dependencies (package-read-from-string (mapconcat #'identity require-lines " ")))))) +(defun lm-package-needs-footer-line (&optional file) + "Return non-nil if package in current buffer needs a footer line. + +Footer lines (sometimes referred to as \"terminating comments\") look +like this: + + ;;; some-cool-package.el ends here + +Such lines are required for a package to be installable by package.el in +Emacs 29.1 or earlier, but are optional in later versions. If the +package depends on a version of Emacs where package.el requires such +comments, or if no version requirement is specified, return non-nil. + +If optional argument FILE is non-nil, use that file instead of the +current buffer." + (lm-with-file file + ;; Starting in Emacs 30.1, avoid warning if the minimum Emacs + ;; version is specified as 30.1 or later. + (let ((min-emacs (cadar (seq-filter (lambda (x) (eq (car x) 'emacs)) + (lm-package-requires))))) + (or (null min-emacs) + (version< min-emacs "30.1"))))) + (defun lm-keywords (&optional file) "Return the keywords given in file FILE, or current buffer if FILE is nil. The return is a `downcase'-ed string, or nil if no keywords @@ -533,7 +557,6 @@ absent, return nil." (if (and page (string-match (rx bol "<" (+ nonl) ">" eol) page)) (substring page 1 -1) page))) -(defalias 'lm-homepage #'lm-website) ; for backwards-compatibility ;;; Verification and synopses @@ -552,7 +575,7 @@ says display \"OK\" in temp buffer for files that have no problems. Optional argument VERBOSE specifies verbosity level. Optional argument NON-FSF-OK if non-nil means a non-FSF copyright notice is allowed." - ;; FIXME: Make obsolete in favor of checkdoc? + (declare (obsolete checkdoc "31.1")) (interactive (list nil nil t)) (let* ((ret (and verbose "Ok")) name) @@ -593,11 +616,12 @@ copyright notice is allowed." ((not (lm-code-start)) "Can't find a `Code' section marker") ((progn - (goto-char (point-max)) - (not - (re-search-backward - (rx bol ";;; " (regexp name) " ends here") - nil t))) + (when (lm-package-needs-footer-line) + (goto-char (point-max)) + (not + (re-search-backward + (rx bol ";;; " (regexp name) " ends here") + nil t)))) "Can't find the footer line") ((not (and (lm-copyright-mark) (lm-crack-copyright))) "Can't find a valid copyright notice") @@ -663,6 +687,7 @@ Prompts for bug subject TOPIC. Leaves you in a mail buffer." (define-obsolete-function-alias 'lm-code-mark #'lm-code-start "30.1") (define-obsolete-function-alias 'lm-commentary-mark #'lm-commentary-start "30.1") (define-obsolete-function-alias 'lm-history-mark #'lm-history-start "30.1") +(define-obsolete-function-alias 'lm-homepage #'lm-website "31.1") (provide 'lisp-mnt) diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 0b1e5abd1ad..2b75a5fd038 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -308,7 +308,7 @@ This will generate compile-time constants from BINDINGS." (buffer-substring-no-properties beg0 end0))))) (buffer-substring-no-properties (1+ beg0) end0)) - `(face ,font-lock-warning-face + '(face font-lock-warning-face help-echo "This \\ has no effect")))) (defun lisp--match-confusable-symbol-character (limit) @@ -490,14 +490,17 @@ This will generate compile-time constants from BINDINGS." (2 font-lock-constant-face nil t)) ;; Words inside \\[], \\<>, \\{} or \\`' tend to be for ;; `substitute-command-keys'. - (,(rx "\\\\" (or (seq "[" (group-n 1 lisp-mode-symbol) "]") + (,(rx "\\\\" (or (seq "[" + (group-n 1 (seq lisp-mode-symbol (not "\\"))) "]") (seq "`" (group-n 1 ;; allow multiple words, e.g. "C-x a" lisp-mode-symbol (* " " lisp-mode-symbol)) "'"))) (1 font-lock-constant-face prepend)) - (,(rx "\\\\" (or (seq "<" (group-n 1 lisp-mode-symbol) ">") - (seq "{" (group-n 1 lisp-mode-symbol) "}"))) + (,(rx "\\\\" (or (seq "<" + (group-n 1 (seq lisp-mode-symbol (not "\\"))) ">") + (seq "{" + (group-n 1 (seq lisp-mode-symbol (not "\\"))) "}"))) (1 font-lock-variable-name-face prepend)) ;; Ineffective backslashes (typically in need of doubling). ("\\(\\\\\\)\\([^\"\\]\\)" @@ -657,9 +660,9 @@ Lisp font lock syntactic face function." (let ((listbeg (nth 1 state))) (if (or (lisp-string-in-doc-position-p listbeg startpos) (lisp-string-after-doc-keyword-p listbeg startpos)) - font-lock-doc-face - font-lock-string-face)))) - font-lock-comment-face)) + 'font-lock-doc-face + 'font-lock-string-face)))) + 'font-lock-comment-face)) (defun lisp-adaptive-fill () "Return fill prefix found at point. @@ -1153,7 +1156,7 @@ is the buffer position of the start of the containing expression." (defun lisp--local-defform-body-p (state) "Return non-nil when at local definition body according to STATE. STATE is the `parse-partial-sexp' state for current position." - (when-let ((start-of-innermost-containing-list (nth 1 state))) + (when-let* ((start-of-innermost-containing-list (nth 1 state))) (let* ((parents (nth 9 state)) (first-cons-after (cdr parents)) (second-cons-after (cdr first-cons-after)) @@ -1171,11 +1174,11 @@ STATE is the `parse-partial-sexp' state for current position." (let (local-definitions-starting-point) (and (save-excursion (goto-char (1+ second-order-parent)) - (when-let ((head (ignore-errors - ;; FIXME: This does not distinguish - ;; between reading nil and a read error. - ;; We don't care but still, better fix this. - (read (current-buffer))))) + (when-let* ((head (ignore-errors + ;; FIXME: This does not distinguish + ;; between reading nil and a read error. + ;; We don't care but still, better fix this. + (read (current-buffer))))) (when (memq head '( cl-flet cl-labels cl-macrolet cl-flet* cl-symbol-macrolet)) ;; In what follows, we rely on (point) returning non-nil. diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index b6ebe75dbad..99305a3c619 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -36,8 +36,8 @@ This is only necessary if the opening paren or brace is not in column 0. See function `beginning-of-defun'." :type '(choice (const nil) regexp) + :local t :group 'lisp) -(make-variable-buffer-local 'defun-prompt-regexp) (defcustom parens-require-spaces t "If non-nil, add whitespace as needed when inserting parentheses. @@ -143,6 +143,14 @@ This command assumes point is not in a string or comment." (point)) nil t)))) +(defun forward-list-default-function (&optional arg) + "Default function for `forward-list-function'." + (goto-char (or (scan-lists (point) arg 0) (buffer-end arg)))) + +(defvar forward-list-function nil + "If non-nil, `forward-list' delegates to this function. +Should take the same arguments and behave similarly to `forward-list'.") + (defun forward-list (&optional arg interactive) "Move forward across one balanced group of parentheses. This command will also work on other parentheses-like expressions @@ -150,6 +158,7 @@ defined by the current language mode. With ARG, do it that many times. Negative arg -N means move backward across N groups of parentheses. This command assumes point is not in a string or comment. +Calls `forward-list-function' to do the work, if that is non-nil. If INTERACTIVE is non-nil, as it is interactively, report errors as appropriate for this kind of usage." (interactive "^p\nd") @@ -160,7 +169,9 @@ report errors as appropriate for this kind of usage." "No next group" "No previous group")))) (or arg (setq arg 1)) - (goto-char (or (scan-lists (point) arg 0) (buffer-end arg))))) + (if forward-list-function + (funcall forward-list-function arg) + (forward-list-default-function arg)))) (defun backward-list (&optional arg interactive) "Move backward across one balanced group of parentheses. @@ -169,12 +180,24 @@ defined by the current language mode. With ARG, do it that many times. Negative arg -N means move forward across N groups of parentheses. This command assumes point is not in a string or comment. +Uses `forward-list' to do the work. If INTERACTIVE is non-nil, as it is interactively, report errors as appropriate for this kind of usage." (interactive "^p\nd") (or arg (setq arg 1)) (forward-list (- arg) interactive)) +(defun down-list-default-function (&optional arg) + "Default function for `down-list-function'." + (let ((inc (if (> arg 0) 1 -1))) + (while (/= arg 0) + (goto-char (or (scan-lists (point) inc -1) (buffer-end arg))) + (setq arg (- arg inc))))) + +(defvar down-list-function nil + "If non-nil, `down-list' delegates to this function. +Should take the same arguments and behave similarly to `down-list'.") + (defun down-list (&optional arg interactive) "Move forward down one level of parentheses. This command will also work on other parentheses-like expressions @@ -182,20 +205,21 @@ defined by the current language mode. With ARG, do this that many times. A negative argument means move backward but still go down a level. This command assumes point is not in a string or comment. +Calls `down-list-function' to do the work, if that is non-nil. 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)) + (when (and (null down-list-function) + (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) (scan-error (user-error "At bottom level"))) (or arg (setq arg 1)) - (let ((inc (if (> arg 0) 1 -1))) - (while (/= arg 0) - (goto-char (or (scan-lists (point) inc -1) (buffer-end arg))) - (setq arg (- arg inc)))))) + (if down-list-function + (funcall down-list-function arg) + (down-list-default-function arg)))) (defun backward-up-list (&optional arg escape-strings no-syntax-crossing) "Move backward out of one level of parentheses. @@ -215,6 +239,10 @@ On error, location of point is unspecified." (interactive "^p\nd\nd") (up-list (- (or arg 1)) escape-strings no-syntax-crossing)) +(defvar up-list-function nil + "If non-nil, `up-list' delegates to this function. +Should take the same arguments and behave similarly to `up-list'.") + (defun up-list (&optional arg escape-strings no-syntax-crossing) "Move forward out of one level of parentheses. This command will also work on other parentheses-like expressions @@ -231,6 +259,12 @@ end of a list broken across multiple strings. On error, location of point is unspecified." (interactive "^p\nd\nd") + (if up-list-function + (funcall up-list-function arg escape-strings no-syntax-crossing) + (up-list-default-function arg escape-strings no-syntax-crossing))) + +(defun up-list-default-function (&optional arg escape-strings no-syntax-crossing) + "Default function for `up-list-function'." (or arg (setq arg 1)) (let ((inc (if (> arg 0) 1 -1)) (pos nil)) @@ -850,10 +884,18 @@ It's used by the command `delete-pair'. The value 0 disables blinking." :group 'lisp :version "28.1") +(defcustom delete-pair-push-mark nil + "Non-nil means `delete-pair' pushes mark at end of delimited region." + :type 'boolean + :group 'lisp + :version "31.1") + (defun delete-pair (&optional arg) "Delete a pair of characters enclosing ARG sexps that follow point. A negative ARG deletes a pair around the preceding ARG sexps instead. -The option `delete-pair-blink-delay' can disable blinking." +The option `delete-pair-blink-delay' can disable blinking. With +`delete-pair-push-mark' enabled, pushes a mark at the end of the +enclosed region." (interactive "P") (if arg (setq arg (prefix-numeric-value arg)) @@ -887,7 +929,9 @@ The option `delete-pair-blink-delay' can disable blinking." (when (and (numberp delete-pair-blink-delay) (> delete-pair-blink-delay 0)) (sit-for delete-pair-blink-delay)) - (delete-char -1))) + (delete-char -1) + (when delete-pair-push-mark + (push-mark)))) (delete-char 1)))) (defun raise-sexp (&optional n) diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el index 0f136df1fe2..ad78b5fbae3 100644 --- a/lisp/emacs-lisp/loaddefs-gen.el +++ b/lisp/emacs-lisp/loaddefs-gen.el @@ -295,7 +295,7 @@ expression, in which case we want to handle forms differently." (null (plist-get props :set)) (error nil))) ;; Propagate the :safe property to the loaddefs file. - ,@(when-let ((safe (plist-get props :safe))) + ,@(when-let* ((safe (plist-get props :safe))) `((put ',varname 'safe-local-variable ,safe)))))) ;; Extract theme properties. @@ -413,8 +413,8 @@ don't include." (save-excursion ;; Since we're "open-coding", we have to repeat more ;; complicated logic in `hack-local-variables'. - (when-let ((beg - (re-search-forward "read-symbol-shorthands: *" nil t))) + (when-let* ((beg + (re-search-forward "read-symbol-shorthands: *" nil t))) ;; `read-symbol-shorthands' alist ends with two parens. (let* ((end (re-search-forward ")[;\n\s]*)")) (commentless (replace-regexp-in-string @@ -499,7 +499,7 @@ don't include." (when (and autoload-compute-prefixes compute-prefixes) (with-demoted-errors "%S" - (when-let + (when-let* ((form (loaddefs-generate--compute-prefixes load-name))) ;; This output needs to always go in the main loaddefs.el, ;; regardless of `generated-autoload-file'. diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index bede6ed7d4a..4b6f77cc940 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -41,7 +41,8 @@ This is to preserve the data in it in the event of a (defmacro macroexp--with-extended-form-stack (expr &rest body) "Evaluate BODY with EXPR pushed onto `byte-compile-form-stack'." - (declare (indent 1)) + (declare (indent 1) + (debug (sexp body))) `(let ((byte-compile-form-stack (cons ,expr byte-compile-form-stack))) ,@body)) diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index 2d24f783958..14cbbfda033 100644 --- a/lisp/emacs-lisp/map-ynp.el +++ b/lisp/emacs-lisp/map-ynp.el @@ -135,8 +135,10 @@ The function's value is the number of actions taken." mouse-event last-nonmenu-event)) (setq user-keys (if action-alist (concat (mapconcat (lambda (elt) - (key-description - (vector (car elt)))) + (substitute-command-keys + (format "\\`%s'" + (key-description + (vector (car elt)))))) action-alist ", ") " ") "") @@ -165,10 +167,13 @@ The function's value is the number of actions taken." 'quit)) ;; Prompt in the echo area. (let ((cursor-in-echo-area (not no-cursor-in-echo-area))) - (message (apply 'propertize "%s(y, n, !, ., q, %sor %s) " - minibuffer-prompt-properties) - prompt user-keys - (key-description (vector help-char))) + (message (substitute-command-keys + (format + (apply #'propertize + "%s(\\`y', \\`n', \\`!', \\`.', \\`q', %sor \\`%s') " + minibuffer-prompt-properties) + prompt user-keys + (key-description (vector help-char))))) (if minibuffer-auto-raise (raise-frame (window-frame (minibuffer-window)))) (unwind-protect @@ -184,12 +189,14 @@ The function's value is the number of actions taken." (when (fboundp 'set-text-conversion-style) (set-text-conversion-style text-conversion-style))) ;; Show the answer to the question. - (message "%s(y, n, !, ., q, %sor %s) %s" - prompt user-keys - (key-description (vector help-char)) - (if (equal char -1) - "[end-of-keyboard-macro]" - (single-key-description char)))) + (message (substitute-command-keys + (format + "%s(\\`y', \\`n', \\`!', \\`.', \\`q', %sor \\`%s') %s" + prompt user-keys + (key-description (vector help-char)) + (if (equal char -1) + "[end-of-keyboard-macro]" + (single-key-description char)))))) (setq def (lookup-key map (vector char)))) (cond ((eq def 'exit) (setq next (lambda () nil))) @@ -264,8 +271,10 @@ Type \\`SPC' or \\`y' to %s the current %s; (funcall try-again)) (t ;; Random char. - (message "Type %s for help." - (key-description (vector help-char))) + (message (substitute-command-keys + (format + "Type \\`%s' for help" + (key-description (vector help-char))))) (beep) (sit-for 1) (funcall try-again)))) diff --git a/lisp/emacs-lisp/multisession.el b/lisp/emacs-lisp/multisession.el index 966afb0a9e3..264516ad509 100644 --- a/lisp/emacs-lisp/multisession.el +++ b/lisp/emacs-lisp/multisession.el @@ -170,56 +170,60 @@ DOC should be a doc string, and ARGS are keywords as applicable to "create unique index multisession_idx on multisession (package, key)"))))) (cl-defmethod multisession-backend-value ((_type (eql 'sqlite)) object) - (multisession--ensure-db) - (let ((id (list (multisession--package object) - (multisession--key object)))) - (cond - ;; We have no value yet; check the database. - ((eq (multisession--cached-value object) multisession--unbound) - (let ((stored - (car - (sqlite-select - multisession--db - "select value, sequence from multisession where package = ? and key = ?" - id)))) - (if stored - (let ((value (car (read-from-string (car stored))))) - (setf (multisession--cached-value object) value - (multisession--cached-sequence object) (cadr stored)) - value) - ;; Nothing; return the initial value. - (multisession--initial-value object)))) - ;; We have a value, but we want to update in case some other - ;; Emacs instance has updated. - ((multisession--synchronized object) - (let ((stored - (car - (sqlite-select - multisession--db - "select value, sequence from multisession where sequence > ? and package = ? and key = ?" - (cons (multisession--cached-sequence object) id))))) - (if stored - (let ((value (car (read-from-string (car stored))))) - (setf (multisession--cached-value object) value - (multisession--cached-sequence object) (cadr stored)) - value) - ;; Nothing, return the cached value. - (multisession--cached-value object)))) - ;; Just return the cached value. - (t - (multisession--cached-value object))))) + (if (not (sqlite-available-p)) + (cl-call-next-method) + (multisession--ensure-db) + (let ((id (list (multisession--package object) + (multisession--key object)))) + (cond + ;; We have no value yet; check the database. + ((eq (multisession--cached-value object) multisession--unbound) + (let ((stored + (car + (sqlite-select + multisession--db + "select value, sequence from multisession where package = ? and key = ?" + id)))) + (if stored + (let ((value (car (read-from-string (car stored))))) + (setf (multisession--cached-value object) value + (multisession--cached-sequence object) (cadr stored)) + value) + ;; Nothing; return the initial value. + (multisession--initial-value object)))) + ;; We have a value, but we want to update in case some other + ;; Emacs instance has updated. + ((multisession--synchronized object) + (let ((stored + (car + (sqlite-select + multisession--db + "select value, sequence from multisession where sequence > ? and package = ? and key = ?" + (cons (multisession--cached-sequence object) id))))) + (if stored + (let ((value (car (read-from-string (car stored))))) + (setf (multisession--cached-value object) value + (multisession--cached-sequence object) (cadr stored)) + value) + ;; Nothing, return the cached value. + (multisession--cached-value object)))) + ;; Just return the cached value. + (t + (multisession--cached-value object)))))) (cl-defmethod multisession--backend-set-value ((_type (eql 'sqlite)) object value) - (catch 'done - (let ((i 0)) - (while (< i 10) - (condition-case nil - (throw 'done (multisession--set-value-sqlite object value)) - (sqlite-locked-error - (setq i (1+ i)) - (sleep-for (+ 0.1 (/ (float (random 10)) 10)))))) - (signal 'sqlite-locked-error "Database is locked")))) + (if (not (sqlite-available-p)) + (cl-call-next-method) + (catch 'done + (let ((i 0)) + (while (< i 10) + (condition-case nil + (throw 'done (multisession--set-value-sqlite object value)) + (sqlite-locked-error + (setq i (1+ i)) + (sleep-for (+ 0.1 (/ (float (random 10)) 10)))))) + (signal 'sqlite-locked-error "Database is locked"))))) (defun multisession--set-value-sqlite (object value) (multisession--ensure-db) @@ -245,16 +249,20 @@ DOC should be a doc string, and ARGS are keywords as applicable to (setf (multisession--cached-value object) value)))) (cl-defmethod multisession--backend-values ((_type (eql 'sqlite))) - (multisession--ensure-db) - (sqlite-select - multisession--db - "select package, key, value from multisession order by package, key")) + (if (not (sqlite-available-p)) + (cl-call-next-method) + (multisession--ensure-db) + (sqlite-select + multisession--db + "select package, key, value from multisession order by package, key"))) (cl-defmethod multisession--backend-delete ((_type (eql 'sqlite)) object) - (sqlite-execute multisession--db - "delete from multisession where package = ? and key = ?" - (list (multisession--package object) - (multisession--key object)))) + (if (not (sqlite-available-p)) + (cl-call-next-method) + (sqlite-execute multisession--db + "delete from multisession where package = ? and key = ?" + (list (multisession--package object) + (multisession--key object))))) ;; Files Backend @@ -420,8 +428,8 @@ storage method to list." (tabulated-list-print t) (goto-char (point-min)) (when id - (when-let ((match - (text-property-search-forward 'tabulated-list-id id t))) + (when-let* ((match + (text-property-search-forward 'tabulated-list-id id t))) (goto-char (prop-match-beginning match)))))) (defun multisession-delete-value (id) @@ -448,7 +456,7 @@ storage method to list." (let* ((object (or ;; If the multisession variable already exists, use ;; it (so that we update it). - (if-let (sym (intern-soft (cdr id))) + (if-let* ((sym (intern-soft (cdr id)))) (and (boundp sym) (symbol-value sym)) nil) ;; Create a new object. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 29602c30e13..a18841fb64d 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -63,71 +63,19 @@ (defconst package-vc--elpa-packages-version 1 "Version number of the package specification format understood by package-vc.") -(defconst package-vc--backend-type - `(choice :convert-widget - ,(lambda (widget) - (let (opts) - (dolist (be vc-handled-backends) - (when (or (vc-find-backend-function be 'clone) - (alist-get 'clone (get be 'vc-functions))) - (push (widget-convert (list 'const be)) opts))) - (widget-put widget :args opts)) - widget)) - "The type of VC backends that support cloning package VCS repositories.") - -(defcustom package-vc-heuristic-alist - `((,(rx bos "http" (? "s") "://" - (or (: (? "www.") "github.com" - "/" (+ (or alnum "-" "." "_")) - "/" (+ (or alnum "-" "." "_"))) - (: "codeberg.org" - "/" (+ (or alnum "-" "." "_")) - "/" (+ (or alnum "-" "." "_"))) - (: (? "www.") "gitlab" (+ "." (+ alnum)) - "/" (+ (or alnum "-" "." "_")) - "/" (+ (or alnum "-" "." "_"))) - (: "git.sr.ht" - "/~" (+ (or alnum "-" "." "_")) - "/" (+ (or alnum "-" "." "_"))) - (: "git." (or "savannah" "sv") "." (? "non") "gnu.org/" - (or "r" "git") "/" - (+ (or alnum "-" "." "_")) (? "/"))) - (or (? "/") ".git") eos) - . Git) - (,(rx bos "http" (? "s") "://" - (or (: "hg.sr.ht" - "/~" (+ (or alnum "-" "." "_")) - "/" (+ (or alnum "-" "." "_"))) - (: "hg." (or "savannah" "sv") "." (? "non") "gnu.org/hgweb/" - (+ (or alnum "-" "." "_")) (? "/"))) - eos) - . Hg) - (,(rx bos "http" (? "s") "://" - (or (: "bzr." (or "savannah" "sv") "." (? "non") "gnu.org/r/" - (+ (or alnum "-" "." "_")) (? "/"))) - eos) - . Bzr)) - "Alist mapping repository URLs to VC backends. -`package-vc-install' consults this alist to determine the VC -backend from the repository URL when you call it without -specifying a backend. Each element of the alist has the form -\(URL-REGEXP . BACKEND). `package-vc-install' will use BACKEND of -the first association for which the URL of the repository matches -the URL-REGEXP of the association. If no match is found, -`package-vc-install' uses `package-vc-default-backend' instead." - :type `(alist :key-type (regexp :tag "Regular expression matching URLs") - :value-type ,package-vc--backend-type) - :version "29.1") +(define-obsolete-variable-alias + 'package-vc-heuristic-alist + 'vc-clone-heuristic-alist "31.1") (defcustom package-vc-default-backend 'Git "Default VC backend to use for cloning package repositories. `package-vc-install' uses this backend when you specify neither the backend nor a repository URL that's recognized via -`package-vc-heuristic-alist'. +`vc-clone-heuristic-alist'. The value must be a member of `vc-handled-backends' that supports the `clone' VC function." - :type package-vc--backend-type + :type vc-cloneable-backends-custom-type :version "29.1") (defcustom package-vc-register-as-project t @@ -247,8 +195,8 @@ This function is meant to be used as a hook for `package-read-archive-hook'." (car spec))) (setf (alist-get (intern archive) package-vc--archive-data-alist) (cdr spec)) - (when-let ((default-vc (plist-get (cdr spec) :default-vc)) - ((not (memq default-vc vc-handled-backends)))) + (when-let* ((default-vc (plist-get (cdr spec) :default-vc)) + ((not (memq default-vc vc-handled-backends)))) (warn "Archive `%S' expects missing VC backend %S" archive (plist-get (cdr spec) :default-vc))))))))) @@ -279,7 +227,7 @@ asynchronously." (defun package-vc--version (pkg) "Return the version number for the VC package PKG." (cl-assert (package-vc-p pkg)) - (if-let ((main-file (package-vc--main-file pkg))) + (if-let* ((main-file (package-vc--main-file pkg))) (with-temp-buffer (insert-file-contents main-file) (package-strip-rcs-id @@ -626,13 +574,6 @@ documentation and marking the package as installed." ""))) t)) -(defun package-vc--guess-backend (url) - "Guess the VC backend for URL. -This function will internally query `package-vc-heuristic-alist' -and return nil if it cannot reasonably guess." - (and url (alist-get url package-vc-heuristic-alist - nil nil #'string-match-p))) - (declare-function project-remember-projects-under "project" (dir &optional recursive)) (defun package-vc--clone (pkg-desc pkg-spec dir rev) @@ -646,7 +587,7 @@ attribute in PKG-SPEC." (unless (file-exists-p dir) (make-directory (file-name-directory dir) t) (let ((backend (or (plist-get pkg-spec :vc-backend) - (package-vc--guess-backend url) + (vc-guess-url-backend url) (plist-get (alist-get (package-desc-archive pkg-desc) package-vc--archive-data-alist nil nil #'string=) @@ -663,7 +604,7 @@ attribute in PKG-SPEC." ;; Check out the latest release if requested (when (eq rev :last-release) - (if-let ((release-rev (package-vc--release-rev pkg-desc))) + (if-let* ((release-rev (package-vc--release-rev pkg-desc))) (vc-retrieve-tag dir release-rev) (message "No release revision was found, continuing..."))))) @@ -753,7 +694,7 @@ VC packages that have already been installed." ;; pointing towards a repository, and use that as a backup (and-let* ((extras (package-desc-extras (cadr pkg))) (url (alist-get :url extras)) - ((package-vc--guess-backend url))))))) + ((vc-guess-url-backend url))))))) (not allow-url))) (defun package-vc--read-package-desc (prompt &optional installed) @@ -868,7 +809,7 @@ If PACKAGE is a string, it specifies the URL of the package repository. In this case, optional argument BACKEND specifies the VC backend to use for cloning the repository; if it's nil, this function tries to infer which backend to use according to -the value of `package-vc-heuristic-alist' and if that fails it +the value of `vc-clone-heuristic-alist' and if that fails it uses `package-vc-default-backend'. Optional argument NAME specifies the package name in this case; if it's nil, this package uses `file-name-base' on the URL to obtain the package @@ -917,7 +858,7 @@ installs takes precedence." (cdr package) rev)) ((and-let* (((stringp package)) - (backend (or backend (package-vc--guess-backend package)))) + (backend (or backend (vc-guess-url-backend package)))) (package-vc--unpack (package-desc-create :name (or name (intern (file-name-base package))) @@ -930,7 +871,7 @@ installs takes precedence." (or (package-vc--desc->spec (cadr desc)) (and-let* ((extras (package-desc-extras (cadr desc))) (url (alist-get :url extras)) - (backend (package-vc--guess-backend url))) + (backend (vc-guess-url-backend url))) (list :vc-backend backend :url url)) (user-error "Package `%s' has no VC data" package)) rev))) @@ -958,7 +899,7 @@ for the last released version of the package." (let ((pkg-spec (or (package-vc--desc->spec pkg-desc) (and-let* ((extras (package-desc-extras pkg-desc)) (url (alist-get :url extras)) - (backend (package-vc--guess-backend url))) + (backend (vc-guess-url-backend url))) (list :vc-backend backend :url url)) (user-error "Package `%s' has no VC data" (package-desc-name pkg-desc))))) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index be3b85f3179..be8dc3f8377 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -858,22 +858,22 @@ byte-compilation of the new package to fail." (cl-remove-if-not #'stringp (mapcar #'car load-history))))) (dolist (file files) - (when-let ((library (package--library-stem - (file-relative-name file dir))) - (canonical (locate-library library nil effective-path)) - (truename (file-truename canonical)) - ;; Normally, all files in a package are compiled by - ;; now, but don't assume that. E.g. different - ;; versions can add or remove `no-byte-compile'. - (altname (if (string-suffix-p ".el" truename) - (replace-regexp-in-string - "\\.el\\'" ".elc" truename t) - (replace-regexp-in-string - "\\.elc\\'" ".el" truename t))) - (found (or (member truename history) - (and (not (string= altname truename)) - (member altname history)))) - (recent-index (length found))) + (when-let* ((library (package--library-stem + (file-relative-name file dir))) + (canonical (locate-library library nil effective-path)) + (truename (file-truename canonical)) + ;; Normally, all files in a package are compiled by + ;; now, but don't assume that. E.g. different + ;; versions can add or remove `no-byte-compile'. + (altname (if (string-suffix-p ".el" truename) + (replace-regexp-in-string + "\\.el\\'" ".elc" truename t) + (replace-regexp-in-string + "\\.elc\\'" ".el" truename t))) + (found (or (member truename history) + (and (not (string= altname truename)) + (member altname history)))) + (recent-index (length found))) (unless (equal (file-name-base library) (format "%s-autoloads" (package-desc-name pkg-desc))) (push (cons (expand-file-name library dir) recent-index) result)))) @@ -1161,6 +1161,7 @@ Signal an error if the entire string was not used." (declare-function lm-keywords-list "lisp-mnt" (&optional file)) (declare-function lm-maintainers "lisp-mnt" (&optional file)) (declare-function lm-authors "lisp-mnt" (&optional file)) +(declare-function lm-package-needs-footer-line "lisp-mnt" (&optional file)) (defun package-buffer-info () "Return a `package-desc' describing the package in the current buffer. @@ -1180,14 +1181,9 @@ boundaries." ;; requirement for a "footer line" without unduly impacting users ;; on earlier Emacs versions. See Bug#26490 for more details. (unless (search-forward (concat ";;; " file-name ".el ends here") nil 'move) - ;; Starting in Emacs 30.1, avoid warning if the minimum Emacs - ;; version is specified as 30.1 or later. - (let ((min-emacs (cadar (seq-filter (lambda (x) (eq (car x) 'emacs)) - (lm-package-requires))))) - (when (or (null min-emacs) - (version< min-emacs "30.1")) - (lwarn '(package package-format) :warning - "Package lacks a terminating comment")))) + (when (lm-package-needs-footer-line) + (lwarn '(package package-format) :warning + "Package lacks a terminating comment"))) ;; Try to include a trailing newline. (forward-line) (narrow-to-region start (point)) @@ -1755,7 +1751,7 @@ The variable `package-load-list' controls which packages to load." (setq file (expand-file-name file)) (let ((context (epg-make-context 'OpenPGP))) (when package-gnupghome-dir - (with-file-modes 448 + (with-file-modes #o700 (make-directory package-gnupghome-dir t)) (setf (epg-context-home-directory context) package-gnupghome-dir)) (message "Importing %s..." (file-name-nondirectory file)) @@ -1833,10 +1829,11 @@ Populate `package-archive-contents' with the result. If optional argument ASYNC is non-nil, perform the downloads asynchronously." (dolist (archive package-archives) - (condition-case-unless-debug nil + (condition-case-unless-debug err (package--download-one-archive archive "archive-contents" async) - (error (message "Failed to download `%s' archive." - (car archive)))))) + (error (message "Failed to download `%s' archive: %s" + (car archive) + (error-message-string err)))))) (defvar package-refresh-contents-hook (list #'package--download-and-read-archives) "List of functions to call to refresh the package archive. @@ -1860,7 +1857,8 @@ downloads in the background." (when (and (package-check-signature) (file-exists-p default-keyring)) (condition-case-unless-debug error (package-import-keyring default-keyring) - (error (message "Cannot import default keyring: %S" (cdr error)))))) + (error (message "Cannot import default keyring: %s" + (error-message-string error)))))) (run-hook-with-args 'package-refresh-contents-hook async)) @@ -2442,9 +2440,10 @@ directory." (defun package-install-selected-packages (&optional noconfirm) "Ensure packages in `package-selected-packages' are installed. If some packages are not installed, propose to install them. -If optional argument NOCONFIRM is non-nil, don't ask for -confirmation to install packages." - (interactive) + +If optional argument NOCONFIRM is non-nil, or when invoked with a prefix +argument, don't ask for confirmation to install packages." + (interactive "P") (package--archives-initialize) ;; We don't need to populate `package-selected-packages' before ;; using here, because the outcome is the same either way (nothing @@ -2621,26 +2620,31 @@ are invalid due to changed byte-code, macros or the like." (package-recompile pkg-desc)))) ;;;###autoload -(defun package-autoremove () +(defun package-autoremove (&optional noconfirm) "Remove packages that are no longer needed. Packages that are no more needed by other packages in `package-selected-packages' and their dependencies -will be deleted." - (interactive) +will be deleted. + +If optional argument NOCONFIRM is non-nil, or when invoked with a prefix +argument, don't ask for confirmation to install packages." + (interactive "P") ;; If `package-selected-packages' is nil, it would make no sense to ;; try to populate it here, because then `package-autoremove' will ;; do absolutely nothing. - (when (or package-selected-packages + (when (or noconfirm + package-selected-packages (yes-or-no-p (format-message "`package-selected-packages' is empty! Really remove ALL packages? "))) (let ((removable (package--removable-packages))) (if removable - (when (y-or-n-p - (format "Packages to delete: %d (%s), proceed? " - (length removable) - (mapconcat #'symbol-name removable " "))) + (when (or noconfirm + (y-or-n-p + (format "Packages to delete: %d (%s), proceed? " + (length removable) + (mapconcat #'symbol-name removable " ")))) (mapc (lambda (p) (package-delete (cadr (assq p package-alist)) t)) removable)) @@ -2702,7 +2706,7 @@ in a clean environment." `(add-to-list 'package-directory-list ,dir)) (cons package-user-dir package-directory-list)) (setq package-load-list ',package-load-list) - (package-initialize))))))) + (package-activate-all))))))) ;;;; Package description buffer. @@ -2870,7 +2874,7 @@ Helper function for `describe-package'." 'action #'package-delete-button-action 'package-desc desc))) (incompatible-reason - (insert (propertize "Incompatible" 'font-lock-face font-lock-warning-face) + (insert (propertize "Incompatible" 'font-lock-face 'font-lock-warning-face) " because it depends on ") (if (stringp incompatible-reason) (insert "Emacs " incompatible-reason ".") @@ -3995,8 +3999,9 @@ Return nil if there were no errors; non-nil otherwise." (package-delete elt nil 'nosave)) (error (push (package-desc-full-name elt) errors) - (message "Error trying to delete `%s': %S" - (package-desc-full-name elt) err))))) + (message "Error trying to delete `%s': %s" + (package-desc-full-name elt) + (error-message-string err)))))) errors)) (defun package--update-selected-packages (add remove) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 73554fd66fd..a6a4751f49a 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -84,14 +84,17 @@ (defun pcase--edebug-match-pat-args (head pf) ;; (cl-assert (null (cdr head))) (setq head (car head)) - (or (alist-get head '((quote sexp) - (or &rest pcase-PAT) - (and &rest pcase-PAT) - (guard form) - (pred &or ("not" pcase-FUN) pcase-FUN) - (app pcase-FUN pcase-PAT))) - (let ((me (pcase--get-macroexpander head))) - (funcall pf (and me (symbolp me) (edebug-get-spec me)))))) + (let ((specs + (or + (alist-get head '((quote sexp) + (or &rest pcase-PAT) + (and &rest pcase-PAT) + (guard form) + (pred &or ("not" pcase-FUN) pcase-FUN) + (app pcase-FUN pcase-PAT))) + (let ((me (pcase--get-macroexpander head))) + (and me (symbolp me) (edebug-get-spec me)))))) + (funcall pf specs))) (defun pcase--get-macroexpander (s) "Return the macroexpander for pcase pattern head S, or nil." @@ -181,6 +184,7 @@ Emacs Lisp manual for more information and examples." (let* ((main (documentation (symbol-function 'pcase) 'raw)) (ud (help-split-fundoc main 'pcase))) (require 'help-fns) + (declare-function help-fns-short-filename "help-fns" (filename)) (declare-function help-fns--signature "help-fns" (function doc real-def real-function buffer)) (with-temp-buffer @@ -213,9 +217,7 @@ Emacs Lisp manual for more information and examples." (save-excursion (forward-char -1) (insert (format-message " in `")) - ;; `file-name-nondirectory' is naive, but - ;; `help-fns-short-filename' is not fast enough yet (bug#73766). - (help-insert-xref-button (file-name-nondirectory filename) + (help-insert-xref-button (help-fns-short-filename filename) 'help-function-def symbol filename 'pcase-macro) (insert (format-message "'.")))) @@ -242,9 +244,14 @@ not signal an error." ;;;###autoload (defmacro pcase-lambda (lambda-list &rest body) "Like `lambda' but allow each argument to be a pattern. -I.e. accepts the usual &optional and &rest keywords, but every -formal argument can be any pattern accepted by `pcase' (a mere -variable name being but a special case of it)." +I.e. accepts the usual &optional and &rest keywords, but every formal +argument can be any pattern destructed by `pcase-let' (a mere variable +name being but a special case of it). + +Each argument should match its respective pattern in the parameter +list (i.e. be of a compatible structure); a mismatch may signal an error +or may go undetected, binding arguments to arbitrary values, such as +nil." (declare (doc-string 2) (indent defun) (debug (&define (&rest pcase-PAT) lambda-doc def-body))) (let* ((bindings ()) @@ -1170,7 +1177,11 @@ The predicate is the logical-AND of: `'(,(cadr upata) . ,(cadr upatd)) `(and (pred consp) (app car-safe ,upata) - (app cdr-safe ,upatd))))) + (app cdr-safe ,upatd) + ,@(when (eq (car qpat) '\`) + `((guard ,(macroexp-warn-and-return + "Nested ` are not supported in Pcase patterns" + t nil nil qpat)))))))) ((or (stringp qpat) (numberp qpat) (symbolp qpat)) `',qpat) ;; In all other cases just raise an error so we can't break ;; backward compatibility when adding \` support for other diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index 169f11b1db6..e4fa4426c03 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -308,17 +308,24 @@ can handle, whenever this is possible. Uses the pretty-printing code specified in `pp-default-function'. Output stream is STREAM, or value of `standard-output' (which see)." - (cond - ((and (eq (or stream standard-output) (current-buffer)) - ;; Make sure the current buffer is setup sanely. - (eq (syntax-table) emacs-lisp-mode-syntax-table) - (eq indent-line-function #'lisp-indent-line)) - ;; Skip the buffer->string->buffer middle man. - (funcall pp-default-function object) - ;; Preserve old behavior of (usually) finishing with a newline. - (unless (bolp) (insert "\n"))) - (t - (princ (pp-to-string object) (or stream standard-output))))) + (let ((stream (or stream standard-output))) + (cond + ((and (eq stream (current-buffer)) + ;; Make sure the current buffer is setup sanely. + (eq (syntax-table) emacs-lisp-mode-syntax-table) + (eq indent-line-function #'lisp-indent-line)) + ;; Skip the buffer->string->buffer middle man. + (funcall pp-default-function object) + ;; Preserve old behavior of (usually) finishing with a newline. + (unless (bolp) (insert "\n"))) + (t + (save-current-buffer + (when (bufferp stream) (set-buffer stream)) + (let ((begin (point)) + (cols (current-column))) + (princ (pp-to-string object) (or stream standard-output)) + (when (and (> cols 0) (bufferp stream)) + (indent-rigidly begin (point) cols)))))))) ;;;###autoload (defun pp-display-expression (expression out-buffer-name &optional lisp) @@ -484,8 +491,8 @@ the bounds of a region containing Lisp code to pretty-print." (cons (cond ((consp (cdr sexp)) (let ((head (car sexp))) - (if-let (((null (cddr sexp))) - (syntax-entry (assq head pp--quoting-syntaxes))) + (if-let* (((null (cddr sexp))) + (syntax-entry (assq head pp--quoting-syntaxes))) (progn (insert (cdr syntax-entry)) (pp--insert-lisp (cadr sexp))) diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index 5ee191fce56..a0c8e4d607f 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -52,7 +52,6 @@ ;; (repeat N FORM) (= N FORM) ;; (syntax CHARACTER) (syntax NAME) ;; (syntax CHAR-SYM) [1] (syntax NAME) -;; (category chinse-two-byte) (category chinese-two-byte) ;; unibyte ascii ;; multibyte nonascii ;; -------------------------------------------------------- @@ -1011,7 +1010,6 @@ Return (REGEXP . PRECEDENCE)." (not-at-beginning-of-line . ?>) (alpha-numeric-two-byte . ?A) (chinese-two-byte . ?C) - (chinse-two-byte . ?C) ; A typo in Emacs 21.1-24.3. (greek-two-byte . ?G) (japanese-hiragana-two-byte . ?H) (indian-two-byte . ?I) diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 2fa0652bc5c..27e039eff9b 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -336,10 +336,61 @@ This construct can only be used with lexical binding." (cl-labels ((,name ,fargs . ,body)) #',name) . ,aargs))) +(defvar work-buffer--list nil) +(defvar work-buffer-limit 10 + "Maximum number of reusable work buffers. +When this limit is exceeded, newly allocated work buffers are +automatically killed, which means that in a such case +`with-work-buffer' becomes equivalent to `with-temp-buffer'.") + +(defsubst work-buffer--get () + "Get a work buffer." + (let ((buffer (pop work-buffer--list))) + (if (buffer-live-p buffer) + buffer + (generate-new-buffer " *work*" t)))) + +(defun work-buffer--release (buffer) + "Release work BUFFER." + (if (buffer-live-p buffer) + (with-current-buffer buffer + ;; Flush BUFFER before making it available again, i.e. clear + ;; its contents, remove all overlays and buffer-local + ;; variables. Is it enough to safely reuse the buffer? + (let ((inhibit-read-only t) + ;; Avoid deactivating the region as side effect. + deactivate-mark) + (erase-buffer)) + (delete-all-overlays) + (let (change-major-mode-hook) + (kill-all-local-variables t)) + ;; Make the buffer available again. + (push buffer work-buffer--list))) + ;; If the maximum number of reusable work buffers is exceeded, kill + ;; work buffer in excess, taking into account that the limit could + ;; have been let-bound to temporarily increase its value. + (when (> (length work-buffer--list) work-buffer-limit) + (mapc #'kill-buffer (nthcdr work-buffer-limit work-buffer--list)) + (setq work-buffer--list (ntake work-buffer-limit work-buffer--list)))) + ;;;###autoload -(defun string-pixel-width (string) - "Return the width of STRING in pixels. +(defmacro with-work-buffer (&rest body) + "Create a work buffer, and evaluate BODY there like `progn'. +Like `with-temp-buffer', but reuse an already created temporary +buffer when possible, instead of creating a new one on each call." + (declare (indent 0) (debug t)) + (let ((work-buffer (make-symbol "work-buffer"))) + `(let ((,work-buffer (work-buffer--get))) + (with-current-buffer ,work-buffer + (unwind-protect + (progn ,@body) + (work-buffer--release ,work-buffer)))))) +;;;###autoload +(defun string-pixel-width (string &optional buffer) + "Return the width of STRING in pixels. +If BUFFER is non-nil, use the face remappings from that buffer when +determining the width. If you call this function to measure pixel width of a string with embedded newlines, it returns the width of the widest substring that does not include newlines." @@ -348,15 +399,26 @@ substring that does not include newlines." 0 ;; Keeping a work buffer around is more efficient than creating a ;; new temporary buffer. - (with-current-buffer (get-buffer-create " *string-pixel-width*") - ;; If `display-line-numbers' is enabled in internal buffers - ;; (e.g. globally), it breaks width calculation (bug#59311) - (setq-local display-line-numbers nil) - (delete-region (point-min) (point-max)) - ;; Disable line-prefix and wrap-prefix, for the same reason. - (setq line-prefix nil - wrap-prefix nil) - (insert (propertize string 'line-prefix nil 'wrap-prefix nil)) + (with-work-buffer + (if buffer + (setq-local face-remapping-alist + (with-current-buffer buffer + face-remapping-alist)) + (kill-local-variable 'face-remapping-alist)) + ;; Avoid deactivating the region as side effect. + (let (deactivate-mark) + (insert string)) + ;; If `display-line-numbers' is enabled in internal + ;; buffers (e.g. globally), it breaks width calculation + ;; (bug#59311). Disable `line-prefix' and `wrap-prefix', + ;; for the same reason. + (add-text-properties + (point-min) (point-max) '(display-line-numbers-disable t)) + ;; Prefer `remove-text-properties' to `propertize' to avoid + ;; creating a new string on each call. + (remove-text-properties + (point-min) (point-max) '(line-prefix nil wrap-prefix nil)) + (setq line-prefix nil wrap-prefix nil) (car (buffer-text-pixel-size nil nil t))))) ;;;###autoload @@ -418,7 +480,7 @@ this defaults to the current buffer." (t disp))) ;; Remove any old instances. - (when-let ((old (assoc prop disp))) + (when-let* ((old (assoc prop disp))) (setq disp (delete old disp))) (setq disp (cons (list prop value) disp)) (when vector diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 60fef3c51ee..40b2fb0886b 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -492,8 +492,8 @@ changing `tabulated-list-sort-key'." (if groups (dolist (group groups) (insert (car group) ?\n) - (when-let ((saved-pt-new (tabulated-list-print-entries - (cdr group) sorter update entry-id))) + (when-let* ((saved-pt-new (tabulated-list-print-entries + (cdr group) sorter update entry-id))) (setq saved-pt saved-pt-new))) (setq saved-pt (tabulated-list-print-entries entries sorter update entry-id))) diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el index 9b60be76f7f..b007e3c9091 100644 --- a/lisp/emacs-lisp/testcover.el +++ b/lisp/emacs-lisp/testcover.el @@ -469,7 +469,7 @@ or return multiple values." ;; form to look odd. See bug#25316. 'testcover-1value) - (`(\` ,bq-form) + (`(,'\` ,bq-form) (testcover-analyze-coverage-backquote-form bq-form)) ((or 't 'nil (pred keywordp)) @@ -548,7 +548,7 @@ FORM is treated as if it will be evaluated." 'testcover-1value)) ((pred atom) 'testcover-1value) - (`(\` ,bq-form) + (`(,'\` ,bq-form) (testcover-analyze-coverage-backquote-form bq-form)) (`(defconst ,sym ,val . ,_) (push sym testcover-module-constants) diff --git a/lisp/emacs-lisp/timer-list.el b/lisp/emacs-lisp/timer-list.el index 168f5961a87..0c28887a20a 100644 --- a/lisp/emacs-lisp/timer-list.el +++ b/lisp/emacs-lisp/timer-list.el @@ -41,23 +41,21 @@ nil `[ ;; Idle. ,(propertize - (if (aref timer 7) " *" " ") + (if (timer--idle-delay timer) " *" " ") 'help-echo "* marks idle timers" 'timer timer) ;; Next time. ,(propertize - (let ((time (list (aref timer 1) - (aref timer 2) - (aref timer 3)))) + (let ((time (timer--time timer))) (format "%12s" (format-seconds "%dd %hh %mm %z%,1ss" (float-time - (if (aref timer 7) + (if (timer--idle-delay timer) time (time-subtract time nil)))))) 'help-echo "Time until next invocation") ;; Repeat. - ,(let ((repeat (aref timer 4))) + ,(let ((repeat (timer--repeat-delay timer))) (cond ((numberp repeat) (propertize @@ -73,7 +71,7 @@ (let ((cl-print-compiled 'static) (cl-print-compiled-button nil) (print-escape-newlines t)) - (cl-prin1-to-string (aref timer 5))) + (cl-prin1-to-string (timer--function timer))) 'help-echo "Function called by timer")])) (append timer-list timer-idle-list))) (tabulated-list-print)) diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index 073dc3933b1..be191d63b9e 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -407,7 +407,7 @@ This function returns a timer object which you can use in ;; Handle relative times like "2 hours 35 minutes". (when (stringp time) - (when-let ((secs (timer-duration time))) + (when-let* ((secs (timer-duration time))) (setq time (timer-relative-time nil secs)))) ;; Handle "11:23pm" and the like. Interpret it as meaning today diff --git a/lisp/emacs-lisp/track-changes.el b/lisp/emacs-lisp/track-changes.el index 3f3b8d7bed9..25c9ad7c859 100644 --- a/lisp/emacs-lisp/track-changes.el +++ b/lisp/emacs-lisp/track-changes.el @@ -170,6 +170,10 @@ More specifically it indicates which \"before\" they hold. "Current size of the buffer, as far as this library knows. This is used to try and detect cases where buffer modifications are \"lost\".") +(defvar track-changes--trace nil + "Ring holding a trace of recent calls to the API. +Each call is recorded as a (BUFFER-NAME . BACKTRACE).") + ;;;; Exposed API. (defvar track-changes-record-errors @@ -178,7 +182,8 @@ This is used to try and detect cases where buffer modifications are \"lost\".") ;; annoy the user too much about errors. (string-match "\\..*\\." emacs-version) "If non-nil, keep track of errors in `before/after-change-functions' calls. -The errors are kept in `track-changes--error-log'.") +The errors are kept in `track-changes--error-log'. +If set to `trace', then we additionally keep a trace of recent calls to the API.") (cl-defun track-changes-register ( signal &key nobefore disjoint immediate) "Register a new tracker whose change-tracking function is SIGNAL. @@ -213,6 +218,7 @@ and should thus be extra careful: don't modify the buffer, don't call a function that may block, do as little work as possible, ... When IMMEDIATE is non-nil, the SIGNAL should probably not always call `track-changes-fetch', since that would defeat the purpose of this library." + (track-changes--trace) (when (and nobefore disjoint) ;; FIXME: Without `before-change-functions', we can discover ;; a disjoint change only after the fact, which is not good enough. @@ -236,6 +242,7 @@ When IMMEDIATE is non-nil, the SIGNAL should probably not always call Trackers can consume resources (especially if `track-changes-fetch' is not called), so it is good practice to unregister them when you don't need them any more." + (track-changes--trace) (unless (memq id track-changes--trackers) (error "Unregistering a non-registered tracker: %S" id)) (setq track-changes--trackers (delq id track-changes--trackers)) @@ -270,6 +277,7 @@ This reflects a bug somewhere, so please report it when it happens. If no changes occurred since the last time, it doesn't call FUNC and returns nil, otherwise it returns the value returned by FUNC and re-enable the TRACKER corresponding to ID." + (track-changes--trace) (cl-assert (memq id track-changes--trackers)) (unless (equal track-changes--buffer-size (buffer-size)) (track-changes--recover-from-error @@ -387,6 +395,29 @@ returned to a consistent state." ;;;; Auxiliary functions. +(defun track-changes--backtrace (n &optional base) + (let ((frames nil)) + (catch 'done + (mapbacktrace (lambda (&rest frame) + (if (>= (setq n (- n 1)) 0) + (push frame frames) + (push '... frames) + (throw 'done nil))) + (or base #'track-changes--backtrace))) + (nreverse frames))) + +(defun track-changes--trace () + (when (eq 'trace track-changes-record-errors) + (require 'ring) + (declare-function ring-insert "ring" (ring item)) + (declare-function make-ring "ring" (size)) + (unless track-changes--trace + (setq track-changes--trace (make-ring 10))) + (ring-insert track-changes--trace + (cons (buffer-name) + (track-changes--backtrace + 10 #'track-changes--trace))))) + (defun track-changes--clean-state () (cond ((null track-changes--state) @@ -442,7 +473,9 @@ returned to a consistent state." (defvar track-changes--error-log () "List of errors encountered. -Each element is a triplet (BUFFER-NAME BACKTRACE RECENT-KEYS).") +Each element is a tuple [BUFFER-NAME BACKTRACE RECENT-KEYS TRACE]. +where both RECENT-KEYS and TRACE are sorted oldest-first and +backtraces have the deepest frame first.") (defun track-changes--recover-from-error (&optional info) ;; We somehow got out of sync. This is usually the result of a bug @@ -453,14 +486,15 @@ Each element is a triplet (BUFFER-NAME BACKTRACE RECENT-KEYS).") (message "Recovering from confusing calls to `before/after-change-functions'!") (warn "Missing/incorrect calls to `before/after-change-functions'!! Details logged to `track-changes--error-log'") - (push (list (buffer-name) info - (let* ((bf (backtrace-frames - #'track-changes--recover-from-error)) - (tail (nthcdr 50 bf))) - (when tail (setcdr tail '...)) - bf) - (let ((rk (recent-keys 'include-cmds))) - (if (< (length rk) 20) rk (substring rk -20)))) + (push (vector (buffer-name) info + (track-changes--backtrace + 50 #'track-changes--recover-from-error) + (let ((rk (recent-keys 'include-cmds))) + (if (< (length rk) 20) rk (substring rk -20))) + (when (and (eq 'trace track-changes-record-errors) + (fboundp 'ring-elements)) + (apply #'vector + (nreverse (ring-elements track-changes--trace))))) track-changes--error-log)) (setq track-changes--before-clean 'unset) (setq track-changes--buffer-size (buffer-size)) @@ -470,6 +504,7 @@ Details logged to `track-changes--error-log'") (setq track-changes--state (track-changes--state))) (defun track-changes--before (beg end) + (track-changes--trace) (cl-assert track-changes--state) (cl-assert (<= beg end)) (let* ((size (- end beg)) @@ -554,6 +589,7 @@ Details logged to `track-changes--error-log'") (buffer-substring-no-properties old-bend new-bend))))))))) (defun track-changes--after (beg end len) + (track-changes--trace) (cl-assert track-changes--state) (let ((offset (- (- end beg) len))) (cl-incf track-changes--buffer-size offset) diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index d332a357c6a..00785113edb 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -45,7 +45,8 @@ getter formatter displayer - -numerical) + -numerical + -aligned) (defclass vtable () ((columns :initarg :columns :accessor vtable-columns) @@ -212,18 +213,12 @@ See info node `(vtable)Top' for vtable documentation." (funcall accessor face2) (plist-get face2 slot)))) (if (and col1 col2) - (vtable--color-blend col1 col2) + (apply #'color-rgb-to-hex + `(,@(color-blend (color-name-to-rgb col1) + (color-name-to-rgb col2)) + 2)) (or col1 col2)))) -;;; 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 () @@ -271,7 +266,7 @@ If TABLE is found, return the position of the start of the table. If it can't be found, return nil and don't move point." (let ((start (point))) (goto-char (point-min)) - (if-let ((match (text-property-search-forward 'vtable table t))) + (if-let* ((match (text-property-search-forward 'vtable table t))) (goto-char (prop-match-beginning match)) (goto-char start) nil))) @@ -279,7 +274,7 @@ If it can't be found, return nil and don't move point." (defun vtable-goto-column (column) "Go to COLUMN on the current line." (beginning-of-line) - (if-let ((match (text-property-search-forward 'vtable-column column t))) + (if-let* ((match (text-property-search-forward 'vtable-column column t))) (goto-char (prop-match-beginning match)) (end-of-line))) @@ -311,10 +306,10 @@ is signaled." ;; FIXME: If the table's buffer has no visible window, or if its ;; width has changed since the table was updated, the cache key will ;; not match and the object can't be updated. (Bug #69837). - (if-let ((line-number (seq-position (car (vtable--cache table)) old-object - (lambda (a b) - (equal (car a) b)))) - (line (elt (car (vtable--cache table)) line-number))) + (if-let* ((line-number (seq-position (car (vtable--cache table)) old-object + (lambda (a b) + (equal (car a) b)))) + (line (elt (car (vtable--cache table)) line-number))) (progn (setcar line object) (setcdr line (vtable--compute-cached-line table object)) @@ -368,86 +363,89 @@ end (if the index is too large) of the table. BEFORE is ignored in this case. This also updates the displayed table." - ;; FIXME: Inserting an object into an empty vtable currently isn't - ;; possible. `nconc' fails silently (twice), and `setcar' on the cache - ;; raises an error. + ;; If the vtable is empty, just add the object and regenerate the + ;; table. (if (null (vtable-objects table)) - (error "[vtable] Cannot insert object into empty vtable")) - ;; First insert into the objects. - (let ((pos (if location - (if (integerp location) - (prog1 - (nthcdr location (vtable-objects table)) - ;; Do not prepend if index is too large: - (setq before nil)) - (or (memq location (vtable-objects table)) - ;; Prepend if `location' is not found and - ;; `before' is non-nil: - (and before (vtable-objects table)))) - ;; If `location' is nil and `before' is non-nil, we - ;; prepend the new object. - (if before (vtable-objects table))))) - (if (or before ; If `before' is non-nil, `pos' should be, as well. - (and pos (integerp location))) - ;; Add the new object before. - (let ((old-object (car pos))) - (setcar pos object) - (setcdr pos (cons old-object (cdr pos)))) - ;; Otherwise, add the object after. - (if pos - ;; Splice the object into the list. - (setcdr pos (cons object (cdr pos))) - ;; Otherwise, append the object. - (nconc (vtable-objects table) (list object))))) - ;; Then adjust the cache and display. - (save-excursion - (vtable-goto-table table) - (let* ((cache (vtable--cache table)) - (inhibit-read-only t) - (keymap (get-text-property (point) 'keymap)) - (ellipsis (if (vtable-ellipsis table) - (propertize (truncate-string-ellipsis) - 'face (vtable-face table)) - "")) - (ellipsis-width (string-pixel-width ellipsis)) - (elem (if location ; This binding mirrors the binding of `pos' above. - (if (integerp location) - (nth location (car cache)) - (or (assq location (car cache)) - (and before (caar cache)))) - (if before (caar cache)))) - (pos (memq elem (car cache))) - (line (cons object (vtable--compute-cached-line table object)))) - (if (or before + (progn + (setf (vtable-objects table) (list object)) + (vtable--recompute-numerical table (vtable--compute-cached-line table object)) + (vtable-goto-table table) + (vtable-revert-command)) + ;; First insert into the objects. + (let ((pos (if location + (if (integerp location) + (prog1 + (nthcdr location (vtable-objects table)) + ;; Do not prepend if index is too large: + (setq before nil)) + (or (memq location (vtable-objects table)) + ;; Prepend if `location' is not found and + ;; `before' is non-nil: + (and before (vtable-objects table)))) + ;; If `location' is nil and `before' is non-nil, we + ;; prepend the new object. + (if before (vtable-objects table))))) + (if (or before ; If `before' is non-nil, `pos' should be, as well. (and pos (integerp location))) - ;; Add the new object before:. - (let ((old-line (car pos))) - (setcar pos line) - (setcdr pos (cons old-line (cdr pos))) - (unless (vtable-goto-object (car elem)) - (vtable-beginning-of-table))) + ;; Add the new object before. + (let ((old-object (car pos))) + (setcar pos object) + (setcdr pos (cons old-object (cdr pos)))) ;; Otherwise, add the object after. (if pos ;; Splice the object into the list. - (progn - (setcdr pos (cons line (cdr pos))) - (if (vtable-goto-object location) - (forward-line 1) ; Insert *after*. - (vtable-end-of-table))) + (setcdr pos (cons object (cdr pos))) ;; Otherwise, append the object. - (setcar cache (nconc (car cache) (list line))) - (vtable-end-of-table))) - (let ((start (point))) - ;; 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) - ellipsis ellipsis-width) - (add-text-properties start (point) (list 'keymap keymap - 'vtable table))) - ;; We may have inserted a non-numerical value into a previously - ;; all-numerical table, so recompute. - (vtable--recompute-numerical table (cdr line))))) + (nconc (vtable-objects table) (list object))))) + ;; Then adjust the cache and display. + (save-excursion + (vtable-goto-table table) + (let* ((cache (vtable--cache table)) + (inhibit-read-only t) + (keymap (get-text-property (point) 'keymap)) + (ellipsis (if (vtable-ellipsis table) + (propertize (truncate-string-ellipsis) + 'face (vtable-face table)) + "")) + (ellipsis-width (string-pixel-width ellipsis)) + (elem (if location ; This binding mirrors the binding of `pos' above. + (if (integerp location) + (nth location (car cache)) + (or (assq location (car cache)) + (and before (caar cache)))) + (if before (caar cache)))) + (pos (memq elem (car cache))) + (line (cons object (vtable--compute-cached-line table object)))) + (if (or before + (and pos (integerp location))) + ;; Add the new object before:. + (let ((old-line (car pos))) + (setcar pos line) + (setcdr pos (cons old-line (cdr pos))) + (unless (vtable-goto-object (car elem)) + (vtable-beginning-of-table))) + ;; Otherwise, add the object after. + (if pos + ;; Splice the object into the list. + (progn + (setcdr pos (cons line (cdr pos))) + (if (vtable-goto-object location) + (forward-line 1) ; Insert *after*. + (vtable-end-of-table))) + ;; Otherwise, append the object. + (setcar cache (nconc (car cache) (list line))) + (vtable-end-of-table))) + (let ((start (point))) + ;; 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) + ellipsis ellipsis-width) + (add-text-properties start (point) (list 'keymap keymap + 'vtable table))) + ;; We may have inserted a non-numerical value into a previously + ;; all-numerical table, so recompute. + (vtable--recompute-numerical table (cdr line)))))) (defun vtable-column (table index) "Return the name of the INDEXth column in TABLE." @@ -470,7 +468,17 @@ This also updates the displayed table." (t (elt object index)))) -(defun vtable--compute-columns (table) +(defun vtable--compute-columns (table &optional recompute) + "Compute column specs for TABLE. +Set the `align', `-aligned' and `-numerical' properties of each column. +If the column contains only numerical data, set `-numerical' to t, +otherwise to nil. `-aligned' indicates whether the column has an +`align' property set by the user. If it does, `align' is not touched, +otherwise it is set to `right' for numeric columns and to `left' for +non-numeric columns. + +If RECOMPUTE is non-nil, do not set `-aligned'. This can be used to +recompute the column specs when the table data has changed." (let ((numerical (make-vector (length (vtable-columns table)) t)) (columns (vtable-columns table))) ;; First determine whether there are any all-numerical columns. @@ -481,11 +489,16 @@ This also updates the displayed table." table)) (setf (elt numerical index) nil))) (vtable-columns table))) + ;; Check if any columns have an explicit `align' property. + (unless recompute + (dolist (column (vtable-columns table)) + (when (vtable-column-align column) + (setf (vtable-column--aligned column) t)))) ;; Then fill in defaults. (seq-map-indexed (lambda (column index) ;; This is used when displaying. - (unless (vtable-column-align column) + (unless (vtable-column--aligned column) (setf (vtable-column-align column) (if (elt numerical index) 'right @@ -638,7 +651,7 @@ This also updates the displayed table." (insert "\n") (put-text-property start (point) 'vtable-object (car line)) (unless column-colors - (when-let ((row-colors (slot-value table '-cached-colors))) + (when-let* ((row-colors (slot-value table '-cached-colors))) (add-face-text-property start (point) (elt row-colors (mod line-number (length row-colors)))))))) @@ -810,7 +823,7 @@ If NEXT, do the next column." (setq recompute t))) line) (when recompute - (vtable--compute-columns table)))) + (vtable--compute-columns table t)))) (defun vtable--set-header-line (table widths spacer) (setq header-line-format @@ -850,32 +863,48 @@ If NEXT, do the next column." (error "Invalid spec: %s" spec)))) (defun vtable--compute-widths (table cache) - "Compute the display widths for TABLE." - (seq-into - (seq-map-indexed - (lambda (column index) - (let ((width - (or - ;; Explicit widths. - (and (vtable-column-width column) - (vtable--compute-width table (vtable-column-width column))) - ;; Compute based on the displayed widths of - ;; the data. - (seq-max (seq-map (lambda (elem) - (nth 1 (elt (cdr elem) index))) - cache))))) - ;; Let min-width/max-width specs have their say. - (when-let ((min-width (and (vtable-column-min-width column) - (vtable--compute-width - table (vtable-column-min-width column))))) - (setq width (max width min-width))) - (when-let ((max-width (and (vtable-column-max-width column) - (vtable--compute-width - table (vtable-column-max-width column))))) - (setq width (min width max-width))) - width)) - (vtable-columns table)) - 'vector)) + "Compute the display widths for TABLE. +CACHE is TABLE's cache data as returned by `vtable--compute-cache'." + (let* ((n-0cols 0) ; Count the number of zero-width columns. + (widths (seq-map-indexed + (lambda (column index) + (let ((width + (or + ;; Explicit widths. + (and (vtable-column-width column) + (vtable--compute-width table (vtable-column-width column))) + ;; If the vtable is empty and no explicit width is given, + ;; set its width to 0 and deal with it below. + (when (null cache) + (setq n-0cols (1+ n-0cols)) + 0) + ;; Otherwise, compute based on the displayed widths of the + ;; data. + (seq-max (seq-map (lambda (elem) + (nth 1 (elt (cdr elem) index))) + cache))))) + ;; Let min-width/max-width specs have their say. + (when-let* ((min-width (and (vtable-column-min-width column) + (vtable--compute-width + table (vtable-column-min-width column))))) + (setq width (max width min-width))) + (when-let* ((max-width (and (vtable-column-max-width column) + (vtable--compute-width + table (vtable-column-max-width column))))) + (setq width (min width max-width))) + width)) + (vtable-columns table)))) + ;; If there are any zero-width columns, divide the remaining window + ;; width evenly over them. + (when (> n-0cols 0) + (let* ((combined-width (apply #'+ widths)) + (default-width (/ (- (window-width nil t) combined-width) n-0cols))) + (setq widths (mapcar (lambda (width) + (if (zerop width) + default-width + width)) + widths)))) + (seq-into widths 'vector))) (defun vtable--compute-cache (table) (seq-map @@ -904,7 +933,7 @@ If NEXT, do the next column." (vtable-keymap table)) (copy-keymap vtable-map) vtable-map))) - (when-let ((actions (vtable-actions table))) + (when-let* ((actions (vtable-actions table))) (while actions (funcall (lambda (key binding) (keymap-set map key diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index f83e8d42fac..8caf32dfcd8 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -285,7 +285,7 @@ entirely by setting `warning-suppress-types' or (unless buffer-name (setq buffer-name "*Warnings*")) (with-suppressed-warnings ((obsolete warning-level-aliases)) - (when-let ((new (cdr (assq level warning-level-aliases)))) + (when-let* ((new (cdr (assq level warning-level-aliases)))) (warn "Warning level `%s' is obsolete; use `%s' instead" level new) (setq level new))) (or (< (warning-numeric-level level) |