summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r--lisp/emacs-lisp/byte-run.el17
-rw-r--r--lisp/emacs-lisp/chart.el2
-rw-r--r--lisp/emacs-lisp/checkdoc.el141
-rw-r--r--lisp/emacs-lisp/comp-cstr.el13
-rw-r--r--lisp/emacs-lisp/comp.el149
-rw-r--r--lisp/emacs-lisp/cond-star.el710
-rw-r--r--lisp/emacs-lisp/ert.el8
-rw-r--r--lisp/emacs-lisp/find-func.el16
-rw-r--r--lisp/emacs-lisp/let-alist.el25
-rw-r--r--lisp/emacs-lisp/lisp-mnt.el47
-rw-r--r--lisp/emacs-lisp/lisp.el14
-rw-r--r--lisp/emacs-lisp/multisession.el118
-rw-r--r--lisp/emacs-lisp/package.el12
-rw-r--r--lisp/emacs-lisp/pcase.el11
-rw-r--r--lisp/emacs-lisp/pp.el29
-rw-r--r--lisp/emacs-lisp/rx.el2
-rw-r--r--lisp/emacs-lisp/subr-x.el78
-rw-r--r--lisp/emacs-lisp/timer-list.el12
18 files changed, 1167 insertions, 237 deletions
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index 75cfc7b32d3..f1486f70634 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))))
diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el
index 2ca9b64be33..3acf2588f24 100644
--- a/lisp/emacs-lisp/chart.el
+++ b/lisp/emacs-lisp/chart.el
@@ -649,7 +649,7 @@ SORT-PRED 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 21d40c56e74..6865a02f9e8 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/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
index 058fc522858..66c44f16835 100644
--- a/lisp/emacs-lisp/comp-cstr.el
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -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
@@ -965,6 +956,10 @@ Non memoized version of `comp-cstr-intersection-no-mem'."
(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.el b/lisp/emacs-lisp/comp.el
index 947fb06e602..9447f68c362 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
@@ -792,21 +793,29 @@ 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'."
@@ -2540,26 +2549,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.
@@ -2802,6 +2814,68 @@ 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 in function: %s"
+ (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
@@ -3577,14 +3651,13 @@ Search happens in `native-comp-eln-load-path'."
;;;###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))
diff --git a/lisp/emacs-lisp/cond-star.el b/lisp/emacs-lisp/cond-star.el
new file mode 100644
index 00000000000..5ff921bb35e
--- /dev/null
+++ b/lisp/emacs-lisp/cond-star.el
@@ -0,0 +1,710 @@
+;;; -*-lexical-binding: t; -*-
+
+;; Copyright (C) 1985-2024 Free Software Foundation, Inc.
+
+;; Maintainer: rms@gnu.org
+;; Package: emacs
+
+;; This file is part of GNU Emacs. It implements `cond*'.
+
+;; cond* 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.
+
+;; cond* 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/>.
+
+;; 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.
+
+(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 `(bind* BINDINGS...)' or `(match* PATTERN 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)' means to match DATUM against the pattern PATTERN
+The condition counts as true if PATTERN matches DATUM.
+
+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.
+
+Mon-exit clause:
+
+If a clause has only one element, or if its first element is
+t, or if it ends with the keyword :non-exit, then
+this clause never exits the `cond*' construct. Instead,
+control falls through to the next clause (if any).
+The 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."
+ (ignore datum)
+ (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 '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)))))
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index 105c44d49aa..fa1b7a60a90 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -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.
diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el
index ce783983b77..c1835feff18 100644
--- a/lisp/emacs-lisp/find-func.el
+++ b/lisp/emacs-lisp/find-func.el
@@ -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.
diff --git a/lisp/emacs-lisp/let-alist.el b/lisp/emacs-lisp/let-alist.el
index cdd476d9df6..b1822519999 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 8b0494dc5cb..3c7f047d203 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-2024 Free Software Foundation,
-;; Inc.
+;; Copyright (C) 1992-2024 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.el b/lisp/emacs-lisp/lisp.el
index e65eec508d9..280de5036aa 100644
--- a/lisp/emacs-lisp/lisp.el
+++ b/lisp/emacs-lisp/lisp.el
@@ -850,10 +850,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 +895,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/multisession.el b/lisp/emacs-lisp/multisession.el
index b7bc5536f78..c923c29bbf7 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
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 53d04b0d5ec..7cae8d68bc0 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -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))
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 5a7f3995311..fd6b0c8db5c 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -241,9 +241,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 ())
diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el
index e550bd4d689..12346b3d285 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)
diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el
index 7113d5a6241..2a2315f08b5 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 d5ed934f805..66347e7b584 100644
--- a/lisp/emacs-lisp/subr-x.el
+++ b/lisp/emacs-lisp/subr-x.el
@@ -336,10 +336,58 @@ 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?
+ (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 +396,23 @@ 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 `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.
+ (setq display-line-numbers nil
+ line-prefix nil wrap-prefix nil)
+ (if buffer
+ (setq-local face-remapping-alist
+ (with-current-buffer buffer
+ face-remapping-alist))
+ (kill-local-variable 'face-remapping-alist))
+ (insert string)
+ ;; 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))
(car (buffer-text-pixel-size nil nil t)))))
;;;###autoload
diff --git a/lisp/emacs-lisp/timer-list.el b/lisp/emacs-lisp/timer-list.el
index 52309a247c0..c237eeb52af 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))
generated by cgit v1.2.3 (git 2.39.1) at 2025-06-16 00:57:06 +0000