diff options
Diffstat (limited to 'lisp/emacs-lisp')
71 files changed, 3807 insertions, 2626 deletions
diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el index 03bef072709..b395a13b0dd 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 @@ -750,7 +750,7 @@ Format it according to VIEW." (let ((fun-and-args (cons fun args))) (insert (backtrace--print-to-string fun-and-args))) ;; Skip the open-paren. - (cl-incf fun-beg))) + (incf fun-beg))) (when fun-file (make-text-button fun-beg (or fun-end diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index c70a7474cdc..5d2f206cc5c 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -682,7 +682,7 @@ is the name of a variable that will hold the value we need to pack.") (cl-defmethod bindat--type (op (_ (eql 'byte))) (bindat--pcase op ('unpack `(bindat--unpack-u8)) - (`(length . ,_) `(cl-incf bindat-idx 1)) + (`(length . ,_) `(incf bindat-idx 1)) (`(pack . ,args) `(bindat--pack-u8 . ,args)))) (cl-defmethod bindat--type (op (_ (eql 'uint)) n &optional le) @@ -690,7 +690,7 @@ is the name of a variable that will hold the value we need to pack.") (bindat--pcase op ('unpack `(if ,le (bindat--unpack-uintr ,n) (bindat--unpack-uint ,n))) - (`(length . ,_) `(cl-incf bindat-idx (/ ,n 8))) + (`(length . ,_) `(incf bindat-idx (/ ,n 8))) (`(pack . ,args) `(if ,le (bindat--pack-uintr ,n . ,args) (bindat--pack-uint ,n . ,args)))))) @@ -698,14 +698,14 @@ is the name of a variable that will hold the value we need to pack.") (cl-defmethod bindat--type (op (_ (eql 'str)) len) (bindat--pcase op ('unpack `(bindat--unpack-str ,len)) - (`(length . ,_) `(cl-incf bindat-idx ,len)) + (`(length . ,_) `(incf bindat-idx ,len)) (`(pack . ,args) `(bindat--pack-str ,len . ,args)))) (cl-defmethod bindat--type (op (_ (eql 'strz)) &optional len) (bindat--pcase op ('unpack `(bindat--unpack-strz ,len)) (`(length ,val) - `(cl-incf bindat-idx ,(cond + `(incf bindat-idx ,(cond ;; Optimizations if len is a literal number or nil. ((null len) `(1+ (length ,val))) ((numberp len) len) @@ -716,11 +716,11 @@ is the name of a variable that will hold the value we need to pack.") (cl-defmethod bindat--type (op (_ (eql 'bits)) len) (bindat--pcase op ('unpack `(bindat--unpack-bits ,len)) - (`(length . ,_) `(cl-incf bindat-idx ,len)) + (`(length . ,_) `(incf bindat-idx ,len)) (`(pack . ,args) `(bindat--pack-bits ,len . ,args)))) (cl-defmethod bindat--type (_op (_ (eql 'fill)) len) - `(progn (cl-incf bindat-idx ,len) nil)) + `(progn (incf bindat-idx ,len) nil)) (cl-defmethod bindat--type (_op (_ (eql 'align)) len) `(progn (cl-callf bindat--align bindat-idx ,len) nil)) @@ -747,7 +747,7 @@ is the name of a variable that will hold the value we need to pack.") (let `#'(lambda (,val) (setq bindat-idx (+ bindat-idx ,len))) fun) (guard (not (macroexp--fgrep `((,val)) len)))) ;; Optimize the case where the size of each element is constant. - `(cl-incf bindat-idx (* ,count ,len))) + `(incf bindat-idx (* ,count ,len))) ;; FIXME: It's tempting to use `(mapc (lambda (,val) ,exp) ,val)' ;; which would be more efficient when `val' is a list, ;; but that's only right if length of `val' is indeed `count'. @@ -883,11 +883,11 @@ controlled in the following way: - If the list of fields is preceded with `:pack-var VAR' then the object to be packed is bound to VAR when evaluating the EXPs of `:pack-val'. -All the above BITLEN, LEN, LE, COUNT, and EXP are ELisp expressions evaluated +All the above BITLEN, LEN, LE, COUNT, and EXP are Elisp expressions evaluated in the current lexical context extended with the previous fields. TYPE can additionally be one of the Bindat type macros defined with -`bindat-defmacro' (and listed below) or an ELisp expression which returns +`bindat-defmacro' (and listed below) or an Elisp expression which returns a bindat type expression." (declare (indent 0) (debug (bindat-type))) `(progn diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 88f98c0c6a2..652c79e9c93 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -172,7 +172,7 @@ Earlier variables shadow later ones with the same name.") ;; When the function comes from another file, we byte-compile ;; the inlined function first, and then inline its byte-code. ;; This also has the advantage that the final code does not - ;; depend on the order of compilation of ELisp files, making + ;; depend on the order of compilation of Elisp files, making ;; the build more reproducible. (if (eq fn localfn) ;; From the same file => same mode. @@ -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 @@ -1859,7 +1861,7 @@ See Info node `(elisp) Integer Basics'." (side-effect-and-error-free-fns '( ;; alloc.c - bool-vector cons list make-marker purecopy record vector + bool-vector cons list make-marker record vector ;; buffer.c buffer-list buffer-live-p current-buffer overlay-lists overlayp ;; casetab.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..6412c8cde22 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)))) @@ -528,7 +543,7 @@ was first made obsolete, for example a date or a release number." (put obsolete-name 'byte-obsolete-info ;; The second entry used to hold the `byte-compile' handler, but ;; is not used any more nowadays. - (purecopy (list current-name nil when))) + (list current-name nil when)) obsolete-name) (defmacro define-obsolete-function-alias ( obsolete-name current-name when @@ -556,14 +571,15 @@ 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 obsolescence warnings; it can be either `get' or `set'." (byte-run--constant-obsolete-warning obsolete-name) (put obsolete-name 'byte-obsolete-variable - (purecopy (list current-name access-type when))) + (list current-name access-type when)) obsolete-name) (defmacro define-obsolete-variable-alias ( obsolete-name current-name when @@ -618,7 +634,7 @@ obsolete, for example a date or a release number." `(progn (put ,obsolete-face 'face-alias ,current-face) ;; Used by M-x describe-face. - (put ,obsolete-face 'obsolete-face (or (purecopy ,when) t)))) + (put ,obsolete-face 'obsolete-face (or ,when t)))) (defmacro dont-compile (&rest body) "Like `progn', but the body always runs interpreted (not compiled). diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 594052ad263..1807f8674fb 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -242,6 +242,7 @@ This includes variable references and calls to functions such as `car'." "Compile `cond' clauses to a jump table implementation (using a hash-table)." :version "26.1" :type 'boolean) +(make-obsolete-variable 'byte-compile-cond-use-jump-table nil "31.1") (defvar byte-compile-dynamic nil "Formerly used to compile function bodies so they load lazily. @@ -2051,7 +2052,7 @@ also be compiled." (not (member source (dir-locals--all-files directory))) ;; File is requested to be ignored (not (string-match-p ignore-files-regexp source))) - (progn (cl-incf + (progn (incf (pcase (byte-recompile-file source force arg) ('no-byte-compile skip-count) ('t file-count) @@ -2132,7 +2133,6 @@ If compilation is needed, this functions returns the result of (and file (not (equal file "")) (with-temp-buffer (insert-file-contents file) - (goto-char (point-min)) (let ((vars nil) var) (while (ignore-errors (setq var (read (current-buffer)))) @@ -2355,7 +2355,8 @@ See also `emacs-lisp-byte-compile-and-load'." (let ((gen-dynvars (getenv "EMACS_GENERATE_DYNVARS"))) (when (and gen-dynvars (not (equal gen-dynvars "")) byte-compile--seen-defvars) - (let ((dynvar-file (concat target-file ".dynvars"))) + (let ((dynvar-file (concat target-file ".dynvars")) + (print-symbols-bare t)) (message "Generating %s" dynvar-file) (with-temp-buffer (dolist (var (delete-dups byte-compile--seen-defvars)) @@ -2713,7 +2714,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) @@ -3583,7 +3584,7 @@ This assumes the function has the `important-return-value' property." (cl-nsubst 3) (cl-nsubst-if 3) (cl-nsubst-if-not 3) (cl-nsubstitute 3) (cl-nsubstitute-if 3) (cl-nsubstitute-if-not 3) (cl-nsublis 2) - (cl-nunion 1 2) (cl-nintersection 1 2) (cl-nset-difference 1 2) + (cl-nunion 1 2) (cl-nintersection 1) (cl-nset-difference 1) (cl-nset-exclusive-or 1 2) (cl-nreconc 1) (cl-sort 1) (cl-stable-sort 1) (cl-merge 2 3) @@ -3772,7 +3773,7 @@ This assumes the function has the `important-return-value' property." ;; Add missing &optional (or &rest) arguments. (dotimes (_ (- (/ (1+ fmax2) 2) alen)) (byte-compile-push-constant nil))) - ((zerop (logand fmax2 1)) + ((evenp fmax2) (byte-compile-report-error (format "Too many arguments for inlined function %S" form)) (byte-compile-discard (- alen (/ fmax2 2)))) @@ -4640,13 +4641,12 @@ Return (TAIL VAR TEST CASES), where: cases)))) (setq jump-table (make-hash-table :test test - :purecopy t :size nvalues))) (setq default-tag (byte-compile-make-tag)) ;; The structure of byte-switch code: ;; ;; varref var - ;; constant #s(hash-table purecopy t data (val1 (TAG1) val2 (TAG2))) + ;; constant #s(hash-table data (val1 (TAG1) val2 (TAG2))) ;; switch ;; goto DEFAULT-TAG ;; TAG1 @@ -5276,11 +5276,11 @@ FORM is used to provide location, `bytecomp--cus-function' and (and tl (progn (bytecomp--cus-warn - tl "misplaced %s keyword in `%s' type" (car tl) head) + tl "misplaced %S keyword in `%S' type" (car tl) head) t)))))) ((memq head '(choice radio)) (unless tail - (bytecomp--cus-warn type "`%s' without any types inside" head)) + (bytecomp--cus-warn type "`%S' without any types inside" head)) (let ((clauses tail) (constants nil) (tags nil)) @@ -5288,7 +5288,7 @@ FORM is used to provide location, `bytecomp--cus-function' and (let* ((ty (car clauses)) (ty-head (car-safe ty))) (when (and (eq ty-head 'other) (cdr clauses)) - (bytecomp--cus-warn ty "`other' not last in `%s'" head)) + (bytecomp--cus-warn ty "`other' not last in `%S'" head)) (when (memq ty-head '(const other)) (let ((ty-tail (cdr ty)) (val nil)) @@ -5300,13 +5300,13 @@ FORM is used to provide location, `bytecomp--cus-function' and (setq val (car ty-tail))) (when (member val constants) (bytecomp--cus-warn - ty "duplicated value in `%s': `%S'" head val)) + ty "duplicated value in `%S': `%S'" head val)) (push val constants))) (let ((tag (and (consp ty) (plist-get (cdr ty) :tag)))) (when (stringp tag) (when (member tag tags) (bytecomp--cus-warn - ty "duplicated :tag string in `%s': %S" head tag)) + ty "duplicated :tag string in `%S': %S" head tag)) (push tag tags))) (bytecomp--check-cus-type ty)) (setq clauses (cdr clauses))))) @@ -5318,7 +5318,7 @@ FORM is used to provide location, `bytecomp--cus-function' and (bytecomp--check-cus-type ty))) ((memq head '(list group vector set repeat)) (unless tail - (bytecomp--cus-warn type "`%s' without type specs" head)) + (bytecomp--cus-warn type "`%S' without type specs" head)) (dolist (ty tail) (bytecomp--check-cus-type ty))) ((memq head '(alist plist)) @@ -5334,21 +5334,21 @@ FORM is used to provide location, `bytecomp--cus-function' and (val (car tail))) (cond ((or (> n 1) (and value-tag tail)) - (bytecomp--cus-warn type "`%s' with too many values" head)) + (bytecomp--cus-warn type "`%S' with too many values" head)) (value-tag (setq val (cadr value-tag))) ;; ;; This is a useful check but it results in perhaps ;; ;; a bit too many complaints. ;; ((null tail) ;; (bytecomp--cus-warn - ;; type "`%s' without value is implicitly nil" head)) + ;; type "`%S' without value is implicitly nil" head)) ) (when (memq (car-safe val) '(quote function)) - (bytecomp--cus-warn type "`%s' with quoted value: %S" head val)))) + (bytecomp--cus-warn type "`%S' with quoted value: %S" head val)))) ((eq head 'quote) - (bytecomp--cus-warn type "type should not be quoted: %s" (cadr type))) + (bytecomp--cus-warn type "type should not be quoted: %S" (cadr type))) ((memq head invalid-types) - (bytecomp--cus-warn type "`%s' is not a valid type" head)) + (bytecomp--cus-warn type "`%S' is not a valid type" head)) ((or (not (symbolp head)) (keywordp head)) (bytecomp--cus-warn type "irregular type `%S'" head)) ))) @@ -5356,11 +5356,64 @@ FORM is used to provide location, `bytecomp--cus-function' and (bytecomp--cus-warn type "irregular type `%S'" type)) ((memq type '( list cons group vector choice radio const other function-item variable-item set repeat restricted-sexp)) - (bytecomp--cus-warn type "`%s' without arguments" type)) + (bytecomp--cus-warn type "`%S' without arguments" type)) ((memq type invalid-types) - (bytecomp--cus-warn type "`%s' is not a valid type" type)) + (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/cconv.el b/lisp/emacs-lisp/cconv.el index a91489437e9..170c7828cdd 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -904,7 +904,7 @@ lexically and dynamically bound symbols actually used by FORM." (defun cconv-make-interpreted-closure (args body env docstring iform) "Make a closure for the interpreter. -This is intended to be called at runtime by the ELisp interpreter (when +This is intended to be called at runtime by the Lisp interpreter (when the code has not been compiled). FUN is the closure's source code, must be a lambda form. ENV is the runtime representation of the lexical environment, @@ -950,7 +950,7 @@ for the lexical bindings." (newenv (nconc (mapcar (lambda (fv) (assq fv env)) (car fvs)) (cdr fvs)))) ;; Never return a nil env, since nil means to use the dynbind - ;; dialect of ELisp. + ;; dialect of Elisp. (make-interpreted-closure args expanded-fun-body (or newenv '(t)) docstring iform))))) diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el index 67b81ddee43..09ce2e763f6 100644 --- a/lisp/emacs-lisp/chart.el +++ b/lisp/emacs-lisp/chart.el @@ -347,7 +347,7 @@ of the drawing." (odd nil) p1) (while s - (setq odd (= (% (length s) 2) 1)) + (setq odd (oddp (length s))) (setq r (chart-translate-namezone (oref a chart) i)) (if (eq dir 'vertical) (setq p (/ (+ (car r) (cdr r)) 2)) @@ -633,7 +633,7 @@ argument to `chart-sort' to sort the lists if desired." (m (member s extlst))) (unless (null s) (if m - (cl-incf (car (nthcdr (- (length extlst) (length m)) cntlst))) + (incf (car (nthcdr (- (length extlst) (length m)) cntlst))) (setq extlst (cons s extlst) cntlst (cons 1 cntlst)))))) ;; Let's create the chart! @@ -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..a45c7dd04cc 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1997-2025 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> -;; Old-Version: 0.6.2 +;; Maintainer: emacs-devel@gnu.org ;; Keywords: docs, maint, lisp ;; This file is part of GNU Emacs. @@ -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 @@ -320,6 +322,14 @@ variable `checkdoc-common-verbs-wrong-voice' if you wish to add your own." Do not set this by hand, use a function like `checkdoc-current-buffer' with a universal argument.") +(defcustom checkdoc-allow-quoting-nil-and-t nil + "If non-nil, don't warn when the symbols nil and t are quoted. + +In other words, it allows writing them like this: \\=`nil\\=', \\=`t\\='." + :type 'boolean + :version "31.1") +;;;###autoload(put 'checkdoc-allow-quoting-nil-and-t 'safe-local-variable #'booleanp) + (defcustom checkdoc-symbol-words '("beginning-of-buffer" "beginning-of-line" "byte-code" "byte-compile" "command-line" "end-of-buffer" "end-of-line" @@ -343,18 +353,19 @@ See Info node `(elisp) Documentation Tips' for background." ;; This is how you can use checkdoc to make mass fixes on the Emacs ;; source tree: ;; -;; (setq checkdoc--argument-missing-flag nil) ; optional +;; (setq checkdoc-arguments-missing-flag nil) ; optional ;; (setq checkdoc--disambiguate-symbol-flag nil) ; optional ;; (setq checkdoc--interactive-docstring-flag nil) ; optional -;; (setq checkdoc-verb-check-experimental-flag nil) +;; (setq checkdoc-permit-comma-termination-flag t) ; optional ;; Then use `M-x find-dired' ("-name '*.el'") and `M-x checkdoc-dired' -(defvar checkdoc--argument-missing-flag t - "Non-nil means warn if arguments are missing from docstring. -This variable is intended for use on Emacs itself, where the -large number of libraries means it is impractical to fix all -of these warnings en masse. In almost any other case, setting -this to anything but t is likely to be counter-productive.") +(define-obsolete-variable-alias 'checkdoc--argument-missing-flag + 'checkdoc-arguments-missing-flag "31.1") +(defcustom checkdoc-arguments-missing-flag t + "Non-nil means warn if function arguments are missing from docstring." + :type 'boolean + :version "31.1") +;;;###autoload(put 'checkdoc-arguments-missing-flag 'safe-local-variable 'booleanp) (defvar checkdoc--disambiguate-symbol-flag t "Non-nil means ask to disambiguate Lisp symbol. @@ -1085,7 +1096,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 +1107,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) @@ -1841,7 +1852,7 @@ function,command,variable,option or symbol." ms1)))))) (looking-at "[.?!]"))) (insert ".")) nil) - (when checkdoc--argument-missing-flag + (when checkdoc-arguments-missing-flag (checkdoc-create-error (format-message "Argument `%s' should appear (as %s) in the doc string" @@ -1953,17 +1964,18 @@ Replace with \"%s\"?" original replace) (length ms))) nil))) ;; t and nil case - (save-excursion - (if (re-search-forward "\\([`‘]\\(t\\|nil\\)['’]\\)" e t) - (if (checkdoc-autofix-ask-replace - (match-beginning 1) (match-end 1) - (format "%s should not appear in quotes. Remove?" - (match-string 2)) - (match-string 2) t) - nil - (checkdoc-create-error - "Symbols t and nil should not appear in single quotes" - (match-beginning 1) (match-end 1))))) + (unless checkdoc-allow-quoting-nil-and-t + (save-excursion + (if (re-search-forward "\\([`‘]\\(t\\|nil\\)['’]\\)" e t) + (if (checkdoc-autofix-ask-replace + (match-beginning 1) (match-end 1) + (format "%s should not appear in quotes. Remove?" + (match-string 2)) + (match-string 2) t) + nil + (checkdoc-create-error + "Symbols t and nil should not appear in single quotes" + (match-beginning 1) (match-end 1)))))) ;; Here is some basic sentence formatting (checkdoc-sentencespace-region-engine (point) e) ;; Here are common proper nouns that should always appear capitalized. @@ -2106,7 +2118,7 @@ The text checked is between START and LIMIT." (goto-char start) (while (and (< (point) p) (re-search-forward "\\\\\"" limit t)) (setq c (1+ c))) - (and (< 0 c) (= (% c 2) 0)))))) + (and (< 0 c) (evenp c)))))) (defun checkdoc-in-abbreviation-p (begin) "Return non-nil if point is at an abbreviation. @@ -2134,7 +2146,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 +2485,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 +2552,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 +2576,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 +2584,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 +2660,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 +2696,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 +2860,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..6390d17a5b7 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -69,6 +69,7 @@ TYPE is a Common Lisp type specifier. This is like `equal', except that it accepts numerically equal numbers of different types (float vs. integer), and also compares strings case-insensitively." + (declare (side-effect-free error-free)) (cond ((eq x y) t) ((stringp x) (and (stringp y) (string-equal-ignore-case x y))) @@ -90,218 +91,226 @@ strings case-insensitively." ;;; Control structures. ;;;###autoload -(defun cl--mapcar-many (cl-func cl-seqs &optional acc) - (if (cdr (cdr cl-seqs)) - (let* ((cl-res nil) - (cl-n (apply #'min (mapcar #'length cl-seqs))) - (cl-i 0) - (cl-args (copy-sequence cl-seqs)) - cl-p1 cl-p2) - (setq cl-seqs (copy-sequence cl-seqs)) - (while (< cl-i cl-n) - (setq cl-p1 cl-seqs cl-p2 cl-args) - (while cl-p1 - (setcar cl-p2 - (if (consp (car cl-p1)) - (prog1 (car (car cl-p1)) - (setcar cl-p1 (cdr (car cl-p1)))) - (aref (car cl-p1) cl-i))) - (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2))) +(defun cl--mapcar-many (func seqs &optional acc) + (if (cdr (cdr seqs)) + (let* ((res nil) + (n (apply #'min (mapcar #'length seqs))) + (i 0) + (args (copy-sequence seqs)) + p1 p2) + (setq seqs (copy-sequence seqs)) + (while (< i n) + (setq p1 seqs p2 args) + (while p1 + (setcar p2 + (if (consp (car p1)) + (prog1 (car (car p1)) + (setcar p1 (cdr (car p1)))) + (aref (car p1) i))) + (setq p1 (cdr p1) p2 (cdr p2))) (if acc - (push (apply cl-func cl-args) cl-res) - (apply cl-func cl-args)) - (setq cl-i (1+ cl-i))) - (and acc (nreverse cl-res))) - (let ((cl-res nil) - (cl-x (car cl-seqs)) - (cl-y (nth 1 cl-seqs))) - (let ((cl-n (min (length cl-x) (length cl-y))) - (cl-i -1)) - (while (< (setq cl-i (1+ cl-i)) cl-n) - (let ((val (funcall cl-func - (if (consp cl-x) (pop cl-x) (aref cl-x cl-i)) - (if (consp cl-y) (pop cl-y) (aref cl-y cl-i))))) + (push (apply func args) res) + (apply func args)) + (setq i (1+ i))) + (and acc (nreverse res))) + (let ((res nil) + (x (car seqs)) + (y (nth 1 seqs))) + (let ((n (min (length x) (length y))) + (i -1)) + (while (< (setq i (1+ i)) n) + (let ((val (funcall func + (if (consp x) (pop x) (aref x i)) + (if (consp y) (pop y) (aref y i))))) (when acc - (push val cl-res))))) - (and acc (nreverse cl-res))))) + (push val res))))) + (and acc (nreverse res))))) ;;;###autoload -(defun cl-map (cl-type cl-func cl-seq &rest cl-rest) +(defsubst cl-map (type func seq &rest rest) "Map a FUNCTION across one or more SEQUENCEs, returning a sequence. TYPE is the sequence type to return. \n(fn TYPE FUNCTION SEQUENCE...)" - (let ((cl-res (apply #'cl-mapcar cl-func cl-seq cl-rest))) - (and cl-type (cl-coerce cl-res cl-type)))) + (declare (important-return-value t)) + (let ((res (apply 'cl-mapcar func seq rest))) + (and type (cl-coerce res type)))) ;;;###autoload -(defun cl-maplist (cl-func cl-list &rest cl-rest) +(defun cl-maplist (func list &rest rest) "Map FUNCTION to each sublist of LIST or LISTs. Like `cl-mapcar', except applies to lists and their cdr's rather than to the elements themselves. \n(fn FUNCTION LIST...)" - (if cl-rest - (let ((cl-res nil) - (cl-args (cons cl-list (copy-sequence cl-rest))) - cl-p) - (while (not (memq nil cl-args)) - (push (apply cl-func cl-args) cl-res) - (setq cl-p cl-args) - (while cl-p (setcar cl-p (cdr (pop cl-p))))) - (nreverse cl-res)) - (let ((cl-res nil)) - (while cl-list - (push (funcall cl-func cl-list) cl-res) - (setq cl-list (cdr cl-list))) - (nreverse cl-res)))) - -;;;###autoload -(defun cl-mapc (cl-func cl-seq &rest cl-rest) + (declare (important-return-value t)) + (if rest + (let ((res nil) + (args (cons list (copy-sequence rest))) + p) + (while (not (memq nil args)) + (push (apply func args) res) + (setq p args) + (while p (setcar p (cdr (pop p))))) + (nreverse res)) + (let ((res nil)) + (while list + (push (funcall func list) res) + (setq list (cdr list))) + (nreverse res)))) + +;;;###autoload +(defun cl-mapc (func seq &rest rest) "Like `cl-mapcar', but does not accumulate values returned by the function. \n(fn FUNCTION SEQUENCE...)" - (if cl-rest - (if (or (cdr cl-rest) (nlistp cl-seq) (nlistp (car cl-rest))) + (if rest + (if (or (cdr rest) (nlistp seq) (nlistp (car rest))) (progn - (cl--mapcar-many cl-func (cons cl-seq cl-rest)) - cl-seq) - (let ((cl-x cl-seq) (cl-y (car cl-rest))) - (while (and cl-x cl-y) - (funcall cl-func (pop cl-x) (pop cl-y))) - cl-seq)) - (mapc cl-func cl-seq))) + (cl--mapcar-many func (cons seq rest)) + seq) + (let ((x seq) (y (car rest))) + (while (and x y) + (funcall func (pop x) (pop y))) + seq)) + (mapc func seq))) ;;;###autoload -(defun cl-mapl (cl-func cl-list &rest cl-rest) +(defun cl-mapl (func list &rest rest) "Like `cl-maplist', but does not accumulate values returned by the function. \n(fn FUNCTION LIST...)" - (if cl-rest - (let ((cl-args (cons cl-list (copy-sequence cl-rest))) - cl-p) - (while (not (memq nil cl-args)) - (apply cl-func cl-args) - (setq cl-p cl-args) - (while cl-p (setcar cl-p (cdr (pop cl-p)))))) - (let ((cl-p cl-list)) - (while cl-p (funcall cl-func cl-p) (setq cl-p (cdr cl-p))))) - cl-list) - -;;;###autoload -(defun cl-mapcan (cl-func cl-seq &rest cl-rest) + (if rest + (let ((args (cons list (copy-sequence rest))) + p) + (while (not (memq nil args)) + (apply func args) + (setq p args) + (while p (setcar p (cdr (pop p)))))) + (let ((p list)) + (while p (funcall func p) (setq p (cdr p))))) + list) + +;;;###autoload +(defun cl-mapcan (func seq &rest rest) "Like `cl-mapcar', but nconc's together the values returned by the function. \n(fn FUNCTION SEQUENCE...)" - (if cl-rest - (apply #'nconc (apply #'cl-mapcar cl-func cl-seq cl-rest)) - (mapcan cl-func cl-seq))) + (declare (important-return-value t)) + (if rest + (apply #'nconc (apply #'cl-mapcar func seq rest)) + (mapcan func seq))) ;;;###autoload -(defun cl-mapcon (cl-func cl-list &rest cl-rest) +(defun cl-mapcon (func list &rest rest) "Like `cl-maplist', but nconc's together the values returned by the function. \n(fn FUNCTION LIST...)" - (apply #'nconc (apply #'cl-maplist cl-func cl-list cl-rest))) + (declare (important-return-value t)) + (apply #'nconc (apply #'cl-maplist func list rest))) ;;;###autoload -(defun cl-some (cl-pred cl-seq &rest cl-rest) +(defun cl-some (pred seq &rest rest) "Say whether PREDICATE is true for any element in the SEQ sequences. More specifically, the return value of this function will be the same as the first return value of PREDICATE where PREDICATE has a non-nil value. \n(fn PREDICATE SEQ...)" - (if (or cl-rest (nlistp cl-seq)) + (declare (important-return-value t)) + (if (or rest (nlistp seq)) (catch 'cl-some (apply #'cl-map nil - (lambda (&rest cl-x) - (let ((cl-res (apply cl-pred cl-x))) - (if cl-res (throw 'cl-some cl-res)))) - cl-seq cl-rest) nil) - (let ((cl-x nil)) - (while (and cl-seq (not (setq cl-x (funcall cl-pred (pop cl-seq)))))) - cl-x))) + (lambda (&rest x) + (let ((res (apply pred x))) + (if res (throw 'cl-some res)))) + seq rest) nil) + (let ((x nil)) + (while (and seq (not (setq x (funcall pred (pop seq)))))) + x))) ;;;###autoload -(defun cl-every (cl-pred cl-seq &rest cl-rest) +(defun cl-every (pred seq &rest rest) "Return true if PREDICATE is true of every element of SEQ or SEQs. \n(fn PREDICATE SEQ...)" - (if (or cl-rest (nlistp cl-seq)) + (declare (important-return-value t)) + (if (or rest (nlistp seq)) (catch 'cl-every (apply #'cl-map nil - (lambda (&rest cl-x) - (or (apply cl-pred cl-x) (throw 'cl-every nil))) - cl-seq cl-rest) t) - (while (and cl-seq (funcall cl-pred (car cl-seq))) - (setq cl-seq (cdr cl-seq))) - (null cl-seq))) + (lambda (&rest x) + (or (apply pred x) (throw 'cl-every nil))) + seq rest) t) + (while (and seq (funcall pred (car seq))) + (setq seq (cdr seq))) + (null seq))) ;;;###autoload -(defun cl-notany (cl-pred cl-seq &rest cl-rest) +(defsubst cl-notany (pred seq &rest rest) "Return true if PREDICATE is false of every element of SEQ or SEQs. \n(fn PREDICATE SEQ...)" - (not (apply #'cl-some cl-pred cl-seq cl-rest))) + (declare (important-return-value t)) + (not (apply #'cl-some pred seq rest))) ;;;###autoload -(defun cl-notevery (cl-pred cl-seq &rest cl-rest) +(defsubst cl-notevery (pred seq &rest rest) "Return true if PREDICATE is false of some element of SEQ or SEQs. \n(fn PREDICATE SEQ...)" - (not (apply #'cl-every cl-pred cl-seq cl-rest))) + (declare (important-return-value t)) + (not (apply #'cl-every pred seq rest))) ;;;###autoload -(defun cl--map-keymap-recursively (cl-func-rec cl-map &optional cl-base) - (or cl-base - (setq cl-base (copy-sequence [0]))) +(defun cl--map-keymap-recursively (func-rec map &optional base) + (or base + (setq base (copy-sequence [0]))) (map-keymap - (lambda (cl-key cl-bind) - (aset cl-base (1- (length cl-base)) cl-key) - (if (keymapp cl-bind) + (lambda (key bind) + (aset base (1- (length base)) key) + (if (keymapp bind) (cl--map-keymap-recursively - cl-func-rec cl-bind - (vconcat cl-base (list 0))) - (funcall cl-func-rec cl-base cl-bind))) - cl-map)) - -;;;###autoload -(defun cl--map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end) - (or cl-what (setq cl-what (current-buffer))) - (if (bufferp cl-what) - (let (cl-mark cl-mark2 (cl-next t) cl-next2) - (with-current-buffer cl-what - (setq cl-mark (copy-marker (or cl-start (point-min)))) - (setq cl-mark2 (and cl-end (copy-marker cl-end)))) - (while (and cl-next (or (not cl-mark2) (< cl-mark cl-mark2))) - (setq cl-next (if cl-prop (next-single-property-change - cl-mark cl-prop cl-what) - (next-property-change cl-mark cl-what)) - cl-next2 (or cl-next (with-current-buffer cl-what - (point-max)))) - (funcall cl-func (prog1 (marker-position cl-mark) - (set-marker cl-mark cl-next2)) - (if cl-mark2 (min cl-next2 cl-mark2) cl-next2))) - (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil))) - (or cl-start (setq cl-start 0)) - (or cl-end (setq cl-end (length cl-what))) - (while (< cl-start cl-end) - (let ((cl-next (or (if cl-prop (next-single-property-change - cl-start cl-prop cl-what) - (next-property-change cl-start cl-what)) - cl-end))) - (funcall cl-func cl-start (min cl-next cl-end)) - (setq cl-start cl-next))))) - -;;;###autoload -(defun cl--map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg) - (or cl-buffer (setq cl-buffer (current-buffer))) - (let (cl-ovl) - (with-current-buffer cl-buffer - (setq cl-ovl (overlay-lists)) - (if cl-start (setq cl-start (copy-marker cl-start))) - (if cl-end (setq cl-end (copy-marker cl-end)))) - (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl))) - (while (and cl-ovl - (or (not (overlay-start (car cl-ovl))) - (and cl-end (>= (overlay-start (car cl-ovl)) cl-end)) - (and cl-start (<= (overlay-end (car cl-ovl)) cl-start)) - (not (funcall cl-func (car cl-ovl) cl-arg)))) - (setq cl-ovl (cdr cl-ovl))) - (if cl-start (set-marker cl-start nil)) - (if cl-end (set-marker cl-end nil)))) + func-rec bind + (vconcat base (list 0))) + (funcall func-rec base bind))) + map)) + +;;;###autoload +(defun cl--map-intervals (func &optional what prop start end) + (or what (setq what (current-buffer))) + (if (bufferp what) + (let (mark mark2 (next t) next2) + (with-current-buffer what + (setq mark (copy-marker (or start (point-min)))) + (setq mark2 (and end (copy-marker end)))) + (while (and next (or (not mark2) (< mark mark2))) + (setq next (if prop (next-single-property-change + mark prop what) + (next-property-change mark what)) + next2 (or next (with-current-buffer what + (point-max)))) + (funcall func (prog1 (marker-position mark) + (set-marker mark next2)) + (if mark2 (min next2 mark2) next2))) + (set-marker mark nil) (if mark2 (set-marker mark2 nil))) + (or start (setq start 0)) + (or end (setq end (length what))) + (while (< start end) + (let ((next (or (if prop (next-single-property-change + start prop what) + (next-property-change start what)) + end))) + (funcall func start (min next end)) + (setq start next))))) + +;;;###autoload +(defun cl--map-overlays (func &optional buffer start end arg) + (or buffer (setq buffer (current-buffer))) + (let (ovl) + (with-current-buffer buffer + (setq ovl (overlay-lists)) + (if start (setq start (copy-marker start))) + (if end (setq end (copy-marker end)))) + (setq ovl (nconc (car ovl) (cdr ovl))) + (while (and ovl + (or (not (overlay-start (car ovl))) + (and end (>= (overlay-start (car ovl)) end)) + (and start (<= (overlay-end (car ovl)) start)) + (not (funcall func (car ovl) arg)))) + (setq ovl (cdr ovl))) + (if start (set-marker start nil)) + (if end (set-marker end nil)))) ;;; Support for `setf'. ;;;###autoload @@ -317,6 +326,7 @@ non-nil value. ;;;###autoload (defun cl-gcd (&rest args) "Return the greatest common divisor of the arguments." + (declare (side-effect-free t)) (let ((a (or (pop args) 0))) (dolist (b args) (while (/= b 0) @@ -326,6 +336,7 @@ non-nil value. ;;;###autoload (defun cl-lcm (&rest args) "Return the least common multiple of the arguments." + (declare (side-effect-free t)) (if (memq 0 args) 0 (let ((a (or (pop args) 1))) @@ -336,6 +347,7 @@ non-nil value. ;;;###autoload (defun cl-isqrt (x) "Return the integer square root of the (integer) argument X." + (declare (side-effect-free t)) (if (and (integerp x) (> x 0)) (let ((g (ash 2 (/ (logb x) 2))) g2) @@ -348,6 +360,7 @@ non-nil value. (defun cl-floor (x &optional y) "Return a list of the floor of X and the fractional part of X. With two arguments, return floor and remainder of their quotient." + (declare (side-effect-free t)) (let ((q (floor x y))) (list q (- x (if y (* y q) q))))) @@ -355,6 +368,7 @@ With two arguments, return floor and remainder of their quotient." (defun cl-ceiling (x &optional y) "Return a list of the ceiling of X and the fractional part of X. With two arguments, return ceiling and remainder of their quotient." + (declare (side-effect-free t)) (let ((res (cl-floor x y))) (if (= (car (cdr res)) 0) res (list (1+ (car res)) (- (car (cdr res)) (or y 1)))))) @@ -363,6 +377,7 @@ With two arguments, return ceiling and remainder of their quotient." (defun cl-truncate (x &optional y) "Return a list of the integer part of X and the fractional part of X. With two arguments, return truncation and remainder of their quotient." + (declare (side-effect-free t)) (if (eq (>= x 0) (or (null y) (>= y 0))) (cl-floor x y) (cl-ceiling x y))) @@ -370,13 +385,14 @@ With two arguments, return truncation and remainder of their quotient." (defun cl-round (x &optional y) "Return a list of X rounded to the nearest integer and the remainder. With two arguments, return rounding and remainder of their quotient." + (declare (side-effect-free t)) (if y (if (and (integerp x) (integerp y)) (let* ((hy (/ y 2)) (res (cl-floor (+ x hy) y))) (if (and (= (car (cdr res)) 0) (= (+ hy hy) y) - (/= (% (car res) 2) 0)) + (oddp (car res))) (list (1- (car res)) hy) (list (car res) (- (car (cdr res)) hy)))) (let ((q (round (/ x y)))) @@ -388,16 +404,19 @@ With two arguments, return rounding and remainder of their quotient." ;;;###autoload (defun cl-mod (x y) "The remainder of X divided by Y, with the same sign as Y." + (declare (side-effect-free t)) (nth 1 (cl-floor x y))) ;;;###autoload (defun cl-rem (x y) "The remainder of X divided by Y, with the same sign as X." + (declare (side-effect-free t)) (nth 1 (cl-truncate x y))) ;;;###autoload (defun cl-signum (x) "Return 1 if X is positive, -1 if negative, 0 if zero." + (declare (side-effect-free t)) (cond ((> x 0) 1) ((< x 0) -1) (t 0))) ;;;###autoload @@ -422,8 +441,8 @@ as an integer unless JUNK-ALLOWED is non-nil." (setq start (1+ start))))) (skip-whitespace) (let ((sign (cl-case (and (< start end) (aref string start)) - (?+ (cl-incf start) +1) - (?- (cl-incf start) -1) + (?+ (incf start) +1) + (?- (incf start) -1) (t +1))) digit sum) (while (and (< start end) @@ -441,12 +460,13 @@ as an integer unless JUNK-ALLOWED is non-nil." ;; Random numbers. (defun cl--random-time () - "Return high-precision timestamp from `time-convert'. + "Return high-precision timestamp from `time-convert'. For example, suitable for use as seed by `cl-make-random-state'." - (car (time-convert nil t))) + (car (time-convert nil t))) ;;;###autoload (autoload 'cl-random-state-p "cl-extra") +;;;###autoload (function-put 'cl-random-state-p 'side-effect-free 'error-free) (cl-defstruct (cl--random-state (:copier nil) (:predicate cl-random-state-p) @@ -549,7 +569,8 @@ If END is omitted, it defaults to the length of the sequence. If START or END is negative, it counts from the end. Signal an error if START or END are outside of the sequence (i.e too large if positive or too small if negative)." - (declare (gv-setter + (declare (side-effect-free t) + (gv-setter (lambda (new) (macroexp-let2 nil new new `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end) @@ -568,19 +589,21 @@ too large if positive or too small if negative)." ;;; List functions. ;;;###autoload -(defun cl-revappend (x y) +(defsubst cl-revappend (x y) "Equivalent to (append (reverse X) Y)." (declare (side-effect-free t)) (nconc (reverse x) y)) ;;;###autoload -(defun cl-nreconc (x y) +(defsubst cl-nreconc (x y) "Equivalent to (nconc (nreverse X) Y)." + (declare (important-return-value t)) (nconc (nreverse x) y)) ;;;###autoload (defun cl-list-length (x) "Return the length of list X. Return nil if list is circular." + (declare (side-effect-free t)) (cl-check-type x list) (condition-case nil (length x) @@ -599,7 +622,8 @@ too large if positive or too small if negative)." (defun cl-get (sym tag &optional def) "Return the value of SYMBOL's PROPNAME property, or DEFAULT if none. \n(fn SYMBOL PROPNAME &optional DEFAULT)" - (declare (compiler-macro cl--compiler-macro-get) + (declare (side-effect-free t) + (compiler-macro cl--compiler-macro-get) (gv-setter (lambda (store) (ignore def) `(put ,sym ,tag ,store)))) (cl-getf (symbol-plist sym) tag def)) (autoload 'cl--compiler-macro-get "cl-macs") @@ -609,7 +633,8 @@ too large if positive or too small if negative)." "Search PROPLIST for property PROPNAME; return its value or DEFAULT. PROPLIST is a list of the sort returned by `symbol-plist'. \n(fn PROPLIST PROPNAME &optional DEFAULT)" - (declare (gv-expander + (declare (side-effect-free t) + (gv-expander (lambda (do) (gv-letplace (getter setter) plist (macroexp-let2* nil ((k tag) (d def)) @@ -722,7 +747,7 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (define-button-type 'cl-type-definition :supertype 'help-function-def - 'help-echo (purecopy "mouse-2, RET: find type definition")) + 'help-echo "mouse-2, RET: find type definition") (declare-function help-fns-short-filename "help-fns" (filename)) @@ -733,6 +758,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 +780,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))))) @@ -880,7 +908,7 @@ Call `cl--find-class' to get TYPE's propname `cl--class'" `(space :align-to ,(+ col col-space))) "%s") formats) - (cl-incf col (+ col-space (aref cols i)))) + (incf col (+ col-space (aref cols i)))) (let ((format (mapconcat #'identity (nreverse formats)))) (insert (apply #'format format (mapcar (lambda (str) (propertize str 'face 'italic)) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 3aa26fba3c3..9a7fe26eaf3 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -509,7 +509,7 @@ Presumes point is at the end of the `cl-defmethod' symbol." (let ((n 2)) (while (and (ignore-errors (forward-sexp 1) t) (not (eq (char-before) ?\)))) - (cl-incf n)) + (incf n)) n))) ;;;###autoload @@ -654,11 +654,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (symbol-function sym))) ;; Prevent `defalias' from recording this as the definition site of ;; the generic function. - current-load-list - ;; BEWARE! Don't purify this function definition, since that leads - ;; to memory corruption if the hash-tables it holds are modified - ;; (the GC doesn't trace those pointers). - (purify-flag nil)) + current-load-list) (when (listp old-adv-cc) (set-advertised-calling-convention gfun old-adv-cc nil)) ;; But do use `defalias', so that it interacts properly with nadvice, diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el index 0695edc3d12..5ea7015adf0 100644 --- a/lisp/emacs-lisp/cl-indent.el +++ b/lisp/emacs-lisp/cl-indent.el @@ -179,13 +179,13 @@ the standard Lisp indent package." (when (and (eq lisp-indent-backquote-substitution-mode 'corrected)) (save-excursion (goto-char (elt state 1)) - (cl-incf loop-indentation - (cond ((eq (char-before) ?,) -1) - ((and (eq (char-before) ?@) - (progn (backward-char) - (eq (char-before) ?,))) - -2) - (t 0))))) + (incf loop-indentation + (cond ((eq (char-before) ?,) -1) + ((and (eq (char-before) ?@) + (progn (backward-char) + (eq (char-before) ?,))) + -2) + (t 0))))) (goto-char indent-point) (beginning-of-line) @@ -400,9 +400,9 @@ instead." ;; ",(...)" or ",@(...)" (when (eq lisp-indent-backquote-substitution-mode 'corrected) - (cl-incf sexp-column -1) + (incf sexp-column -1) (when (eq (char-after (1- containing-sexp)) ?\@) - (cl-incf sexp-column -1))) + (incf sexp-column -1))) (cond (lisp-indent-backquote-substitution-mode (setf tentative-calculated normal-indent) (setq depth lisp-indent-maximum-backtracking) @@ -706,7 +706,7 @@ optional\\|rest\\|key\\|allow-other-keys\\|aux\\|whole\\|body\\|environment\ (forward-sexp 2) (skip-chars-forward " \t\n") (while (looking-at "\\sw\\|\\s_") - (cl-incf nqual) + (incf nqual) (forward-sexp) (skip-chars-forward " \t\n")) (> nqual 0))) diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 3f7ca28d2bb..4208160bd12 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -105,29 +105,27 @@ a future Emacs interpreter will be able to use it.") ;; can safely be used in init files. ;;;###autoload -(defmacro cl-incf (place &optional x) +(defalias 'cl-incf #'incf "Increment PLACE by X (1 by default). PLACE may be a symbol, or any generalized variable allowed by `setf'. The return value is the incremented value of PLACE. If X is specified, it should be an expression that should -evaluate to a number." - (declare (debug (place &optional form))) - (if (symbolp place) - (list 'setq place (if x (list '+ place x) (list '1+ place))) - (list 'cl-callf '+ place (or x 1)))) +evaluate to a number. + +This macro is considered deprecated in favor of the built-in macro +`incf' that was added in Emacs 31.1.") -(defmacro cl-decf (place &optional x) +(defalias 'cl-decf #'decf "Decrement PLACE by X (1 by default). PLACE may be a symbol, or any generalized variable allowed by `setf'. The return value is the decremented value of PLACE. If X is specified, it should be an expression that should -evaluate to a number." - (declare (debug cl-incf)) - (if (symbolp place) - (list 'setq place (if x (list '- place x) (list '1- place))) - (list 'cl-callf '- place (or x 1)))) +evaluate to a number. + +This macro is considered deprecated in favor of the built-in macro +`decf' that was added in Emacs 31.1.") (defmacro cl-pushnew (x place &rest keys) "Add X to the list stored in PLACE unless X is already in the list. @@ -164,9 +162,9 @@ to an element already in the list stored in PLACE. val)) (defun cl--set-substring (str start end val) - (if end (if (< end 0) (cl-incf end (length str))) + (if end (if (< end 0) (incf end (length str))) (setq end (length str))) - (if (< start 0) (cl-incf start (length str))) + (if (< start 0) (incf start (length str))) (concat (and (> start 0) (substring str 0 start)) val (and (< end (length str)) (substring str end)))) @@ -185,8 +183,8 @@ to an element already in the list stored in PLACE. ;;; Blocks and exits. -(defalias 'cl--block-wrapper 'identity) -(defalias 'cl--block-throw 'throw) +(defalias 'cl--block-wrapper #'identity) +(defalias 'cl--block-throw #'throw) ;;; Multiple values. @@ -232,7 +230,7 @@ right when EXPRESSION calls an ordinary Emacs Lisp function that returns just one value." (apply function expression)) -(defalias 'cl-multiple-value-call 'apply +(defalias 'cl-multiple-value-call #'apply "Apply FUNCTION to ARGUMENTS, taking multiple values into account. This implementation only handles the case where there is only one argument.") @@ -270,21 +268,29 @@ so that they are registered at compile-time as well as run-time." (define-obsolete-function-alias 'cl-floatp-safe 'floatp "24.4") -(defsubst cl-plusp (number) - "Return t if NUMBER is positive." - (> number 0)) +(defalias 'cl-plusp #'plusp + "Return t if NUMBER is positive. + +This function is considered deprecated in favor of the built-in function +`plusp' that was added in Emacs 31.1.") -(defsubst cl-minusp (number) - "Return t if NUMBER is negative." - (< number 0)) +(defalias 'cl-minusp #'minusp + "Return t if NUMBER is negative. -(defun cl-oddp (integer) - "Return t if INTEGER is odd." - (eq (logand integer 1) 1)) +This function is considered deprecated in favor of the built-in function +`minusp' that was added in Emacs 31.1.") -(defun cl-evenp (integer) - "Return t if INTEGER is even." - (eq (logand integer 1) 0)) +(defalias 'cl-oddp #'oddp + "Return t if INTEGER is odd. + +This function is considered deprecated in favor of the built-in function +`oddp' that was added in Emacs 31.1.") + +(defalias 'cl-evenp #'evenp + "Return t if INTEGER is even. + +This function is considered deprecated in favor of the built-in function +`evenp' that was added in Emacs 31.1.") (defconst cl-digit-char-table (let* ((digits (make-vector 256 nil)) @@ -352,98 +358,105 @@ Call `cl-float-limits' to set this.") ;;; Sequence functions. -(cl--defalias 'cl-copy-seq 'copy-sequence) +(cl--defalias 'cl-copy-seq #'copy-sequence) (declare-function cl--mapcar-many "cl-extra" (cl-func cl-seqs &optional acc)) -(defun cl-mapcar (cl-func cl-x &rest cl-rest) +(defun cl-mapcar (func x &rest rest) "Apply FUNCTION to each element of SEQ, and make a list of the results. If there are several SEQs, FUNCTION is called with that many arguments, and mapping stops as soon as the shortest list runs out. With just one SEQ, this is like `mapcar'. With several, it is like the Common Lisp `mapcar' function extended to arbitrary sequence types. \n(fn FUNCTION SEQ...)" - (if cl-rest - (if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest))) - (cl--mapcar-many cl-func (cons cl-x cl-rest) 'accumulate) - (let ((cl-res nil) (cl-y (car cl-rest))) - (while (and cl-x cl-y) - (push (funcall cl-func (pop cl-x) (pop cl-y)) cl-res)) - (nreverse cl-res))) - (mapcar cl-func cl-x))) - -(cl--defalias 'cl-svref 'aref) + (declare (important-return-value t)) + (if rest + (if (or (cdr rest) (nlistp x) (nlistp (car rest))) + (cl--mapcar-many func (cons x rest) 'accumulate) + (let ((res nil) (y (car rest))) + (while (and x y) + (push (funcall func (pop x) (pop y)) res)) + (nreverse res))) + (mapcar func x))) + +(cl--defalias 'cl-svref #'aref) ;;; List functions. -(cl--defalias 'cl-first 'car) -(cl--defalias 'cl-second 'cadr) -(cl--defalias 'cl-rest 'cdr) +(cl--defalias 'cl-first #'car) +(cl--defalias 'cl-second #'cadr) +(cl--defalias 'cl-rest #'cdr) (cl--defalias 'cl-third #'caddr "Return the third element of the list X.") (cl--defalias 'cl-fourth #'cadddr "Return the fourth element of the list X.") (defsubst cl-fifth (x) "Return the fifth element of the list X." - (declare (gv-setter (lambda (store) `(setcar (nthcdr 4 ,x) ,store)))) + (declare (side-effect-free t) + (gv-setter (lambda (store) `(setcar (nthcdr 4 ,x) ,store)))) (nth 4 x)) (defsubst cl-sixth (x) "Return the sixth element of the list X." - (declare (gv-setter (lambda (store) `(setcar (nthcdr 5 ,x) ,store)))) + (declare (side-effect-free t) + (gv-setter (lambda (store) `(setcar (nthcdr 5 ,x) ,store)))) (nth 5 x)) (defsubst cl-seventh (x) "Return the seventh element of the list X." - (declare (gv-setter (lambda (store) `(setcar (nthcdr 6 ,x) ,store)))) + (declare (side-effect-free t) + (gv-setter (lambda (store) `(setcar (nthcdr 6 ,x) ,store)))) (nth 6 x)) (defsubst cl-eighth (x) "Return the eighth element of the list X." - (declare (gv-setter (lambda (store) `(setcar (nthcdr 7 ,x) ,store)))) + (declare (side-effect-free t) + (gv-setter (lambda (store) `(setcar (nthcdr 7 ,x) ,store)))) (nth 7 x)) (defsubst cl-ninth (x) "Return the ninth element of the list X." - (declare (gv-setter (lambda (store) `(setcar (nthcdr 8 ,x) ,store)))) + (declare (side-effect-free t) + (gv-setter (lambda (store) `(setcar (nthcdr 8 ,x) ,store)))) (nth 8 x)) (defsubst cl-tenth (x) "Return the tenth element of the list X." - (declare (gv-setter (lambda (store) `(setcar (nthcdr 9 ,x) ,store)))) + (declare (side-effect-free t) + (gv-setter (lambda (store) `(setcar (nthcdr 9 ,x) ,store)))) (nth 9 x)) -(defalias 'cl-caaar 'caaar) -(defalias 'cl-caadr 'caadr) -(defalias 'cl-cadar 'cadar) -(defalias 'cl-caddr 'caddr) -(defalias 'cl-cdaar 'cdaar) -(defalias 'cl-cdadr 'cdadr) -(defalias 'cl-cddar 'cddar) -(defalias 'cl-cdddr 'cdddr) -(defalias 'cl-caaaar 'caaaar) -(defalias 'cl-caaadr 'caaadr) -(defalias 'cl-caadar 'caadar) -(defalias 'cl-caaddr 'caaddr) -(defalias 'cl-cadaar 'cadaar) -(defalias 'cl-cadadr 'cadadr) -(defalias 'cl-caddar 'caddar) -(defalias 'cl-cadddr 'cadddr) -(defalias 'cl-cdaaar 'cdaaar) -(defalias 'cl-cdaadr 'cdaadr) -(defalias 'cl-cdadar 'cdadar) -(defalias 'cl-cdaddr 'cdaddr) -(defalias 'cl-cddaar 'cddaar) -(defalias 'cl-cddadr 'cddadr) -(defalias 'cl-cdddar 'cdddar) -(defalias 'cl-cddddr 'cddddr) +(defalias 'cl-caaar #'caaar) +(defalias 'cl-caadr #'caadr) +(defalias 'cl-cadar #'cadar) +(defalias 'cl-caddr #'caddr) +(defalias 'cl-cdaar #'cdaar) +(defalias 'cl-cdadr #'cdadr) +(defalias 'cl-cddar #'cddar) +(defalias 'cl-cdddr #'cdddr) +(defalias 'cl-caaaar #'caaaar) +(defalias 'cl-caaadr #'caaadr) +(defalias 'cl-caadar #'caadar) +(defalias 'cl-caaddr #'caaddr) +(defalias 'cl-cadaar #'cadaar) +(defalias 'cl-cadadr #'cadadr) +(defalias 'cl-caddar #'caddar) +(defalias 'cl-cadddr #'cadddr) +(defalias 'cl-cdaaar #'cdaaar) +(defalias 'cl-cdaadr #'cdaadr) +(defalias 'cl-cdadar #'cdadar) +(defalias 'cl-cdaddr #'cdaddr) +(defalias 'cl-cddaar #'cddaar) +(defalias 'cl-cddadr #'cddadr) +(defalias 'cl-cdddar #'cdddar) +(defalias 'cl-cddddr #'cddddr) ;;(defun last* (x &optional n) ;; "Returns the last link in the list LIST. ;;With optional argument N, returns Nth-to-last link (default 1)." ;; (if n ;; (let ((m 0) (p x)) -;; (while (consp p) (cl-incf m) (pop p)) +;; (while (consp p) (incf m) (pop p)) ;; (if (<= n 0) p ;; (if (< n m) (nthcdr (- m n) x) x))) ;; (while (consp (cdr x)) (pop x)) @@ -454,7 +467,8 @@ SEQ, this is like `mapcar'. With several, it is like the Common Lisp Thus, `(cl-list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to `(cons A (cons B (cons C D)))'. \n(fn ARG...)" - (declare (compiler-macro cl--compiler-macro-list*)) + (declare (side-effect-free error-free) + (compiler-macro cl--compiler-macro-list*)) (cond ((not rest) arg) ((not (cdr rest)) (cons arg (car rest))) (t (let* ((n (length rest)) @@ -465,6 +479,7 @@ Thus, `(cl-list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to (defun cl-ldiff (list sublist) "Return a copy of LIST with the tail SUBLIST removed." + (declare (side-effect-free t)) (let ((res nil)) (while (and (consp list) (not (eq list sublist))) (push (pop list) res)) @@ -487,40 +502,43 @@ The elements of LIST are not copied, just the list structure itself." (declare-function cl-round "cl-extra" (x &optional y)) (declare-function cl-mod "cl-extra" (x y)) -(defun cl-adjoin (cl-item cl-list &rest cl-keys) +(defun cl-adjoin (item list &rest keys) "Return ITEM consed onto the front of LIST only if it's not already there. Otherwise, return LIST unmodified. \nKeywords supported: :test :test-not :key \n(fn ITEM LIST [KEYWORD VALUE]...)" - (declare (compiler-macro cl--compiler-macro-adjoin)) - (cond ((or (equal cl-keys '(:test eq)) - (and (null cl-keys) (not (numberp cl-item)))) - (if (memq cl-item cl-list) cl-list (cons cl-item cl-list))) - ((or (equal cl-keys '(:test equal)) (null cl-keys)) - (if (member cl-item cl-list) cl-list (cons cl-item cl-list))) - (t (apply 'cl--adjoin cl-item cl-list cl-keys)))) - -(defun cl-subst (cl-new cl-old cl-tree &rest cl-keys) + (declare (important-return-value t) + (compiler-macro cl--compiler-macro-adjoin)) + (cond ((or (equal keys '(:test eq)) + (and (null keys) (not (numberp item)))) + (if (memq item list) list (cons item list))) + ((or (equal keys '(:test equal)) (null keys)) + (if (member item list) list (cons item list))) + (t (apply 'cl--adjoin item list keys)))) + +(defun cl-subst (new old tree &rest keys) "Substitute NEW for OLD everywhere in TREE (non-destructively). Return a copy of TREE with all elements `eql' to OLD replaced by NEW. \nKeywords supported: :test :test-not :key \n(fn NEW OLD TREE [KEYWORD VALUE]...)" - (if (or cl-keys (and (numberp cl-old) (not (integerp cl-old)))) - (apply 'cl-sublis (list (cons cl-old cl-new)) cl-tree cl-keys) - (cl--do-subst cl-new cl-old cl-tree))) - -(defun cl--do-subst (cl-new cl-old cl-tree) - (cond ((eq cl-tree cl-old) cl-new) - ((consp cl-tree) - (let ((a (cl--do-subst cl-new cl-old (car cl-tree))) - (d (cl--do-subst cl-new cl-old (cdr cl-tree)))) - (if (and (eq a (car cl-tree)) (eq d (cdr cl-tree))) - cl-tree (cons a d)))) - (t cl-tree))) - -(defun cl-acons (key value alist) + (declare (important-return-value t)) + (if (or keys (and (numberp old) (not (integerp old)))) + (apply 'cl-sublis (list (cons old new)) tree keys) + (cl--do-subst new old tree))) + +(defun cl--do-subst (new old tree) + (cond ((eq tree old) new) + ((consp tree) + (let ((a (cl--do-subst new old (car tree))) + (d (cl--do-subst new old (cdr tree)))) + (if (and (eq a (car tree)) (eq d (cdr tree))) + tree (cons a d)))) + (t tree))) + +(defsubst cl-acons (key value alist) "Add KEY and VALUE to ALIST. Return a new list with (cons KEY VALUE) as car and ALIST as cdr." + (declare (side-effect-free error-free)) (cons (cons key value) alist)) (defun cl-pairlis (keys values &optional alist) @@ -528,6 +546,7 @@ Return a new list with (cons KEY VALUE) as car and ALIST as cdr." Return a new alist composed by associating KEYS to corresponding VALUES; the process stops as soon as KEYS or VALUES run out. If ALIST is non-nil, the new pairs are prepended to it." + (declare (side-effect-free t)) (nconc (cl-mapcar 'cons keys values) alist)) ;;; Miscellaneous. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 99c105c7559..89319a05b27 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -70,9 +70,6 @@ (setq form `(cons ,(car args) ,form))) form)) -;; Note: `cl--compiler-macro-cXXr' has been copied to -;; `internal--compiler-macro-cXXr' in subr.el. If you amend either -;; one, you may want to amend the other, too. ;;;###autoload (define-obsolete-function-alias 'cl--compiler-macro-cXXr #'internal--compiler-macro-cXXr "25.1") @@ -169,6 +166,7 @@ whether X is known at compile time, macroexpand it completely in (defun cl-gensym (&optional prefix) "Generate a new uninterned symbol. The name is made by appending a number to PREFIX, default \"G\"." + (declare (obsolete gensym "31.1")) (let ((pfix (if (stringp prefix) prefix "G")) (num (if (integerp prefix) prefix (prog1 cl--gensym-counter @@ -339,7 +337,7 @@ FORM is of the form (ARGS . BODY)." (format "%S" (cons 'fn (cl--make-usage-args orig-args)))))))) (when (memq '&optional simple-args) - (cl-decf slen)) + (decf slen)) (setq header (cons (if (eq :documentation (car-safe (car header))) @@ -901,9 +899,13 @@ references may appear inside macro expansions, but not inside functions called from BODY." (declare (indent 1) (debug (symbolp body))) (if (cl--safe-expr-p `(progn ,@body)) `(progn ,@body) - `(cl--block-wrapper - (catch ',(intern (format "--cl-block-%s--" name)) - ,@body)))) + (let ((var (intern (format "--cl-block-%s--" name)))) + `(cl--block-wrapper + ;; Build a unique "tag" in the form of a fresh cons. + ;; We include `var' in the cons, just in case it help debugging. + (let ((,var (cons ',var nil))) + (catch ,var + ,@body)))))) ;;;###autoload (defmacro cl-return (&optional result) @@ -921,7 +923,7 @@ This is compatible with Common Lisp, but note that `defun' and `defmacro' do not create implicit blocks as they do in Common Lisp." (declare (indent 1) (debug (symbolp &optional form))) (let ((name2 (intern (format "--cl-block-%s--" name)))) - `(cl--block-throw ',name2 ,result))) + `(cl--block-throw ,name2 ,result))) ;;; The "cl-loop" macro. @@ -1269,10 +1271,10 @@ For more details, see Info node `(cl)Loop Facility'. (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil) (ands nil)) (while - ;; Use `cl-gensym' rather than `make-symbol'. It's important that + ;; Use `gensym' rather than `make-symbol'. It's important that ;; (not (eq (symbol-name var1) (symbol-name var2))) because ;; these vars get added to the macro-environment. - (let ((var (or (pop cl--loop-args) (cl-gensym "--cl-var--")))) + (let ((var (or (pop cl--loop-args) (gensym "--cl-var--")))) (setq word (pop cl--loop-args)) (if (eq word 'being) (setq word (pop cl--loop-args))) (if (memq word '(the each)) (setq word (pop cl--loop-args))) @@ -1479,7 +1481,7 @@ For more details, see Info node `(cl)Loop Facility'. ((memq word key-types) (or (memq (car cl--loop-args) '(in of)) (error "Expected `of'")) - (let ((cl-map (cl--pop2 cl--loop-args)) + (let ((map (cl--pop2 cl--loop-args)) (other (if (eq (car cl--loop-args) 'using) (if (and (= (length (cadr cl--loop-args)) 2) @@ -1494,7 +1496,7 @@ For more details, see Info node `(cl)Loop Facility'. 'keys (lambda (body) `(,(if (memq word '(key-seq key-seqs)) 'cl--map-keymap-recursively 'map-keymap) - (lambda (,var ,other) . ,body) ,cl-map))))) + (lambda (,var ,other) . ,body) ,map))))) ((memq word '(frame frames screen screens)) (let ((temp (make-symbol "--cl-var--"))) @@ -1597,12 +1599,12 @@ For more details, see Info node `(cl)Loop Facility'. ((memq word '(sum summing)) (let ((what (pop cl--loop-args)) (var (cl--loop-handle-accum 0))) - (push `(progn (cl-incf ,var ,what) t) cl--loop-body))) + (push `(progn (incf ,var ,what) t) cl--loop-body))) ((memq word '(count counting)) (let ((what (pop cl--loop-args)) (var (cl--loop-handle-accum 0))) - (push `(progn (if ,what (cl-incf ,var)) t) cl--loop-body))) + (push `(progn (if ,what (incf ,var)) t) cl--loop-body))) ((memq word '(minimize minimizing maximize maximizing)) (push `(progn ,(macroexp-let2 macroexp-copyable-p temp @@ -2058,7 +2060,7 @@ a `let' form, except that the list of symbols can be computed at run-time." (funcall (cdr found) cl--labels-magic))))) (if (and replacement (eq cl--labels-magic (car replacement))) (nth 1 replacement) - ;; FIXME: Here, we'd like to return the `&whole' form, but since ELisp + ;; FIXME: Here, we'd like to return the `&whole' form, but since Elisp ;; doesn't have that, we approximate it via `cl--labels-convert-cache'. (let ((res `(function ,f))) (setq cl--labels-convert-cache (cons f res)) @@ -2067,7 +2069,6 @@ a `let' form, except that the list of symbols can be computed at run-time." ;;;###autoload (defmacro cl-flet (bindings &rest body) "Make local function definitions. - 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 @@ -2096,15 +2097,22 @@ function definitions. Use `cl-labels' for that. See Info node 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,6 +2255,23 @@ 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. @@ -2264,7 +2289,7 @@ and mutually recursive function definitions. See Info node (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) @@ -2275,18 +2300,22 @@ and mutually recursive function definitions. See Info node (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) @@ -2592,10 +2621,8 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). ;;; Declarations. ;;;###autoload -(defmacro cl-locally (&rest body) - "Equivalent to `progn'." - (declare (debug t)) - (cons 'progn body)) +(define-obsolete-function-alias 'cl-locally #'progn "31.1") + ;;;###autoload (defmacro cl-the (type form) "Return FORM. If type-checking is enabled, assert that it is of TYPE." @@ -2669,7 +2696,7 @@ Example: (let ((speed (assq (nth 1 (assq 'speed (cdr spec))) '((0 nil) (1 t) (2 t) (3 t)))) (safety (assq (nth 1 (assq 'safety (cdr spec))) - '((0 t) (1 t) (2 t) (3 nil))))) + '((0 t) (1 nil) (2 nil) (3 nil))))) (if speed (setq cl--optimize-speed (car speed) byte-optimize (nth 1 speed))) (if safety (setq cl--optimize-safety (car safety) @@ -2698,6 +2725,7 @@ For instance will turn off byte-compile warnings in the function. See Info node `(cl)Declarations' for details." + (declare (obsolete defvar "31.1")) (if (macroexp-compiling-p) (while specs (if (listp cl--declare-stack) (push (car specs) cl--declare-stack)) @@ -3227,7 +3255,7 @@ To see the documentation for a defined struct type, use (declare (side-effect-free t)) ,access-body) forms) - (when (cl-oddp (length desc)) + (when (oddp (length desc)) (push (macroexp-warn-and-return (format-message @@ -3644,20 +3672,24 @@ macro that returns its `&whole' argument." (defvar cl--active-block-names nil) -(cl-define-compiler-macro cl--block-wrapper (cl-form) - (let* ((cl-entry (cons (nth 1 (nth 1 cl-form)) nil)) - (cl--active-block-names (cons cl-entry cl--active-block-names)) - (cl-body (macroexpand-all ;Performs compiler-macro expansions. - (macroexp-progn (cddr cl-form)) - macroexpand-all-environment))) - ;; FIXME: To avoid re-applying macroexpand-all, we'd like to be able - ;; to indicate that this return value is already fully expanded. - (if (cdr cl-entry) - `(catch ,(nth 1 cl-form) ,@(macroexp-unprogn cl-body)) - cl-body))) +(cl-define-compiler-macro cl--block-wrapper (form) + (pcase form + (`(let ((,var . ,val)) (catch ,var . ,body)) + (let* ((cl-entry (cons var nil)) + (cl--active-block-names (cons cl-entry cl--active-block-names)) + (cl-body (macroexpand-all ;Performs compiler-macro expansions. + (macroexp-progn body) + macroexpand-all-environment))) + ;; FIXME: To avoid re-applying macroexpand-all, we'd like to be able + ;; to indicate that this return value is already fully expanded. + (if (cdr cl-entry) + `(let ((,var . ,val)) (catch ,var ,@(macroexp-unprogn cl-body))) + cl-body))) + ;; `form' was somehow mangled, god knows what happened, let's not touch it. + (_ form))) (cl-define-compiler-macro cl--block-throw (cl-tag cl-value) - (let ((cl-found (assq (nth 1 cl-tag) cl--active-block-names))) + (let ((cl-found (and (symbolp cl-tag) (assq cl-tag cl--active-block-names)))) (if cl-found (setcdr cl-found t))) `(throw ,cl-tag ,cl-value)) @@ -3692,74 +3724,6 @@ macro that returns its `&whole' argument." `(cl-getf (symbol-plist ,sym) ,prop ,def) `(get ,sym ,prop))) -(dolist (y '(cl-first cl-second cl-third cl-fourth - cl-fifth cl-sixth cl-seventh - cl-eighth cl-ninth cl-tenth - cl-rest cl-endp cl-plusp cl-minusp - cl-caaar cl-caadr cl-cadar - cl-caddr cl-cdaar cl-cdadr - cl-cddar cl-cdddr cl-caaaar - cl-caaadr cl-caadar cl-caaddr - cl-cadaar cl-cadadr cl-caddar - cl-cadddr cl-cdaaar cl-cdaadr - cl-cdadar cl-cdaddr cl-cddaar - cl-cddadr cl-cdddar cl-cddddr)) - (put y 'side-effect-free t)) - -;;; Things that are inline. -(cl-proclaim '(inline cl-acons cl-map cl-notany cl-notevery cl-revappend - cl-nreconc)) - -;;; Things that are side-effect-free. -(mapc (lambda (x) (function-put x 'side-effect-free t)) - '(cl-oddp cl-evenp cl-signum cl-ldiff cl-pairlis cl-gcd - cl-lcm cl-isqrt cl-floor cl-ceiling cl-truncate cl-round cl-mod cl-rem - cl-subseq cl-list-length cl-get cl-getf)) - -;;; Things that are side-effect-and-error-free. -(mapc (lambda (x) (function-put x 'side-effect-free 'error-free)) - '(cl-list* cl-acons cl-equalp - cl-random-state-p copy-tree)) - -;;; Things whose return value should probably be used. -(mapc (lambda (x) (function-put x 'important-return-value t)) - '( - ;; Functions that are side-effect-free except for the - ;; behavior of functions passed as argument. - cl-mapcar cl-mapcan cl-maplist cl-map cl-mapcon - cl-reduce - cl-assoc cl-assoc-if cl-assoc-if-not - cl-rassoc cl-rassoc-if cl-rassoc-if-not - cl-member cl-member-if cl-member-if-not - cl-adjoin - cl-mismatch cl-search - cl-find cl-find-if cl-find-if-not - cl-position cl-position-if cl-position-if-not - cl-count cl-count-if cl-count-if-not - cl-remove cl-remove-if cl-remove-if-not - cl-remove-duplicates - cl-subst cl-subst-if cl-subst-if-not - cl-substitute cl-substitute-if cl-substitute-if-not - cl-sublis - cl-union cl-intersection cl-set-difference cl-set-exclusive-or - cl-subsetp - cl-every cl-some cl-notevery cl-notany - cl-tree-equal - - ;; Functions that mutate and return a list. - cl-delete cl-delete-if cl-delete-if-not - cl-delete-duplicates - cl-nsubst cl-nsubst-if cl-nsubst-if-not - cl-nsubstitute cl-nsubstitute-if cl-nsubstitute-if-not - cl-nunion cl-nintersection cl-nset-difference cl-nset-exclusive-or - cl-nreconc cl-nsublis - cl-merge - ;; It's safe to ignore the value of `cl-sort' and `cl-stable-sort' - ;; when used on arrays, but most calls pass lists. - cl-sort cl-stable-sort - )) - - ;;; Types and assertions. ;;;###autoload diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 7c36b398263..7017fcd5b83 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -41,7 +41,7 @@ ;; The `assert' macro from the cl package signals ;; `cl-assertion-failed' at runtime so always define it. -(define-error 'cl-assertion-failed (purecopy "Assertion failed")) +(define-error 'cl-assertion-failed "Assertion failed") (defun cl--assertion-failed (form &optional string sargs args) (if debug-on-error @@ -161,7 +161,7 @@ (car slot) (nth 1 slot) type props))) (puthash (car slot) (+ i offset) index-table) - (cl-incf i)) + (incf i)) v)) (class (cl--struct-new-class name docstring @@ -183,20 +183,7 @@ (add-to-list 'current-load-list `(define-type . ,name)) (cl--struct-register-child parent-class tag) (unless (or (eq named t) (eq tag name)) - ;; We used to use `defconst' instead of `set' but that - ;; has a side-effect of purecopying during the dump, so that the - ;; class object stored in the tag ends up being a *copy* of the - ;; one stored in the `cl--class' property! We could have fixed - ;; this needless duplication by using the purecopied object, but - ;; that then breaks down a bit later when we modify the - ;; cl-structure-class class object to close the recursion - ;; between cl-structure-object and cl-structure-class (because - ;; modifying purecopied objects is not allowed. Since this is - ;; done during dumping, we could relax this rule and allow the - ;; modification, but it's cumbersome). - ;; So in the end, it's easier to just avoid the duplication by - ;; avoiding the use of the purespace here. - (set tag class) + (eval `(defconst ,tag ',class) t) ;; In the cl-generic support, we need to be able to check ;; if a vector is a cl-struct object, without knowing its particular type. ;; So we use the (otherwise) unused function slots of the tag symbol diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index bdc35f33b3b..62cda07ac73 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -100,7 +100,7 @@ Print the contents hidden by the ellipsis to STREAM." (cl-print-object (pop object) stream) (cl-print-insert-ellipsis object t stream) (setq object nil)) - (cl-incf count)) + (incf count)) (when object (princ " . " stream) (cl-print-object object stream)))) @@ -123,7 +123,7 @@ Print the contents hidden by the ellipsis to STREAM." (while (< i limit) (unless (= i start) (princ " " stream)) (cl-print-object (aref object i) stream) - (cl-incf i)) + (incf i)) (when (< limit len) (princ " " stream) (cl-print-insert-ellipsis object limit stream)))) @@ -160,7 +160,7 @@ Print the contents hidden by the ellipsis to STREAM." 'follow-link t 'action (lambda (button) (disassemble (button-get button 'byte-code-function))) - 'help-echo (purecopy "mouse-2, RET: disassemble this function")) + 'help-echo "mouse-2, RET: disassemble this function") (defvar cl-print-compiled nil "Control how to print byte-compiled functions. @@ -298,7 +298,7 @@ into a button whose action shows the function's disassembly.") (princ (cl--slot-descriptor-name slot) stream) (princ " " stream) (cl-print-object (aref object (1+ i)) stream)) - (cl-incf i)) + (incf i)) (when (< limit len) (princ " " stream) (cl-print-insert-ellipsis object limit stream)))) @@ -369,7 +369,7 @@ primitives such as `prin1'.") (princ start-pos stream) (princ " " stream) (princ end-pos stream) (princ " " stream) (cl-print-object props stream) - (cl-incf interval-count)) + (incf interval-count)) (setq start-pos end-pos end-pos (next-property-change start-pos object len)))) (when (< start-pos len) @@ -636,10 +636,10 @@ abbreviating it with ellipses to fit within a size limit." (throw 'done (buffer-string))) (let* ((ratio (/ result limit)) (delta-level (max 1 (min (- print-level 2) ratio)))) - (cl-decf print-level delta-level) - (cl-decf print-length (* delta-length delta-level)) + (decf print-level delta-level) + (decf print-length (* delta-length delta-level)) (when cl-print-string-length - (cl-decf cl-print-string-length + (decf cl-print-string-length (ceiling cl-print-string-length 4.0)))))))))) (provide 'cl-print) diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index 7a79488f1f5..33f14df0291 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -47,7 +47,7 @@ ;; This is special-cased here so that we can compile ;; this file independent from cl-macs. -(defmacro cl--parsing-keywords (kwords other-keys &rest body) +(defmacro cl--parsing-keywords (keywords other-keys &rest body) (declare (indent 2) (debug (sexp sexp &rest form))) `(let* ,(mapcar (lambda (x) @@ -59,26 +59,22 @@ (setq mem `(and ,mem (setq cl-if ,mem) t))) (list (intern (format "cl-%s" (substring (symbol-name var) 1))) - (if (consp x) `(or ,mem ,(car (cdr x))) mem)))) - kwords) + (if (consp x) `(or ,mem ,(cadr x)) mem)))) + keywords) ,@(append (and (not (eq other-keys t)) - (list - (list 'let '((cl-keys-temp cl-keys)) - (list 'while 'cl-keys-temp - (list 'or (list 'memq '(car cl-keys-temp) - (list 'quote - (mapcar - (lambda (x) - (if (consp x) - (car x) x)) - (append kwords - other-keys)))) - '(car (cdr (memq (quote :allow-other-keys) - cl-keys))) - '(error "Bad keyword argument %s" - (car cl-keys-temp))) - '(setq cl-keys-temp (cdr (cdr cl-keys-temp))))))) + `((let ((cl-keys-temp cl-keys)) + (while cl-keys-temp + (or (memq (car cl-keys-temp) + (quote ,(mapcar + (lambda (x) + (if (consp x) + (car x) x)) + (append keywords other-keys)))) + (cadr (memq :allow-other-keys cl-keys)) + (error "Bad keyword argument %s" + (car cl-keys-temp))) + (setq cl-keys-temp (cddr cl-keys-temp)))))) body))) (defmacro cl--check-key (x) ;Expects `cl-key' in context of generated code. @@ -115,11 +111,12 @@ (defun cl-endp (x) "Return true if X is the empty list; false if it is a cons. Signal an error if X is not a list." + (declare (side-effect-free t)) (cl-check-type x list) (null x)) ;;;###autoload -(defun cl-reduce (cl-func cl-seq &rest cl-keys) +(defun cl-reduce (func seq &rest cl-keys) "Reduce two-argument FUNCTION across SEQ. \nKeywords supported: :start :end :from-end :initial-value :key @@ -144,909 +141,970 @@ the SEQ moving forward, and the order of arguments to the FUNCTION is also reversed. \n(fn FUNCTION SEQ [KEYWORD VALUE]...)" + (declare (important-return-value t)) (cl--parsing-keywords (:from-end (:start 0) :end :initial-value :key) () - (or (listp cl-seq) (setq cl-seq (append cl-seq nil))) - (setq cl-seq (cl-subseq cl-seq cl-start cl-end)) - (if cl-from-end (setq cl-seq (nreverse cl-seq))) - (let ((cl-accum (cond ((memq :initial-value cl-keys) cl-initial-value) - (cl-seq (cl--check-key (pop cl-seq))) - (t (funcall cl-func))))) + (or (listp seq) (setq seq (append seq nil))) + (setq seq (cl-subseq seq cl-start cl-end)) + (if cl-from-end (setq seq (nreverse seq))) + (let ((accum (cond ((memq :initial-value cl-keys) cl-initial-value) + (seq (cl--check-key (pop seq))) + (t (funcall func))))) (if cl-from-end - (while cl-seq - (setq cl-accum (funcall cl-func (cl--check-key (pop cl-seq)) - cl-accum))) - (while cl-seq - (setq cl-accum (funcall cl-func cl-accum - (cl--check-key (pop cl-seq)))))) - cl-accum))) + (while seq + (setq accum (funcall func (cl--check-key (pop seq)) + accum))) + (while seq + (setq accum (funcall func accum + (cl--check-key (pop seq)))))) + accum))) ;;;###autoload -(defun cl-fill (cl-seq cl-item &rest cl-keys) +(defun cl-fill (seq item &rest cl-keys) "Fill the elements of SEQ with ITEM. \nKeywords supported: :start :end \n(fn SEQ ITEM [KEYWORD VALUE]...)" (cl--parsing-keywords ((:start 0) :end) () - (if (listp cl-seq) - (let ((p (nthcdr cl-start cl-seq)) + (if (listp seq) + (let ((p (nthcdr cl-start seq)) (n (and cl-end (- cl-end cl-start)))) - (while (and p (or (null n) (>= (cl-decf n) 0))) - (setcar p cl-item) + (while (and p (or (null n) (>= (decf n) 0))) + (setcar p item) (setq p (cdr p)))) - (or cl-end (setq cl-end (length cl-seq))) - (if (and (= cl-start 0) (= cl-end (length cl-seq))) - (fillarray cl-seq cl-item) + (or cl-end (setq cl-end (length seq))) + (if (and (= cl-start 0) (= cl-end (length seq))) + (fillarray seq item) (while (< cl-start cl-end) - (aset cl-seq cl-start cl-item) + (aset seq cl-start item) (setq cl-start (1+ cl-start))))) - cl-seq)) + seq)) ;;;###autoload -(defun cl-replace (cl-seq1 cl-seq2 &rest cl-keys) +(defun cl-replace (seq1 seq2 &rest cl-keys) "Replace the elements of SEQ1 with the elements of SEQ2. SEQ1 is destructively modified, then returned. \nKeywords supported: :start1 :end1 :start2 :end2 \n(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" (cl--parsing-keywords ((:start1 0) :end1 (:start2 0) :end2) () - (if (and (eq cl-seq1 cl-seq2) (<= cl-start2 cl-start1)) + (if (and (eq seq1 seq2) (<= cl-start2 cl-start1)) (or (= cl-start1 cl-start2) - (let* ((cl-len (length cl-seq1)) - (cl-n (min (- (or cl-end1 cl-len) cl-start1) - (- (or cl-end2 cl-len) cl-start2)))) - (while (>= (setq cl-n (1- cl-n)) 0) - (setf (elt cl-seq1 (+ cl-start1 cl-n)) - (elt cl-seq2 (+ cl-start2 cl-n)))))) - (if (listp cl-seq1) - (let ((cl-p1 (nthcdr cl-start1 cl-seq1)) - (cl-n1 (and cl-end1 (- cl-end1 cl-start1)))) - (if (listp cl-seq2) - (let ((cl-p2 (nthcdr cl-start2 cl-seq2)) - (cl-n (cond ((and cl-n1 cl-end2) - (min cl-n1 (- cl-end2 cl-start2))) - ((and cl-n1 (null cl-end2)) cl-n1) - ((and (null cl-n1) cl-end2) (- cl-end2 cl-start2))))) - (while (and cl-p1 cl-p2 (or (null cl-n) (>= (cl-decf cl-n) 0))) - (setcar cl-p1 (car cl-p2)) - (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)))) - (setq cl-end2 (if (null cl-n1) - (or cl-end2 (length cl-seq2)) - (min (or cl-end2 (length cl-seq2)) - (+ cl-start2 cl-n1)))) - (while (and cl-p1 (< cl-start2 cl-end2)) - (setcar cl-p1 (aref cl-seq2 cl-start2)) - (setq cl-p1 (cdr cl-p1) cl-start2 (1+ cl-start2))))) - (setq cl-end1 (min (or cl-end1 (length cl-seq1)) - (+ cl-start1 (- (or cl-end2 (length cl-seq2)) + (let* ((len (length seq1)) + (n (min (- (or cl-end1 len) cl-start1) + (- (or cl-end2 len) cl-start2)))) + (while (>= (setq n (1- n)) 0) + (setf (elt seq1 (+ cl-start1 n)) + (elt seq2 (+ cl-start2 n)))))) + (if (listp seq1) + (let ((p1 (nthcdr cl-start1 seq1)) + (n1 (and cl-end1 (- cl-end1 cl-start1)))) + (if (listp seq2) + (let ((p2 (nthcdr cl-start2 seq2)) + (n (cond ((and n1 cl-end2) + (min n1 (- cl-end2 cl-start2))) + ((and n1 (null cl-end2)) n1) + ((and (null n1) cl-end2) (- cl-end2 cl-start2))))) + (while (and p1 p2 (or (null n) (>= (decf n) 0))) + (setcar p1 (car p2)) + (setq p1 (cdr p1) p2 (cdr p2)))) + (setq cl-end2 (if (null n1) + (or cl-end2 (length seq2)) + (min (or cl-end2 (length seq2)) + (+ cl-start2 n1)))) + (while (and p1 (< cl-start2 cl-end2)) + (setcar p1 (aref seq2 cl-start2)) + (setq p1 (cdr p1) cl-start2 (1+ cl-start2))))) + (setq cl-end1 (min (or cl-end1 (length seq1)) + (+ cl-start1 (- (or cl-end2 (length seq2)) cl-start2)))) - (if (listp cl-seq2) - (let ((cl-p2 (nthcdr cl-start2 cl-seq2))) + (if (listp seq2) + (let ((p2 (nthcdr cl-start2 seq2))) (while (< cl-start1 cl-end1) - (aset cl-seq1 cl-start1 (car cl-p2)) - (setq cl-p2 (cdr cl-p2) cl-start1 (1+ cl-start1)))) + (aset seq1 cl-start1 (car p2)) + (setq p2 (cdr p2) cl-start1 (1+ cl-start1)))) (while (< cl-start1 cl-end1) - (aset cl-seq1 cl-start1 (aref cl-seq2 cl-start2)) + (aset seq1 cl-start1 (aref seq2 cl-start2)) (setq cl-start2 (1+ cl-start2) cl-start1 (1+ cl-start1)))))) - cl-seq1)) + seq1)) ;;;###autoload -(defun cl-remove (cl-item cl-seq &rest cl-keys) +(defun cl-remove (item seq &rest cl-keys) "Remove all occurrences of ITEM in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. \nKeywords supported: :test :test-not :key :count :start :end :from-end \n(fn ITEM SEQ [KEYWORD VALUE]...)" - (cl--parsing-keywords (:test :test-not :key :if :if-not :count :from-end - (:start 0) :end) () - (let ((len (length cl-seq))) + (declare (important-return-value t)) + (cl--parsing-keywords ( :test :test-not :key :if :if-not :count :from-end + (:start 0) :end) () + (let ((len (length seq))) (if (<= (or cl-count (setq cl-count len)) 0) - cl-seq - (if (or (nlistp cl-seq) (and cl-from-end (< cl-count (/ len 2)))) - (let ((cl-i (cl--position cl-item cl-seq cl-start cl-end - cl-from-end))) - (if cl-i - (let ((cl-res (apply 'cl-delete cl-item (append cl-seq nil) - (append (if cl-from-end - (list :end (1+ cl-i)) - (list :start cl-i)) - cl-keys)))) - (if (listp cl-seq) cl-res - (if (stringp cl-seq) (concat cl-res) (vconcat cl-res)))) - cl-seq)) + seq + (if (or (nlistp seq) (and cl-from-end (< cl-count (/ len 2)))) + (let ((i (cl--position item seq cl-start cl-end + cl-from-end))) + (if i + (let ((res (apply #'cl-delete item (append seq nil) + (append (if cl-from-end + (list :end (1+ i)) + (list :start i)) + cl-keys)))) + (if (listp seq) res + (if (stringp seq) (concat res) (vconcat res)))) + seq)) (setq cl-end (- (or cl-end len) cl-start)) - (if (= cl-start 0) - (while (and cl-seq (> cl-end 0) - (cl--check-test cl-item (car cl-seq)) - (setq cl-end (1- cl-end) cl-seq (cdr cl-seq)) - (> (setq cl-count (1- cl-count)) 0)))) - (if (and (> cl-count 0) (> cl-end 0)) - (let ((cl-p (if (> cl-start 0) (nthcdr cl-start cl-seq) - (setq cl-end (1- cl-end)) (cdr cl-seq)))) - (while (and cl-p (> cl-end 0) - (not (cl--check-test cl-item (car cl-p)))) - (setq cl-p (cdr cl-p) cl-end (1- cl-end))) - (if (and cl-p (> cl-end 0)) - (nconc (cl-ldiff cl-seq cl-p) - (if (= cl-count 1) (cdr cl-p) - (and (cdr cl-p) - (apply 'cl-delete cl-item - (copy-sequence (cdr cl-p)) - :start 0 :end (1- cl-end) - :count (1- cl-count) cl-keys)))) - cl-seq)) - cl-seq)))))) + (if (= cl-start 0) + (while (and seq (> cl-end 0) + (cl--check-test item (car seq)) + (setq cl-end (1- cl-end) seq (cdr seq)) + (> (setq cl-count (1- cl-count)) 0)))) + (if (and (> cl-count 0) (> cl-end 0)) + (let ((p (if (> cl-start 0) (nthcdr cl-start seq) + (setq cl-end (1- cl-end)) (cdr seq)))) + (while (and p (> cl-end 0) + (not (cl--check-test item (car p)))) + (setq p (cdr p) cl-end (1- cl-end))) + (if (and p (> cl-end 0)) + (nconc (cl-ldiff seq p) + (if (= cl-count 1) (cdr p) + (and (cdr p) + (apply #'cl-delete item + (copy-sequence (cdr p)) + :start 0 :end (1- cl-end) + :count (1- cl-count) cl-keys)))) + seq)) + seq)))))) ;;;###autoload -(defun cl-remove-if (cl-pred cl-list &rest cl-keys) +(defun cl-remove-if (pred list &rest cl-keys) "Remove all items satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. \nKeywords supported: :key :count :start :end :from-end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'cl-remove nil cl-list :if cl-pred cl-keys)) + (declare (important-return-value t)) + (apply #'cl-remove nil list :if pred cl-keys)) ;;;###autoload -(defun cl-remove-if-not (cl-pred cl-list &rest cl-keys) +(defun cl-remove-if-not (pred list &rest cl-keys) "Remove all items not satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. \nKeywords supported: :key :count :start :end :from-end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'cl-remove nil cl-list :if-not cl-pred cl-keys)) + (declare (important-return-value t)) + (apply #'cl-remove nil list :if-not pred cl-keys)) ;;;###autoload -(defun cl-delete (cl-item cl-seq &rest cl-keys) +(defun cl-delete (item seq &rest cl-keys) "Remove all occurrences of ITEM in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. \nKeywords supported: :test :test-not :key :count :start :end :from-end \n(fn ITEM SEQ [KEYWORD VALUE]...)" - (cl--parsing-keywords (:test :test-not :key :if :if-not :count :from-end - (:start 0) :end) () - (let ((len (length cl-seq))) + (declare (important-return-value t)) + (cl--parsing-keywords ( :test :test-not :key :if :if-not :count :from-end + (:start 0) :end) () + (let ((len (length seq))) (if (<= (or cl-count (setq cl-count len)) 0) - cl-seq - (if (listp cl-seq) - (if (and cl-from-end (< cl-count (/ len 2))) - (let (cl-i) - (while (and (>= (setq cl-count (1- cl-count)) 0) - (setq cl-i (cl--position cl-item cl-seq cl-start - cl-end cl-from-end))) - (if (= cl-i 0) (setq cl-seq (cdr cl-seq)) - (let ((cl-tail (nthcdr (1- cl-i) cl-seq))) - (setcdr cl-tail (cdr (cdr cl-tail))))) - (setq cl-end cl-i)) - cl-seq) - (setq cl-end (- (or cl-end len) cl-start)) - (if (= cl-start 0) - (progn - (while (and cl-seq - (> cl-end 0) - (cl--check-test cl-item (car cl-seq)) - (setq cl-end (1- cl-end) cl-seq (cdr cl-seq)) - (> (setq cl-count (1- cl-count)) 0))) - (setq cl-end (1- cl-end))) - (setq cl-start (1- cl-start))) - (if (and (> cl-count 0) (> cl-end 0)) - (let ((cl-p (nthcdr cl-start cl-seq))) - (while (and (cdr cl-p) (> cl-end 0)) - (if (cl--check-test cl-item (car (cdr cl-p))) - (progn - (setcdr cl-p (cdr (cdr cl-p))) - (if (= (setq cl-count (1- cl-count)) 0) - (setq cl-end 1))) - (setq cl-p (cdr cl-p))) - (setq cl-end (1- cl-end))))) - cl-seq) - (apply 'cl-remove cl-item cl-seq cl-keys)))))) + seq + (if (listp seq) + (if (and cl-from-end (< cl-count (/ len 2))) + (let (i) + (while (and (>= (setq cl-count (1- cl-count)) 0) + (setq i (cl--position item seq cl-start + cl-end cl-from-end))) + (if (= i 0) (setq seq (cdr seq)) + (let ((tail (nthcdr (1- i) seq))) + (setcdr tail (cdr (cdr tail))))) + (setq cl-end i)) + seq) + (setq cl-end (- (or cl-end len) cl-start)) + (if (= cl-start 0) + (progn + (while (and seq + (> cl-end 0) + (cl--check-test item (car seq)) + (setq cl-end (1- cl-end) seq (cdr seq)) + (> (setq cl-count (1- cl-count)) 0))) + (setq cl-end (1- cl-end))) + (setq cl-start (1- cl-start))) + (if (and (> cl-count 0) (> cl-end 0)) + (let ((p (nthcdr cl-start seq))) + (while (and (cdr p) (> cl-end 0)) + (if (cl--check-test item (car (cdr p))) + (progn + (setcdr p (cdr (cdr p))) + (if (= (setq cl-count (1- cl-count)) 0) + (setq cl-end 1))) + (setq p (cdr p))) + (setq cl-end (1- cl-end))))) + seq) + (apply #'cl-remove item seq cl-keys)))))) ;;;###autoload -(defun cl-delete-if (cl-pred cl-list &rest cl-keys) +(defun cl-delete-if (pred list &rest cl-keys) "Remove all items satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. \nKeywords supported: :key :count :start :end :from-end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'cl-delete nil cl-list :if cl-pred cl-keys)) + (declare (important-return-value t)) + (apply #'cl-delete nil list :if pred cl-keys)) ;;;###autoload -(defun cl-delete-if-not (cl-pred cl-list &rest cl-keys) +(defun cl-delete-if-not (pred list &rest cl-keys) "Remove all items not satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. \nKeywords supported: :key :count :start :end :from-end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'cl-delete nil cl-list :if-not cl-pred cl-keys)) + (declare (important-return-value t)) + (apply #'cl-delete nil list :if-not pred cl-keys)) ;;;###autoload -(defun cl-remove-duplicates (cl-seq &rest cl-keys) +(defun cl-remove-duplicates (seq &rest cl-keys) "Return a copy of SEQ with all duplicate elements removed. \nKeywords supported: :test :test-not :key :start :end :from-end \n(fn SEQ [KEYWORD VALUE]...)" - (cl--delete-duplicates cl-seq cl-keys t)) + (declare (important-return-value t)) + (cl--delete-duplicates seq cl-keys t)) ;;;###autoload -(defun cl-delete-duplicates (cl-seq &rest cl-keys) +(defun cl-delete-duplicates (seq &rest cl-keys) "Remove all duplicate elements from SEQ (destructively). \nKeywords supported: :test :test-not :key :start :end :from-end \n(fn SEQ [KEYWORD VALUE]...)" - (cl--delete-duplicates cl-seq cl-keys nil)) + (declare (important-return-value t)) + (cl--delete-duplicates seq cl-keys nil)) -(defun cl--delete-duplicates (cl-seq cl-keys cl-copy) - (if (listp cl-seq) +(defun cl--delete-duplicates (seq cl-keys copy) + (if (listp seq) (cl--parsing-keywords ;; We need to parse :if, otherwise `cl-if' is unbound. (:test :test-not :key (:start 0) :end :from-end :if) () (if cl-from-end - (let ((cl-p (nthcdr cl-start cl-seq)) cl-i) - (setq cl-end (- (or cl-end (length cl-seq)) cl-start)) + (let ((p (nthcdr cl-start seq)) i) + (setq cl-end (- (or cl-end (length seq)) cl-start)) (while (> cl-end 1) - (setq cl-i 0) - (while (setq cl-i (cl--position (cl--check-key (car cl-p)) - (cdr cl-p) cl-i (1- cl-end))) - (if cl-copy (setq cl-seq (copy-sequence cl-seq) - cl-p (nthcdr cl-start cl-seq) cl-copy nil)) - (let ((cl-tail (nthcdr cl-i cl-p))) - (setcdr cl-tail (cdr (cdr cl-tail)))) + (setq i 0) + (while (setq i (cl--position (cl--check-key (car p)) + (cdr p) i (1- cl-end))) + (if copy (setq seq (copy-sequence seq) + p (nthcdr cl-start seq) copy nil)) + (let ((tail (nthcdr i p))) + (setcdr tail (cdr (cdr tail)))) (setq cl-end (1- cl-end))) - (setq cl-p (cdr cl-p) cl-end (1- cl-end) + (setq p (cdr p) cl-end (1- cl-end) cl-start (1+ cl-start))) - cl-seq) - (setq cl-end (- (or cl-end (length cl-seq)) cl-start)) - (while (and (cdr cl-seq) (= cl-start 0) (> cl-end 1) - (cl--position (cl--check-key (car cl-seq)) - (cdr cl-seq) 0 (1- cl-end))) - (setq cl-seq (cdr cl-seq) cl-end (1- cl-end))) - (let ((cl-p (if (> cl-start 0) (nthcdr (1- cl-start) cl-seq) - (setq cl-end (1- cl-end) cl-start 1) cl-seq))) - (while (and (cdr (cdr cl-p)) (> cl-end 1)) - (if (cl--position (cl--check-key (car (cdr cl-p))) - (cdr (cdr cl-p)) 0 (1- cl-end)) + seq) + (setq cl-end (- (or cl-end (length seq)) cl-start)) + (while (and (cdr seq) (= cl-start 0) (> cl-end 1) + (cl--position (cl--check-key (car seq)) + (cdr seq) 0 (1- cl-end))) + (setq seq (cdr seq) cl-end (1- cl-end))) + (let ((p (if (> cl-start 0) (nthcdr (1- cl-start) seq) + (setq cl-end (1- cl-end) cl-start 1) seq))) + (while (and (cdr (cdr p)) (> cl-end 1)) + (if (cl--position (cl--check-key (car (cdr p))) + (cdr (cdr p)) 0 (1- cl-end)) (progn - (if cl-copy (setq cl-seq (copy-sequence cl-seq) - cl-p (nthcdr (1- cl-start) cl-seq) - cl-copy nil)) - (setcdr cl-p (cdr (cdr cl-p)))) - (setq cl-p (cdr cl-p))) + (if copy (setq seq (copy-sequence seq) + p (nthcdr (1- cl-start) seq) + copy nil)) + (setcdr p (cdr (cdr p)))) + (setq p (cdr p))) (setq cl-end (1- cl-end) cl-start (1+ cl-start))) - cl-seq))) - (let ((cl-res (cl--delete-duplicates (append cl-seq nil) cl-keys nil))) - (if (stringp cl-seq) (concat cl-res) (vconcat cl-res))))) + seq))) + (let ((res (cl--delete-duplicates (append seq nil) cl-keys nil))) + (if (stringp seq) (concat res) (vconcat res))))) ;;;###autoload -(defun cl-substitute (cl-new cl-old cl-seq &rest cl-keys) +(defun cl-substitute (new old seq &rest cl-keys) "Substitute NEW for OLD in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. \nKeywords supported: :test :test-not :key :count :start :end :from-end \n(fn NEW OLD SEQ [KEYWORD VALUE]...)" - (cl--parsing-keywords (:test :test-not :key :if :if-not :count - (:start 0) :end :from-end) () - (if (or (eq cl-old cl-new) + (declare (important-return-value t)) + (cl--parsing-keywords ( :test :test-not :key :if :if-not :count + (:start 0) :end :from-end) () + (if (or (eq old new) (<= (or cl-count (setq cl-from-end nil - cl-count (length cl-seq))) 0)) - cl-seq - (let ((cl-i (cl--position cl-old cl-seq cl-start cl-end))) - (if (not cl-i) - cl-seq - (setq cl-seq (copy-sequence cl-seq)) + cl-count (length seq))) 0)) + seq + (let ((i (cl--position old seq cl-start cl-end))) + (if (not i) + seq + (setq seq (copy-sequence seq)) (unless cl-from-end - (setf (elt cl-seq cl-i) cl-new) - (cl-incf cl-i) - (cl-decf cl-count)) - (apply 'cl-nsubstitute cl-new cl-old cl-seq :count cl-count - :start cl-i cl-keys)))))) + (setf (elt seq i) new) + (incf i) + (decf cl-count)) + (apply #'cl-nsubstitute new old seq :count cl-count + :start i cl-keys)))))) ;;;###autoload -(defun cl-substitute-if (cl-new cl-pred cl-list &rest cl-keys) +(defun cl-substitute-if (new pred seq &rest cl-keys) "Substitute NEW for all items satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. \nKeywords supported: :key :count :start :end :from-end \n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'cl-substitute cl-new nil cl-list :if cl-pred cl-keys)) + (declare (important-return-value t)) + (apply #'cl-substitute new nil seq :if pred cl-keys)) ;;;###autoload -(defun cl-substitute-if-not (cl-new cl-pred cl-list &rest cl-keys) +(defun cl-substitute-if-not (new pred seq &rest cl-keys) "Substitute NEW for all items not satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. \nKeywords supported: :key :count :start :end :from-end \n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'cl-substitute cl-new nil cl-list :if-not cl-pred cl-keys)) + (declare (important-return-value t)) + (apply #'cl-substitute new nil seq :if-not pred cl-keys)) ;;;###autoload -(defun cl-nsubstitute (cl-new cl-old seq &rest cl-keys) +(defun cl-nsubstitute (new old seq &rest cl-keys) "Substitute NEW for OLD in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. \nKeywords supported: :test :test-not :key :count :start :end :from-end \n(fn NEW OLD SEQ [KEYWORD VALUE]...)" - (cl--parsing-keywords (:test :test-not :key :if :if-not :count - (:start 0) :end :from-end) () - (let* ((cl-seq (if (stringp seq) (string-to-vector seq) seq)) - (len (length cl-seq))) - (or (eq cl-old cl-new) (<= (or cl-count (setq cl-count len)) 0) - (if (and (listp cl-seq) (or (not cl-from-end) (> cl-count (/ len 2)))) - (let ((cl-p (nthcdr cl-start cl-seq))) - (setq cl-end (- (or cl-end len) cl-start)) - (while (and cl-p (> cl-end 0) (> cl-count 0)) - (if (cl--check-test cl-old (car cl-p)) - (progn - (setcar cl-p cl-new) - (setq cl-count (1- cl-count)))) - (setq cl-p (cdr cl-p) cl-end (1- cl-end)))) + (declare (important-return-value t)) + (cl--parsing-keywords ( :test :test-not :key :if :if-not :count + (:start 0) :end :from-end) () + (let* ((seq (if (stringp seq) (string-to-vector seq) seq)) + (len (length seq))) + (or (eq old new) (<= (or cl-count (setq cl-count len)) 0) + (if (and (listp seq) (or (not cl-from-end) (> cl-count (/ len 2)))) + (let ((p (nthcdr cl-start seq))) + (setq cl-end (- (or cl-end len) cl-start)) + (while (and p (> cl-end 0) (> cl-count 0)) + (if (cl--check-test old (car p)) + (progn + (setcar p new) + (setq cl-count (1- cl-count)))) + (setq p (cdr p) cl-end (1- cl-end)))) (or cl-end (setq cl-end len)) - (if cl-from-end - (while (and (< cl-start cl-end) (> cl-count 0)) - (setq cl-end (1- cl-end)) - (if (cl--check-test cl-old (elt cl-seq cl-end)) - (progn - (setf (elt cl-seq cl-end) cl-new) - (setq cl-count (1- cl-count))))) - (while (and (< cl-start cl-end) (> cl-count 0)) - (if (cl--check-test cl-old (aref cl-seq cl-start)) - (progn - (aset cl-seq cl-start cl-new) - (setq cl-count (1- cl-count)))) - (setq cl-start (1+ cl-start)))))) - (if (stringp seq) (concat cl-seq) cl-seq)))) + (if cl-from-end + (while (and (< cl-start cl-end) (> cl-count 0)) + (setq cl-end (1- cl-end)) + (if (cl--check-test old (elt seq cl-end)) + (progn + (setf (elt seq cl-end) new) + (setq cl-count (1- cl-count))))) + (while (and (< cl-start cl-end) (> cl-count 0)) + (if (cl--check-test old (aref seq cl-start)) + (progn + (aset seq cl-start new) + (setq cl-count (1- cl-count)))) + (setq cl-start (1+ cl-start)))))) + (if (stringp seq) (concat seq) seq)))) ;;;###autoload -(defun cl-nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys) +(defun cl-nsubstitute-if (new pred list &rest cl-keys) "Substitute NEW for all items satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. \nKeywords supported: :key :count :start :end :from-end \n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'cl-nsubstitute cl-new nil cl-list :if cl-pred cl-keys)) + (declare (important-return-value t)) + (apply #'cl-nsubstitute new nil list :if pred cl-keys)) ;;;###autoload -(defun cl-nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys) +(defun cl-nsubstitute-if-not (new pred list &rest cl-keys) "Substitute NEW for all items not satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. \nKeywords supported: :key :count :start :end :from-end \n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'cl-nsubstitute cl-new nil cl-list :if-not cl-pred cl-keys)) + (declare (important-return-value t)) + (apply #'cl-nsubstitute new nil list :if-not pred cl-keys)) ;;;###autoload -(defun cl-find (cl-item cl-seq &rest cl-keys) +(defun cl-find (item seq &rest cl-keys) "Find the first occurrence of ITEM in SEQ. Return the matching ITEM, or nil if not found. \nKeywords supported: :test :test-not :key :start :end :from-end \n(fn ITEM SEQ [KEYWORD VALUE]...)" - (let ((cl-pos (apply 'cl-position cl-item cl-seq cl-keys))) - (and cl-pos (elt cl-seq cl-pos)))) + (declare (important-return-value t)) + (let ((pos (apply #'cl-position item seq cl-keys))) + (and pos (elt seq pos)))) ;;;###autoload -(defun cl-find-if (cl-pred cl-list &rest cl-keys) +(defun cl-find-if (pred list &rest cl-keys) "Find the first item satisfying PREDICATE in SEQ. Return the matching item, or nil if not found. \nKeywords supported: :key :start :end :from-end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'cl-find nil cl-list :if cl-pred cl-keys)) + (declare (important-return-value t)) + (apply #'cl-find nil list :if pred cl-keys)) ;;;###autoload -(defun cl-find-if-not (cl-pred cl-list &rest cl-keys) +(defun cl-find-if-not (pred list &rest cl-keys) "Find the first item not satisfying PREDICATE in SEQ. Return the matching item, or nil if not found. \nKeywords supported: :key :start :end :from-end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'cl-find nil cl-list :if-not cl-pred cl-keys)) + (declare (important-return-value t)) + (apply #'cl-find nil list :if-not pred cl-keys)) ;;;###autoload -(defun cl-position (cl-item cl-seq &rest cl-keys) +(defun cl-position (item seq &rest cl-keys) "Find the first occurrence of ITEM in SEQ. Return the index of the matching item, or nil if not found. \nKeywords supported: :test :test-not :key :start :end :from-end \n(fn ITEM SEQ [KEYWORD VALUE]...)" - (cl--parsing-keywords (:test :test-not :key :if :if-not - (:start 0) :end :from-end) () - (cl--position cl-item cl-seq cl-start cl-end cl-from-end))) - -(defun cl--position (cl-item cl-seq cl-start &optional cl-end cl-from-end) - (if (listp cl-seq) - (let ((cl-p (nthcdr cl-start cl-seq)) - cl-res) - (while (and cl-p (or (null cl-end) (< cl-start cl-end)) (or (null cl-res) cl-from-end)) - (if (cl--check-test cl-item (car cl-p)) - (setq cl-res cl-start)) - (setq cl-p (cdr cl-p) cl-start (1+ cl-start))) - cl-res) - (or cl-end (setq cl-end (length cl-seq))) - (if cl-from-end + (declare (important-return-value t)) + (cl--parsing-keywords ( :test :test-not :key :if :if-not + (:start 0) :end :from-end) () + (cl--position item seq cl-start cl-end cl-from-end))) + +(defun cl--position (item seq start &optional end from-end) + (if (listp seq) + (let ((p (nthcdr start seq)) + res) + (while (and p (or (null end) (< start end)) (or (null res) from-end)) + (if (cl--check-test item (car p)) + (setq res start)) + (setq p (cdr p) start (1+ start))) + res) + (or end (setq end (length seq))) + (if from-end (progn - (while (and (>= (setq cl-end (1- cl-end)) cl-start) - (not (cl--check-test cl-item (aref cl-seq cl-end))))) - (and (>= cl-end cl-start) cl-end)) - (while (and (< cl-start cl-end) - (not (cl--check-test cl-item (aref cl-seq cl-start)))) - (setq cl-start (1+ cl-start))) - (and (< cl-start cl-end) cl-start)))) + (while (and (>= (setq end (1- end)) start) + (not (cl--check-test item (aref seq end))))) + (and (>= end start) end)) + (while (and (< start end) + (not (cl--check-test item (aref seq start)))) + (setq start (1+ start))) + (and (< start end) start)))) ;;;###autoload -(defun cl-position-if (cl-pred cl-list &rest cl-keys) +(defun cl-position-if (pred list &rest cl-keys) "Find the first item satisfying PREDICATE in SEQ. Return the index of the matching item, or nil if not found. \nKeywords supported: :key :start :end :from-end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'cl-position nil cl-list :if cl-pred cl-keys)) + (declare (important-return-value t)) + (apply #'cl-position nil list :if pred cl-keys)) ;;;###autoload -(defun cl-position-if-not (cl-pred cl-list &rest cl-keys) +(defun cl-position-if-not (pred list &rest cl-keys) "Find the first item not satisfying PREDICATE in SEQ. Return the index of the matching item, or nil if not found. \nKeywords supported: :key :start :end :from-end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'cl-position nil cl-list :if-not cl-pred cl-keys)) + (declare (important-return-value t)) + (apply #'cl-position nil list :if-not pred cl-keys)) ;;;###autoload -(defun cl-count (cl-item cl-seq &rest cl-keys) +(defun cl-count (item seq &rest cl-keys) "Count the number of occurrences of ITEM in SEQ. \nKeywords supported: :test :test-not :key :start :end \n(fn ITEM SEQ [KEYWORD VALUE]...)" + (declare (important-return-value t)) (cl--parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end) () - (let ((cl-count 0) cl-x) - (or cl-end (setq cl-end (length cl-seq))) - (if (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq))) + (let ((count 0) x) + (or cl-end (setq cl-end (length seq))) + (if (consp seq) (setq seq (nthcdr cl-start seq))) (while (< cl-start cl-end) - (setq cl-x (if (consp cl-seq) (pop cl-seq) (aref cl-seq cl-start))) - (if (cl--check-test cl-item cl-x) (setq cl-count (1+ cl-count))) + (setq x (if (consp seq) (pop seq) (aref seq cl-start))) + (if (cl--check-test item x) (incf count)) (setq cl-start (1+ cl-start))) - cl-count))) + count))) ;;;###autoload -(defun cl-count-if (cl-pred cl-list &rest cl-keys) +(defun cl-count-if (pred list &rest cl-keys) "Count the number of items satisfying PREDICATE in SEQ. \nKeywords supported: :key :start :end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'cl-count nil cl-list :if cl-pred cl-keys)) + (declare (important-return-value t)) + (apply #'cl-count nil list :if pred cl-keys)) ;;;###autoload -(defun cl-count-if-not (cl-pred cl-list &rest cl-keys) +(defun cl-count-if-not (pred list &rest cl-keys) "Count the number of items not satisfying PREDICATE in SEQ. \nKeywords supported: :key :start :end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'cl-count nil cl-list :if-not cl-pred cl-keys)) + (declare (important-return-value t)) + (apply #'cl-count nil list :if-not pred cl-keys)) ;;;###autoload -(defun cl-mismatch (cl-seq1 cl-seq2 &rest cl-keys) +(defun cl-mismatch (seq1 seq2 &rest cl-keys) "Compare SEQ1 with SEQ2, return index of first mismatching element. Return nil if the sequences match. If one sequence is a prefix of the other, the return value indicates the end of the shorter sequence. \nKeywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end \n(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" - (cl--parsing-keywords (:test :test-not :key :from-end - (:start1 0) :end1 (:start2 0) :end2) () - (or cl-end1 (setq cl-end1 (length cl-seq1))) - (or cl-end2 (setq cl-end2 (length cl-seq2))) + (declare (important-return-value t)) + (cl--parsing-keywords ( :test :test-not :key :from-end + (:start1 0) :end1 (:start2 0) :end2) () + (or cl-end1 (setq cl-end1 (length seq1))) + (or cl-end2 (setq cl-end2 (length seq2))) (if cl-from-end (progn (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2) - (cl--check-match (elt cl-seq1 (1- cl-end1)) - (elt cl-seq2 (1- cl-end2)))) + (cl--check-match (elt seq1 (1- cl-end1)) + (elt seq2 (1- cl-end2)))) (setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2))) (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2)) (1- cl-end1))) - (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1))) - (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2)))) + (let ((p1 (and (listp seq1) (nthcdr cl-start1 seq1))) + (p2 (and (listp seq2) (nthcdr cl-start2 seq2)))) (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2) - (cl--check-match (if cl-p1 (car cl-p1) - (aref cl-seq1 cl-start1)) - (if cl-p2 (car cl-p2) - (aref cl-seq2 cl-start2)))) - (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2) + (cl--check-match (if p1 (car p1) + (aref seq1 cl-start1)) + (if p2 (car p2) + (aref seq2 cl-start2)))) + (setq p1 (cdr p1) p2 (cdr p2) cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2))) (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2)) cl-start1))))) ;;;###autoload -(defun cl-search (cl-seq1 cl-seq2 &rest cl-keys) +(defun cl-search (seq1 seq2 &rest cl-keys) "Search for SEQ1 as a subsequence of SEQ2. Return the index of the leftmost element of the first match found; return nil if there are no matches. \nKeywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end \n(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" - (cl--parsing-keywords (:test :test-not :key :from-end - (:start1 0) :end1 (:start2 0) :end2) () - (or cl-end1 (setq cl-end1 (length cl-seq1))) - (or cl-end2 (setq cl-end2 (length cl-seq2))) + (declare (important-return-value t)) + (cl--parsing-keywords ( :test :test-not :key :from-end + (:start1 0) :end1 (:start2 0) :end2) () + (or cl-end1 (setq cl-end1 (length seq1))) + (or cl-end2 (setq cl-end2 (length seq2))) (if (>= cl-start1 cl-end1) (if cl-from-end cl-end2 cl-start2) - (let* ((cl-len (- cl-end1 cl-start1)) - (cl-first (cl--check-key (elt cl-seq1 cl-start1))) - (cl-if nil) cl-pos) - (setq cl-end2 (- cl-end2 (1- cl-len))) + (let* ((len (- cl-end1 cl-start1)) + (first (cl--check-key (elt seq1 cl-start1))) + (cl-if nil) pos) + (setq cl-end2 (- cl-end2 (1- len))) (while (and (< cl-start2 cl-end2) - (setq cl-pos (cl--position cl-first cl-seq2 - cl-start2 cl-end2 cl-from-end)) - (apply 'cl-mismatch cl-seq1 cl-seq2 + (setq pos (cl--position first seq2 + cl-start2 cl-end2 cl-from-end)) + (apply #'cl-mismatch seq1 seq2 :start1 (1+ cl-start1) :end1 cl-end1 - :start2 (1+ cl-pos) :end2 (+ cl-pos cl-len) + :start2 (1+ pos) :end2 (+ pos len) :from-end nil cl-keys)) - (if cl-from-end (setq cl-end2 cl-pos) (setq cl-start2 (1+ cl-pos)))) - (and (< cl-start2 cl-end2) cl-pos))))) + (if cl-from-end (setq cl-end2 pos) (setq cl-start2 (1+ pos)))) + (and (< cl-start2 cl-end2) pos))))) ;;;###autoload -(defun cl-sort (cl-seq cl-pred &rest cl-keys) +(defun cl-sort (seq pred &rest cl-keys) "Sort the argument SEQ according to PREDICATE. This is a destructive function; it reuses the storage of SEQ if possible. \nKeywords supported: :key \n(fn SEQ PREDICATE [KEYWORD VALUE]...)" - (if (nlistp cl-seq) - (if (stringp cl-seq) - (concat (apply #'cl-sort (vconcat cl-seq) cl-pred cl-keys)) - (cl-replace cl-seq - (apply #'cl-sort (append cl-seq nil) cl-pred cl-keys))) + ;; It's safe to ignore the return value when used on arrays, + ;; but most calls pass lists. + (declare (important-return-value t)) + (if (nlistp seq) + (if (stringp seq) + (concat (apply #'cl-sort (vconcat seq) pred cl-keys)) + (cl-replace seq + (apply #'cl-sort (append seq nil) pred cl-keys))) (cl--parsing-keywords (:key) () (if (memq cl-key '(nil identity)) - (sort cl-seq cl-pred) - (sort cl-seq (lambda (cl-x cl-y) - (funcall cl-pred (funcall cl-key cl-x) - (funcall cl-key cl-y)))))))) + (sort seq pred) + (sort seq (lambda (x y) + (funcall pred (funcall cl-key x) + (funcall cl-key y)))))))) ;;;###autoload -(defun cl-stable-sort (cl-seq cl-pred &rest cl-keys) +(defun cl-stable-sort (seq pred &rest cl-keys) "Sort the argument SEQ stably according to PREDICATE. This is a destructive function; it reuses the storage of SEQ if possible. \nKeywords supported: :key \n(fn SEQ PREDICATE [KEYWORD VALUE]...)" - (apply 'cl-sort cl-seq cl-pred cl-keys)) + ;; It's safe to ignore the return value when used on arrays, + ;; but most calls pass lists. + (declare (important-return-value t)) + (apply #'cl-sort seq pred cl-keys)) ;;;###autoload -(defun cl-merge (cl-type cl-seq1 cl-seq2 cl-pred &rest cl-keys) +(defun cl-merge (type seq1 seq2 pred &rest cl-keys) "Destructively merge the two sequences to produce a new sequence. TYPE is the sequence type to return, SEQ1 and SEQ2 are the two argument sequences, and PREDICATE is a `less-than' predicate on the elements. \nKeywords supported: :key \n(fn TYPE SEQ1 SEQ2 PREDICATE [KEYWORD VALUE]...)" - (or (listp cl-seq1) (setq cl-seq1 (append cl-seq1 nil))) - (or (listp cl-seq2) (setq cl-seq2 (append cl-seq2 nil))) + (declare (important-return-value t)) + (or (listp seq1) (setq seq1 (append seq1 nil))) + (or (listp seq2) (setq seq2 (append seq2 nil))) (cl--parsing-keywords (:key) () - (let ((cl-res nil)) - (while (and cl-seq1 cl-seq2) - (if (funcall cl-pred (cl--check-key (car cl-seq2)) - (cl--check-key (car cl-seq1))) - (push (pop cl-seq2) cl-res) - (push (pop cl-seq1) cl-res))) - (cl-coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type)))) + (let ((res nil)) + (while (and seq1 seq2) + (if (funcall pred (cl--check-key (car seq2)) + (cl--check-key (car seq1))) + (push (pop seq2) res) + (push (pop seq1) res))) + (cl-coerce (nconc (nreverse res) seq1 seq2) type)))) ;;;###autoload -(defun cl-member (cl-item cl-list &rest cl-keys) +(defun cl-member (item list &rest cl-keys) "Find the first occurrence of ITEM in LIST. Return the sublist of LIST whose car is ITEM. \nKeywords supported: :test :test-not :key \n(fn ITEM LIST [KEYWORD VALUE]...)" - (declare (compiler-macro cl--compiler-macro-member)) + (declare (important-return-value t) + (compiler-macro cl--compiler-macro-member)) (if cl-keys (cl--parsing-keywords (:test :test-not :key :if :if-not) () - (while (and cl-list (not (cl--check-test cl-item (car cl-list)))) - (setq cl-list (cdr cl-list))) - cl-list) - (memql cl-item cl-list))) + (while (and list (not (cl--check-test item (car list)))) + (setq list (cdr list))) + list) + (memql item list))) (autoload 'cl--compiler-macro-member "cl-macs") ;;;###autoload -(defun cl-member-if (cl-pred cl-list &rest cl-keys) +(defun cl-member-if (pred list &rest cl-keys) "Find the first item satisfying PREDICATE in LIST. Return the sublist of LIST whose car matches. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" - (apply 'cl-member nil cl-list :if cl-pred cl-keys)) + (declare (important-return-value t)) + (apply #'cl-member nil list :if pred cl-keys)) ;;;###autoload -(defun cl-member-if-not (cl-pred cl-list &rest cl-keys) +(defun cl-member-if-not (pred list &rest cl-keys) "Find the first item not satisfying PREDICATE in LIST. Return the sublist of LIST whose car matches. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" - (apply 'cl-member nil cl-list :if-not cl-pred cl-keys)) + (declare (important-return-value t)) + (apply #'cl-member nil list :if-not pred cl-keys)) ;;;###autoload -(defun cl--adjoin (cl-item cl-list &rest cl-keys) +(defun cl--adjoin (item list &rest cl-keys) (if (cl--parsing-keywords (:key) t - (apply 'cl-member (cl--check-key cl-item) cl-list cl-keys)) - cl-list - (cons cl-item cl-list))) + (apply #'cl-member (cl--check-key item) list cl-keys)) + list + (cons item list))) ;;;###autoload -(defun cl-assoc (cl-item cl-alist &rest cl-keys) +(defun cl-assoc (item alist &rest cl-keys) "Find the first item whose car matches ITEM in LIST. \nKeywords supported: :test :test-not :key \n(fn ITEM LIST [KEYWORD VALUE]...)" - (declare (compiler-macro cl--compiler-macro-assoc)) + (declare (important-return-value t) + (compiler-macro cl--compiler-macro-assoc)) (if cl-keys (cl--parsing-keywords (:test :test-not :key :if :if-not) () - (while (and cl-alist - (or (not (consp (car cl-alist))) - (not (cl--check-test cl-item (car (car cl-alist)))))) - (setq cl-alist (cdr cl-alist))) - (and cl-alist (car cl-alist))) - (if (and (numberp cl-item) (not (fixnump cl-item))) - (assoc cl-item cl-alist) - (assq cl-item cl-alist)))) + (while (and alist + (or (not (consp (car alist))) + (not (cl--check-test item (car (car alist)))))) + (setq alist (cdr alist))) + (and alist (car alist))) + (if (and (numberp item) (not (fixnump item))) + (assoc item alist) + (assq item alist)))) (autoload 'cl--compiler-macro-assoc "cl-macs") ;;;###autoload -(defun cl-assoc-if (cl-pred cl-list &rest cl-keys) +(defun cl-assoc-if (pred list &rest cl-keys) "Find the first item whose car satisfies PREDICATE in LIST. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" - (apply 'cl-assoc nil cl-list :if cl-pred cl-keys)) + (declare (important-return-value t)) + (apply #'cl-assoc nil list :if pred cl-keys)) ;;;###autoload -(defun cl-assoc-if-not (cl-pred cl-list &rest cl-keys) +(defun cl-assoc-if-not (pred list &rest cl-keys) "Find the first item whose car does not satisfy PREDICATE in LIST. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" - (apply 'cl-assoc nil cl-list :if-not cl-pred cl-keys)) + (declare (important-return-value t)) + (apply #'cl-assoc nil list :if-not pred cl-keys)) ;;;###autoload -(defun cl-rassoc (cl-item cl-alist &rest cl-keys) +(defun cl-rassoc (item alist &rest cl-keys) "Find the first item whose cdr matches ITEM in LIST. \nKeywords supported: :test :test-not :key \n(fn ITEM LIST [KEYWORD VALUE]...)" - (if (or cl-keys (numberp cl-item)) + (declare (important-return-value t)) + (if (or cl-keys (numberp item)) (cl--parsing-keywords (:test :test-not :key :if :if-not) () - (while (and cl-alist - (or (not (consp (car cl-alist))) - (not (cl--check-test cl-item (cdr (car cl-alist)))))) - (setq cl-alist (cdr cl-alist))) - (and cl-alist (car cl-alist))) - (rassq cl-item cl-alist))) + (while (and alist + (or (not (consp (car alist))) + (not (cl--check-test item (cdr (car alist)))))) + (setq alist (cdr alist))) + (and alist (car alist))) + (rassq item alist))) ;;;###autoload -(defun cl-rassoc-if (cl-pred cl-list &rest cl-keys) +(defun cl-rassoc-if (pred list &rest cl-keys) "Find the first item whose cdr satisfies PREDICATE in LIST. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" - (apply 'cl-rassoc nil cl-list :if cl-pred cl-keys)) + (declare (important-return-value t)) + (apply #'cl-rassoc nil list :if pred cl-keys)) ;;;###autoload -(defun cl-rassoc-if-not (cl-pred cl-list &rest cl-keys) +(defun cl-rassoc-if-not (pred list &rest cl-keys) "Find the first item whose cdr does not satisfy PREDICATE in LIST. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" - (apply 'cl-rassoc nil cl-list :if-not cl-pred cl-keys)) + (declare (important-return-value t)) + (apply #'cl-rassoc nil list :if-not pred cl-keys)) ;;;###autoload -(defun cl-union (cl-list1 cl-list2 &rest cl-keys) +(defun cl-union (list1 list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-union operation. The resulting list contains all items that appear in either LIST1 or LIST2. This is a non-destructive function; it makes a copy of the data if necessary to avoid corrupting the original LIST1 and LIST2. \nKeywords supported: :test :test-not :key \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" - (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) - ((and (not cl-keys) (equal cl-list1 cl-list2)) cl-list1) + (declare (important-return-value t)) + (cond ((null list1) list2) ((null list2) list1) + ((and (not cl-keys) (equal list1 list2)) list1) (t - (or (>= (length cl-list1) (length cl-list2)) - (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1)))) - (while cl-list2 - (if (or cl-keys (numberp (car cl-list2))) - (setq cl-list1 - (apply 'cl-adjoin (car cl-list2) cl-list1 cl-keys)) - (or (memq (car cl-list2) cl-list1) - (push (car cl-list2) cl-list1))) - (pop cl-list2)) - cl-list1))) + (or (>= (length list1) (length list2)) + (setq list1 (prog1 list2 (setq list2 list1)))) + (while list2 + (if (or cl-keys (numberp (car list2))) + (setq list1 + (apply #'cl-adjoin (car list2) list1 cl-keys)) + (or (memq (car list2) list1) + (push (car list2) list1))) + (pop list2)) + list1))) ;;;###autoload -(defun cl-nunion (cl-list1 cl-list2 &rest cl-keys) +(defun cl-nunion (list1 list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-union operation. The resulting list contains all items that appear in either LIST1 or LIST2. This is a destructive function; it reuses the storage of LIST1 and LIST2 whenever possible. \nKeywords supported: :test :test-not :key \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" - (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) - (t (apply 'cl-union cl-list1 cl-list2 cl-keys)))) + (declare (important-return-value t)) + (cond ((null list1) list2) ((null list2) list1) + (t (apply #'cl-union list1 list2 cl-keys)))) ;;;###autoload -(defun cl-intersection (cl-list1 cl-list2 &rest cl-keys) +(defun cl-intersection (list1 list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-intersection operation. The resulting list contains all items that appear in both LIST1 and LIST2. This is a non-destructive function; it makes a copy of the data if necessary to avoid corrupting the original LIST1 and LIST2. \nKeywords supported: :test :test-not :key \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" - (and cl-list1 cl-list2 - (if (equal cl-list1 cl-list2) cl-list1 + (declare (important-return-value t)) + (and list1 list2 + (if (equal list1 list2) list1 (cl--parsing-keywords (:key) (:test :test-not) - (let ((cl-res nil)) - (or (>= (length cl-list1) (length cl-list2)) - (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1)))) - (while cl-list2 - (if (if (or cl-keys (numberp (car cl-list2))) - (apply 'cl-member (cl--check-key (car cl-list2)) - cl-list1 cl-keys) - (memq (car cl-list2) cl-list1)) - (push (car cl-list2) cl-res)) - (pop cl-list2)) - cl-res))))) + (let ((res nil)) + (or (>= (length list1) (length list2)) + (setq list1 (prog1 list2 (setq list2 list1)))) + (while list2 + (if (if (or cl-keys (numberp (car list2))) + (apply #'cl-member (cl--check-key (car list2)) + list1 cl-keys) + (memq (car list2) list1)) + (push (car list2) res)) + (pop list2)) + res))))) ;;;###autoload -(defun cl-nintersection (cl-list1 cl-list2 &rest cl-keys) +(defun cl-nintersection (list1 list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-intersection operation. The resulting list contains all items that appear in both LIST1 and LIST2. -This is a destructive function; it reuses the storage of LIST1 and LIST2 -whenever possible. +This is a destructive function; it reuses the storage of LIST1 (but not +LIST2) whenever possible. \nKeywords supported: :test :test-not :key \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" - (and cl-list1 cl-list2 (apply 'cl-intersection cl-list1 cl-list2 cl-keys))) + (declare (important-return-value t)) + (and list1 list2 (apply #'cl-intersection list1 list2 cl-keys))) ;;;###autoload -(defun cl-set-difference (cl-list1 cl-list2 &rest cl-keys) +(defun cl-set-difference (list1 list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-difference operation. The resulting list contains all items that appear in LIST1 but not LIST2. This is a non-destructive function; it makes a copy of the data if necessary to avoid corrupting the original LIST1 and LIST2. \nKeywords supported: :test :test-not :key \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" - (if (or (null cl-list1) (null cl-list2)) cl-list1 + (declare (important-return-value t)) + (if (or (null list1) (null list2)) list1 (cl--parsing-keywords (:key) (:test :test-not) - (let ((cl-res nil)) - (while cl-list1 - (or (if (or cl-keys (numberp (car cl-list1))) - (apply 'cl-member (cl--check-key (car cl-list1)) - cl-list2 cl-keys) - (memq (car cl-list1) cl-list2)) - (push (car cl-list1) cl-res)) - (pop cl-list1)) - (nreverse cl-res))))) + (let ((res nil)) + (while list1 + (or (if (or cl-keys (numberp (car list1))) + (apply #'cl-member (cl--check-key (car list1)) + list2 cl-keys) + (memq (car list1) list2)) + (push (car list1) res)) + (pop list1)) + (nreverse res))))) ;;;###autoload -(defun cl-nset-difference (cl-list1 cl-list2 &rest cl-keys) +(defun cl-nset-difference (list1 list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-difference operation. The resulting list contains all items that appear in LIST1 but not LIST2. -This is a destructive function; it reuses the storage of LIST1 and LIST2 -whenever possible. +This is a destructive function; it reuses the storage of LIST1 (but not +LIST2) whenever possible. \nKeywords supported: :test :test-not :key \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" - (if (or (null cl-list1) (null cl-list2)) cl-list1 - (apply 'cl-set-difference cl-list1 cl-list2 cl-keys))) + (declare (important-return-value t)) + (if (or (null list1) (null list2)) list1 + (apply #'cl-set-difference list1 list2 cl-keys))) ;;;###autoload -(defun cl-set-exclusive-or (cl-list1 cl-list2 &rest cl-keys) +(defun cl-set-exclusive-or (list1 list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-exclusive-or operation. The resulting list contains all items appearing in exactly one of LIST1, LIST2. This is a non-destructive function; it makes a copy of the data if necessary to avoid corrupting the original LIST1 and LIST2. \nKeywords supported: :test :test-not :key \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" - (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) - ((equal cl-list1 cl-list2) nil) - (t (append (apply 'cl-set-difference cl-list1 cl-list2 cl-keys) - (apply 'cl-set-difference cl-list2 cl-list1 cl-keys))))) + (declare (important-return-value t)) + (cond ((null list1) list2) ((null list2) list1) + ((equal list1 list2) nil) + (t (append (apply #'cl-set-difference list1 list2 cl-keys) + (apply #'cl-set-difference list2 list1 cl-keys))))) ;;;###autoload -(defun cl-nset-exclusive-or (cl-list1 cl-list2 &rest cl-keys) +(defun cl-nset-exclusive-or (list1 list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-exclusive-or operation. The resulting list contains all items appearing in exactly one of LIST1, LIST2. This is a destructive function; it reuses the storage of LIST1 and LIST2 whenever possible. \nKeywords supported: :test :test-not :key \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" - (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) - ((equal cl-list1 cl-list2) nil) - (t (nconc (apply 'cl-nset-difference cl-list1 cl-list2 cl-keys) - (apply 'cl-nset-difference cl-list2 cl-list1 cl-keys))))) + (declare (important-return-value t)) + (cond ((null list1) list2) ((null list2) list1) + ((equal list1 list2) nil) + (t (nconc (apply #'cl-nset-difference list1 list2 cl-keys) + (apply #'cl-nset-difference list2 list1 cl-keys))))) ;;;###autoload -(defun cl-subsetp (cl-list1 cl-list2 &rest cl-keys) +(defun cl-subsetp (list1 list2 &rest cl-keys) "Return true if LIST1 is a subset of LIST2. I.e., if every element of LIST1 also appears in LIST2. \nKeywords supported: :test :test-not :key \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" - (cond ((null cl-list1) t) ((null cl-list2) nil) - ((equal cl-list1 cl-list2) t) + (declare (important-return-value t)) + (cond ((null list1) t) ((null list2) nil) + ((equal list1 list2) t) (t (cl--parsing-keywords (:key) (:test :test-not) - (while (and cl-list1 - (apply 'cl-member (cl--check-key (car cl-list1)) - cl-list2 cl-keys)) - (pop cl-list1)) - (null cl-list1))))) + (while (and list1 + (apply #'cl-member (cl--check-key (car list1)) + list2 cl-keys)) + (pop list1)) + (null list1))))) ;;;###autoload -(defun cl-subst-if (cl-new cl-pred cl-tree &rest cl-keys) +(defun cl-subst-if (new pred tree &rest cl-keys) "Substitute NEW for elements matching PREDICATE in TREE (non-destructively). Return a copy of TREE with all matching elements replaced by NEW. \nKeywords supported: :key \n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" - (apply 'cl-sublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys)) + (declare (important-return-value t)) + (apply #'cl-sublis (list (cons nil new)) tree :if pred cl-keys)) ;;;###autoload -(defun cl-subst-if-not (cl-new cl-pred cl-tree &rest cl-keys) +(defun cl-subst-if-not (new pred tree &rest cl-keys) "Substitute NEW for elts not matching PREDICATE in TREE (non-destructively). Return a copy of TREE with all non-matching elements replaced by NEW. \nKeywords supported: :key \n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" - (apply 'cl-sublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) + (declare (important-return-value t)) + (apply #'cl-sublis (list (cons nil new)) tree :if-not pred cl-keys)) ;;;###autoload -(defun cl-nsubst (cl-new cl-old cl-tree &rest cl-keys) +(defun cl-nsubst (new old tree &rest cl-keys) "Substitute NEW for OLD everywhere in TREE (destructively). Any element of TREE which is `eql' to OLD is changed to NEW (via a call to `setcar'). \nKeywords supported: :test :test-not :key \n(fn NEW OLD TREE [KEYWORD VALUE]...)" - (apply 'cl-nsublis (list (cons cl-old cl-new)) cl-tree cl-keys)) + (declare (important-return-value t)) + (apply #'cl-nsublis (list (cons old new)) tree cl-keys)) ;;;###autoload -(defun cl-nsubst-if (cl-new cl-pred cl-tree &rest cl-keys) +(defun cl-nsubst-if (new pred tree &rest cl-keys) "Substitute NEW for elements matching PREDICATE in TREE (destructively). Any element of TREE which matches is changed to NEW (via a call to `setcar'). \nKeywords supported: :key \n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" - (apply 'cl-nsublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys)) + (declare (important-return-value t)) + (apply #'cl-nsublis (list (cons nil new)) tree :if pred cl-keys)) ;;;###autoload -(defun cl-nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys) +(defun cl-nsubst-if-not (new pred tree &rest cl-keys) "Substitute NEW for elements not matching PREDICATE in TREE (destructively). Any element of TREE which matches is changed to NEW (via a call to `setcar'). \nKeywords supported: :key \n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" - (apply 'cl-nsublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) + (declare (important-return-value t)) + (apply #'cl-nsublis (list (cons nil new)) tree :if-not pred cl-keys)) (defvar cl--alist) ;;;###autoload -(defun cl-sublis (cl-alist cl-tree &rest cl-keys) +(defun cl-sublis (alist tree &rest cl-keys) "Perform substitutions indicated by ALIST in TREE (non-destructively). Return a copy of TREE with all matching elements replaced. \nKeywords supported: :test :test-not :key \n(fn ALIST TREE [KEYWORD VALUE]...)" + (declare (important-return-value t)) (cl--parsing-keywords (:test :test-not :key :if :if-not) () - (let ((cl--alist cl-alist)) - (cl--sublis-rec cl-tree)))) - -(defun cl--sublis-rec (cl-tree) ;Uses cl--alist cl-key/test*/if*. - (let ((cl-temp (cl--check-key cl-tree)) (cl-p cl--alist)) - (while (and cl-p (not (cl--check-test-nokey (car (car cl-p)) cl-temp))) - (setq cl-p (cdr cl-p))) - (if cl-p (cdr (car cl-p)) - (if (consp cl-tree) - (let ((cl-a (cl--sublis-rec (car cl-tree))) - (cl-d (cl--sublis-rec (cdr cl-tree)))) - (if (and (eq cl-a (car cl-tree)) (eq cl-d (cdr cl-tree))) - cl-tree - (cons cl-a cl-d))) - cl-tree)))) + (let ((cl--alist alist)) + (cl--sublis-rec tree)))) + +(defun cl--sublis-rec (tree) ;Uses cl--alist cl-key/test*/if*. + (let ((temp (cl--check-key tree)) + (p cl--alist)) + (while (and p (not (cl--check-test-nokey (car (car p)) temp))) + (setq p (cdr p))) + (if p (cdr (car p)) + (if (consp tree) + (let ((a (cl--sublis-rec (car tree))) + (d (cl--sublis-rec (cdr tree)))) + (if (and (eq a (car tree)) (eq d (cdr tree))) + tree + (cons a d))) + tree)))) ;;;###autoload -(defun cl-nsublis (cl-alist cl-tree &rest cl-keys) +(defun cl-nsublis (alist tree &rest cl-keys) "Perform substitutions indicated by ALIST in TREE (destructively). Any matching element of TREE is changed via a call to `setcar'. \nKeywords supported: :test :test-not :key \n(fn ALIST TREE [KEYWORD VALUE]...)" + (declare (important-return-value t)) (cl--parsing-keywords (:test :test-not :key :if :if-not) () - (let ((cl-hold (list cl-tree)) - (cl--alist cl-alist)) - (cl--nsublis-rec cl-hold) - (car cl-hold)))) - -(defun cl--nsublis-rec (cl-tree) ;Uses cl--alist cl-key/test*/if*. - (while (consp cl-tree) - (let ((cl-temp (cl--check-key (car cl-tree))) (cl-p cl--alist)) - (while (and cl-p (not (cl--check-test-nokey (car (car cl-p)) cl-temp))) - (setq cl-p (cdr cl-p))) - (if cl-p (setcar cl-tree (cdr (car cl-p))) - (if (consp (car cl-tree)) (cl--nsublis-rec (car cl-tree)))) - (setq cl-temp (cl--check-key (cdr cl-tree)) cl-p cl--alist) - (while (and cl-p (not (cl--check-test-nokey (car (car cl-p)) cl-temp))) - (setq cl-p (cdr cl-p))) - (if cl-p - (progn (setcdr cl-tree (cdr (car cl-p))) (setq cl-tree nil)) - (setq cl-tree (cdr cl-tree)))))) + (let ((hold (list tree)) + (cl--alist alist)) + (cl--nsublis-rec hold) + (car hold)))) + +(defun cl--nsublis-rec (tree) ;Uses cl--alist cl-key/test*/if*. + (while (consp tree) + (let ((temp (cl--check-key (car tree))) + (p cl--alist)) + (while (and p (not (cl--check-test-nokey (car (car p)) temp))) + (setq p (cdr p))) + (if p (setcar tree (cdr (car p))) + (if (consp (car tree)) (cl--nsublis-rec (car tree)))) + (setq temp (cl--check-key (cdr tree)) p cl--alist) + (while (and p (not (cl--check-test-nokey (car (car p)) temp))) + (setq p (cdr p))) + (if p + (progn (setcdr tree (cdr (car p))) (setq tree nil)) + (setq tree (cdr tree)))))) ;;;###autoload -(defun cl-tree-equal (cl-x cl-y &rest cl-keys) +(defun cl-tree-equal (x y &rest cl-keys) "Return t if trees TREE1 and TREE2 have `eql' leaves. Atoms are compared by `eql'; cons cells are compared recursively. \nKeywords supported: :test :test-not :key \n(fn TREE1 TREE2 [KEYWORD VALUE]...)" + (declare (important-return-value t)) (cl--parsing-keywords (:test :test-not :key) () - (cl--tree-equal-rec cl-x cl-y))) + (cl--tree-equal-rec x y))) -(defun cl--tree-equal-rec (cl-x cl-y) ;Uses cl-key/test*. - (while (and (consp cl-x) (consp cl-y) - (cl--tree-equal-rec (car cl-x) (car cl-y))) - (setq cl-x (cdr cl-x) cl-y (cdr cl-y))) - (and (not (consp cl-x)) (not (consp cl-y)) (cl--check-match cl-x cl-y))) +(defun cl--tree-equal-rec (x y) ;Uses cl-key/test*. + (while (and (consp x) (consp y) + (cl--tree-equal-rec (car x) (car y))) + (setq x (cdr x) y (cdr y))) + (and (not (consp x)) (not (consp y)) (cl--check-match x y))) (make-obsolete-variable 'cl-seq-load-hook diff --git a/lisp/emacs-lisp/comp-common.el b/lisp/emacs-lisp/comp-common.el index 0eeda8cef54..faf368bb858 100644 --- a/lisp/emacs-lisp/comp-common.el +++ b/lisp/emacs-lisp/comp-common.el @@ -56,7 +56,7 @@ This is intended for debugging the compiler itself. "Primitive functions to exclude from trampoline optimization. Primitive functions included in this list will not be called -directly by the natively-compiled code, which makes trampolines for +directly by the native-compiled code, which makes trampolines for those primitives unnecessary in case of function redefinition/advice." :type '(repeat symbol) :version "30.1") @@ -510,17 +510,17 @@ 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) - ;; Native compiled inferred + ;; Natively compiled inferred (setf kind 'inferred type-spec (subr-type f)))))) (when type-spec diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 52ed73ff5c3..67c72c8ce2b 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)) @@ -216,7 +216,7 @@ Return them as multiple value." collect cstr into positives finally return (cl-values positives negatives))) -;; So we can load comp-cstr.el and comp.el in non native compiled +;; So we can load comp-cstr.el and comp.el in non natively compiled ;; builds. (defvar comp-ctxt nil) @@ -448,12 +448,12 @@ Return them as multiple value." do (when (zerop nest) (setf low i)) - (cl-incf nest) + (incf nest) else do (when (= nest 1) (push `(,(comp-range-1+ low) . ,i) res)) - (cl-decf nest) + (decf nest) finally return (reverse res))) (defun comp--range-intersection (&rest ranges) @@ -477,7 +477,7 @@ Return them as multiple value." (cl-return '())) if (eq x 'l) do - (cl-incf nest) + (incf nest) (when (= nest n-ranges) (setf low i)) else @@ -485,7 +485,7 @@ Return them as multiple value." (when (= nest n-ranges) (push `(,low . ,i) res)) - (cl-decf nest) + (decf nest) finally return (reverse res))) (defun comp--range-negation (range) @@ -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..061f1767b74 100644 --- a/lisp/emacs-lisp/comp-run.el +++ b/lisp/emacs-lisp/comp-run.el @@ -161,9 +161,6 @@ LOAD and SELECTOR work as described in `native--compile-async'." (defvar comp-files-queue () "List of Emacs Lisp files to be compiled.") -(defvar comp-async-compilations (make-hash-table :test #'equal) - "Hash table file-name -> async compilation process.") - (defun comp--async-runnings () "Return the number of async compilations currently running. This function has the side effect of cleaning-up finished @@ -186,8 +183,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 +367,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 +420,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..6ad00f63971 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -42,6 +42,7 @@ (defvar comp-subr-arities-h) (defvar native-comp-eln-load-path) (defvar native-comp-enable-subr-trampolines) +(defvar comp--\#$) (declare-function comp--compile-ctxt-to-file0 "comp.c") (declare-function comp--init-ctxt "comp.c") @@ -155,7 +156,7 @@ native compilation runs.") (defvar comp-curr-allocation-class 'd-default "Current allocation class. -Can be one of: `d-default', `d-impure' or `d-ephemeral'. See `comp-ctxt'.") +Can be one of: `d-default' or `d-ephemeral'. See `comp-ctxt'.") (defconst comp-passes '(comp--spill-lap comp--limplify @@ -164,6 +165,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 +202,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 @@ -332,14 +334,14 @@ Useful to hook into pass checkers.") "Append ELT into VEC. Returns ELT." (puthash (comp-vec-end vec) elt (comp-vec-data vec)) - (cl-incf (comp-vec-end vec)) + (incf (comp-vec-end vec)) elt) (defsubst comp-vec-prepend (vec elt) "Prepend ELT into VEC. Returns ELT." (puthash (1- (comp-vec-beg vec)) elt (comp-vec-data vec)) - (cl-decf (comp-vec-beg vec)) + (decf (comp-vec-beg vec)) elt) @@ -394,9 +396,6 @@ Needed to replace immediate byte-compiled lambdas with the compiled reference.") :documentation "Documentation index -> documentation") (d-default (make-comp-data-container) :type comp-data-container :documentation "Standard data relocated in use by functions.") - (d-impure (make-comp-data-container) :type comp-data-container - :documentation "Relocated data that cannot be moved into pure space. -This is typically for top-level forms other than defun.") (d-ephemeral (make-comp-data-container) :type comp-data-container :documentation "Relocated data not necessary after load.") (with-late-load nil :type boolean @@ -493,7 +492,7 @@ non local exit (ends with an `unreachable' insn).")) "Return a sequential number generator." (let ((n -1)) (lambda () - (cl-incf n)))) + (incf n)))) (cl-defstruct (comp-func (:copier nil)) "LIMPLE representation of a function." @@ -616,7 +615,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 +791,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) @@ -946,7 +953,7 @@ Points to the next slot to be filled.") Restore the original value afterwards." (declare (debug (form body)) (indent defun)) - (let ((sym (gensym))) + (cl-with-gensyms (sym) `(let ((,sym (comp--sp))) (setf (comp--sp) ,sp) (progn ,@body) @@ -1181,7 +1188,7 @@ Return value is the fall-through block name." (defun comp--jump-table-optimizable (jmp-table) "Return t if JMP-TABLE can be optimized out." ;; Identify LAP sequences like: - ;; (byte-constant #s(hash-table test eq purecopy t data (created 126 deleted 126 changed 126)) . 24) + ;; (byte-constant #s(hash-table test eq data (created 126 deleted 126 changed 126)) . 24) ;; (byte-switch) ;; (TAG 126 . 10) (let ((targets (hash-table-values jmp-table))) @@ -1295,7 +1302,7 @@ and the annotation emission." ;; ,(concat "LAP op " op-name))) ;; Emit the stack adjustment if present. ,(when (and sp-delta (not (eq 0 sp-delta))) - `(cl-incf (comp--sp) ,sp-delta)) + `(incf (comp--sp) ,sp-delta)) ,@(comp--body-eff body op-name sp-delta)) else collect `(',op (signal 'native-ice @@ -1329,7 +1336,7 @@ and the annotation emission." (make--comp-mvar :constant arg) (comp--slot+1)))) (byte-call - (cl-incf (comp--sp) (- arg)) + (incf (comp--sp) (- arg)) (comp--emit-set-call (comp--callref 'funcall (1+ arg) (comp--sp)))) (byte-unbind (comp--emit (comp--call 'helper_unbind_n @@ -1484,19 +1491,19 @@ and the annotation emission." (byte-numberp auto) (byte-integerp auto) (byte-listN - (cl-incf (comp--sp) (- 1 arg)) + (incf (comp--sp) (- 1 arg)) (comp--emit-set-call (comp--callref 'list arg (comp--sp)))) (byte-concatN - (cl-incf (comp--sp) (- 1 arg)) + (incf (comp--sp) (- 1 arg)) (comp--emit-set-call (comp--callref 'concat arg (comp--sp)))) (byte-insertN - (cl-incf (comp--sp) (- 1 arg)) + (incf (comp--sp) (- 1 arg)) (comp--emit-set-call (comp--callref 'insert arg (comp--sp)))) (byte-stack-set (comp--copy-slot (1+ (comp--sp)) (- (comp--sp) arg -1))) (byte-stack-set2 (cl-assert nil)) ;; TODO (byte-discardN - (cl-incf (comp--sp) (- arg))) + (incf (comp--sp) (- arg))) (byte-switch ;; Assume to follow the emission of a setimm. ;; This is checked into comp--emit-switch. @@ -1506,7 +1513,7 @@ and the annotation emission." (byte-constant (comp--emit-setimm arg)) (byte-discardN-preserve-tos - (cl-incf (comp--sp) (- arg)) + (incf (comp--sp) (- arg)) (comp--copy-slot (+ arg (comp--sp))))))) (defun comp--emit-narg-prologue (minarg nonrest rest) @@ -1536,7 +1543,7 @@ and the annotation emission." (comp--emit `(set-rest-args-to-local ,(comp--slot-n nonrest))) (setf (comp--sp) nonrest) (when (and (> nonrest 8) (null rest)) - (cl-decf (comp--sp)))) + (decf (comp--sp)))) (defun comp--limplify-finalize-function (func) "Reverse insns into all basic blocks of FUNC." @@ -1606,7 +1613,7 @@ and the annotation emission." (unless for-late-load (comp--emit (comp--call 'eval - (let ((comp-curr-allocation-class 'd-impure)) + (let ((comp-curr-allocation-class 'd-default)) (make--comp-mvar :constant (byte-to-native-top-level-form form))) (make--comp-mvar :constant @@ -1616,7 +1623,7 @@ and the annotation emission." "Emit the creation of subrs for lambda FUNC. These are stored in the reloc data array." (let ((args (comp--prepare-args-for-top-level func))) - (let ((comp-curr-allocation-class 'd-impure)) + (let ((comp-curr-allocation-class 'd-default)) (comp--add-const-to-relocs (comp-func-byte-func func))) (comp--emit (comp--call 'comp--register-lambda @@ -1696,7 +1703,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) @@ -1715,7 +1722,7 @@ into the C code forwarding the compilation unit." for inst = (car inst-cell) for next-inst = (car-safe (cdr inst-cell)) do (comp--limplify-lap-inst inst) - (cl-incf (comp-limplify-pc comp-pass)) + (incf (comp-limplify-pc comp-pass)) when (comp--lap-fall-through-p inst) do (pcase next-inst (`(TAG ,_label . ,label-sp) @@ -1748,7 +1755,7 @@ into the C code forwarding the compilation unit." (let ((args (comp-func-l-args func))) (if (comp-args-p args) (cl-loop for i below (comp-args-max args) - do (cl-incf (comp--sp)) + do (incf (comp--sp)) (comp--emit `(set-par-to-local ,(comp--slot) ,i))) (comp--emit-narg-prologue (comp-args-base-min args) (comp-nargs-nonrest args) @@ -1873,9 +1880,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 +1898,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 + (- (incf (comp-func-vframe-size comp-func)))))) (progn (push `(assume ,new-mvar ,op) (cdr insns-seq)) new-mvar) @@ -1965,7 +1972,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 +2137,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 +2338,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 +2448,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 +2506,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 +2551,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 +2666,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 +2683,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. @@ -2754,7 +2768,7 @@ Return t if something was changed." (comp--copy-insn insn)) do (comp--fwprop-insn insn) - (cl-incf i) + (incf i) when (and (null modified) (not (equal insn orig-insn))) do (setf modified t)) when (> i comp--fwprop-max-insns-scan) @@ -2802,6 +2816,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 +2966,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 (_) @@ -3178,7 +3255,9 @@ Set it into the `type' slot." ;; from the corresponding m-var. collect (if (gethash obj (comp-ctxt-byte-func-to-func-h comp-ctxt)) - 'lambda-fixup + ;; This prints as #$, so we can assert this + ;; value does not remain in the data vector + comp--\#$ obj)))) (defun comp--finalize-relocs () @@ -3192,28 +3271,15 @@ Update all insn accordingly." (let* ((d-default (comp-ctxt-d-default comp-ctxt)) (d-default-idx (comp-data-container-idx d-default)) - (d-impure (comp-ctxt-d-impure comp-ctxt)) - (d-impure-idx (comp-data-container-idx d-impure)) (d-ephemeral (comp-ctxt-d-ephemeral comp-ctxt)) (d-ephemeral-idx (comp-data-container-idx d-ephemeral))) - ;; We never want compiled lambdas ending up in pure space. A copy must - ;; be already present in impure (see `comp--emit-lambda-for-top-level'). - (cl-loop for obj being each hash-keys of d-default-idx - when (gethash obj (comp-ctxt-lambda-fixups-h comp-ctxt)) - do (cl-assert (gethash obj d-impure-idx)) - (remhash obj d-default-idx)) - ;; Remove entries in d-impure already present in d-default. - (cl-loop for obj being each hash-keys of d-impure-idx - when (gethash obj d-default-idx) - do (remhash obj d-impure-idx)) - ;; Remove entries in d-ephemeral already present in d-default or - ;; d-impure. + ;; Remove entries in d-ephemeral already present in d-default (cl-loop for obj being each hash-keys of d-ephemeral-idx - when (or (gethash obj d-default-idx) (gethash obj d-impure-idx)) + when (gethash obj d-default-idx) do (remhash obj d-ephemeral-idx)) ;; Fix-up indexes in each relocation class and fill corresponding ;; reloc lists. - (mapc #'comp--finalize-container (list d-default d-impure d-ephemeral)) + (mapc #'comp--finalize-container (list d-default d-ephemeral)) ;; Make a vector from the function documentation hash table. (cl-loop with h = (comp-ctxt-function-docs comp-ctxt) with v = (make-vector (hash-table-count h) nil) @@ -3223,13 +3289,13 @@ Update all insn accordingly." finally do (setf (comp-ctxt-function-docs comp-ctxt) v)) ;; And now we conclude with the following: We need to pass to - ;; `comp--register-lambda' the index in the impure relocation - ;; array to store revived lambdas, but given we know it only now - ;; we fix it up as last. + ;; `comp--register-lambda' the index in the relocation array to + ;; store revived lambdas, but given we know it only now we fix it up + ;; as last. (cl-loop for f being each hash-keys of (comp-ctxt-lambda-fixups-h comp-ctxt) using (hash-value mvar) with reverse-h = (make-hash-table) ;; Make sure idx is unique. - for idx = (gethash f d-impure-idx) + for idx = (gethash f d-default-idx) do (cl-assert (null (gethash idx reverse-h))) (cl-assert (fixnump idx)) @@ -3509,7 +3575,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 +3630,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 +3726,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..7c4c1043948 --- /dev/null +++ b/lisp/emacs-lisp/cond-star.el @@ -0,0 +1,755 @@ +;;; 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: cond-star +;; Version: 1.0 +;; Package-Requires: ((emacs "24.3")) + +;; This is a GNU ELPA :core package. Avoid functionality that is not +;; compatible with the version of Emacs recorded above. + +;; 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 the `cond*' macro, that extends `cond' with +;; pattern-matching capabilities. It provides an alternative to +;; `pcase'. Consult the Info note `(elisp) cond* Macro' for details on +;; how to use it. + +;;; Implementation Notice: + +;; 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`(bind* BINDINGS...)', `(match* PATTERN DATUM)', +or `(pcase* PATTERN DATUM)', + +`(bind* BINDINGS...)' means to bind BINDINGS (as if they were in `let*') +for the body of the clause, and all subsequent clauses, since the `bind*' +clause is always a non-exit clause. As a condition, it counts as true +and runs the body of the clause if the first binding's value is non-nil. + +`(match* PATTERN DATUM)' means to match DATUM against the pattern PATTERN +For its patterns, see `match*'. +The condition counts as true if PATTERN matches 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. + +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 +t or 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) + ;; Starts with a `bind*' pseudo-form. + (and (consp (car clause)) + (eq (caar clause) 'bind*)))))) + +(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/crm.el b/lisp/emacs-lisp/crm.el index d442d74f030..a75ccd46f50 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -79,9 +79,25 @@ (define-obsolete-variable-alias 'crm-default-separator 'crm-separator "29.1") -(defvar crm-separator "[ \t]*,[ \t]*" +(defvar crm-separator + (propertize "[ \t]*,[ \t]*" 'separator "," 'description "comma-separated list") "Separator regexp used for separating strings in `completing-read-multiple'. -It should be a regexp that does not match the list of completion candidates.") +It should be a regexp that does not match the list of completion +candidates. The regexp string can carry the text properties `separator' +and `description', which if present `completing-read-multiple' will show +as part of the prompt. See the user option `crm-prompt'.") + +(defcustom crm-prompt "[%d] %p" + "Prompt format for `completing-read-multiple'. +The prompt is formatted by `format-spec' with the keys %d, %s and %p +standing for the separator description, the separator itself and the +original prompt respectively." + :type '(choice (const :tag "Original prompt" "%p") + (const :tag "Description and prompt" "[%d] %p") + (const :tag "Short CRM indication" "[CRM%s] %p") + (string :tag "Custom string")) + :group 'minibuffer + :version "31.1") (defvar-keymap crm-local-completion-map :doc "Local keymap for minibuffer multiple input with completion. @@ -268,8 +284,14 @@ with empty strings removed." (unless (eq require-match t) require-match)) (setq-local crm-completion-table table)) (setq input (read-from-minibuffer - prompt initial-input map - nil hist def inherit-input-method))) + (format-spec + crm-prompt + (let* ((sep (or (get-text-property 0 'separator crm-separator) + (string-replace "[ \t]*" "" crm-separator))) + (desc (or (get-text-property 0 'description crm-separator) + (concat "list separated by " sep)))) + `((?s . ,sep) (?d . ,desc) (?p . ,prompt)))) + initial-input map nil hist def inherit-input-method))) ;; If the user enters empty input, `read-from-minibuffer' ;; returns the empty string, not DEF. (when (and def (string-equal input "")) diff --git a/lisp/emacs-lisp/debug-early.el b/lisp/emacs-lisp/debug-early.el index 48b71e7f9f0..b6fdef00080 100644 --- a/lisp/emacs-lisp/debug-early.el +++ b/lisp/emacs-lisp/debug-early.el @@ -36,6 +36,8 @@ ;; For bootstrap reasons, we cannot use any macros here since they're ;; not defined yet. +(defvar debugger--last-error nil) + (defalias 'debug-early-backtrace #'(lambda (&optional base) "Print a trace of Lisp function calls currently active. @@ -76,15 +78,20 @@ of the build process." (setq args (cdr args))) (princ " "))) (princ ")\n")))) - base)))) + base)) + (message "debug-early-backtrace...done"))) (defalias 'debug--early #'(lambda (error base) - (princ "\nError: ") - (prin1 (car error)) ; The error symbol. - (princ " ") - (prin1 (cdr error)) ; The error data. - (debug-early-backtrace base))) + (if (eq error debugger--last-error) nil + (setq debugger--last-error nil) + (princ "\nError: ") + (prin1 (car error)) ; The error symbol. + (princ " ") + (prin1 (cdr error)) ; The error data. + (prog1 ;; Purposefully not `unwind-protect'! + (debug-early-backtrace base) + (setq debugger--last-error error))))) (defalias 'debug-early ;Called from C. #'(lambda (&rest args) diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 0ca3a0f931c..c1aaa1ac623 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -153,8 +153,6 @@ where CAUSE can be: (insert (debugger--buffer-state-content state))) (goto-char (debugger--buffer-state-pos state))) -(defvar debugger--last-error nil) - (defun debugger--duplicate-p (args) (pcase args (`(error ,err . ,_) (and (consp err) (eq err debugger--last-error))))) @@ -253,11 +251,11 @@ the debugger will not be entered." ;; Place an extra debug-on-exit for macro's. (when (eq 'lambda (car-safe (cadr (backtrace-frame 1 base)))) (backtrace-debug 2 t base)))) - (with-current-buffer debugger-buffer - (unless (derived-mode-p 'debugger-mode) - (debugger-mode)) - (debugger-setup-buffer debugger-args) - (when non-interactive-frame + (set-buffer debugger-buffer) + (unless (derived-mode-p 'debugger-mode) + (debugger-mode)) + (debugger-setup-buffer debugger-args) + (if non-interactive-frame ;; If the backtrace is long, save the beginning ;; and the end, but discard the middle. (let ((inhibit-read-only t)) @@ -269,38 +267,37 @@ the debugger will not be entered." (goto-char (point-max)) (forward-line (- (/ debugger-batch-max-lines 2))) (delete-region middlestart (point))) - (insert "...\n"))) - (message "%s" (buffer-string)) - (kill-emacs -1))) - (pop-to-buffer - debugger-buffer - `((display-buffer-reuse-window - display-buffer-in-previous-window - display-buffer-below-selected) - . ((window-min-height . 10) - (window-height . fit-window-to-buffer) - ,@(when (and (window-live-p debugger-previous-window) - (frame-visible-p - (window-frame debugger-previous-window))) - `((previous-window . ,debugger-previous-window)))))) - (setq debugger-window (selected-window)) - (when debugger-jumping-flag - ;; Try to restore previous height of debugger - ;; window. - (condition-case nil - (window-resize - debugger-window - (- debugger-previous-window-height - (window-total-height debugger-window))) - (error nil)) - (setq debugger-previous-window debugger-window)) - (message "") - (let ((standard-output nil) - (buffer-read-only t)) - (message "") - ;; Make sure we unbind buffer-read-only in the right buffer. - (save-excursion - (recursive-edit)))) + (insert "...\n")) + (message "%s" (buffer-string))) + (pop-to-buffer + debugger-buffer + `((display-buffer-reuse-window + display-buffer-in-previous-window + display-buffer-below-selected) + . ((window-min-height . 10) + (window-height . fit-window-to-buffer) + ,@(when (and (window-live-p debugger-previous-window) + (frame-visible-p + (window-frame debugger-previous-window))) + `((previous-window . ,debugger-previous-window)))))) + (setq debugger-window (selected-window)) + (when debugger-jumping-flag + ;; Try to restore previous height of debugger + ;; window. + (condition-case nil + (window-resize + debugger-window + (- debugger-previous-window-height + (window-total-height debugger-window))) + (error nil)) + (setq debugger-previous-window debugger-window)) + (message "") + (let ((standard-output nil) + (buffer-read-only t)) + (message "") + ;; Make sure we unbind buffer-read-only in the right buffer. + (save-excursion + (recursive-edit))))) (when (and (window-live-p debugger-window) (eq (window-buffer debugger-window) debugger-buffer)) ;; Record height of debugger window. diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index 6b10150d04d..2e54d6ce36c 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -220,7 +220,7 @@ No problems result if this variable is not bound. (with-no-warnings (defvar ,map (make-sparse-keymap))) (unless (get ',map 'variable-documentation) (put ',map 'variable-documentation - (purecopy ,(format "Keymap for `%s'." child)))) + ,(format "Keymap for `%s'." child))) ,(if declare-syntax `(progn (defvar ,syntax) @@ -229,7 +229,7 @@ No problems result if this variable is not bound. (defvar ,syntax (make-syntax-table))) (unless (get ',syntax 'variable-documentation) (put ',syntax 'variable-documentation - (purecopy ,(format "Syntax table for `%s'." child)))))) + ,(format "Syntax table for `%s'." child))))) ,(if declare-abbrev `(progn (defvar ,abbrev) @@ -239,7 +239,7 @@ No problems result if this variable is not bound. (progn (define-abbrev-table ',abbrev nil) ,abbrev))) (unless (get ',abbrev 'variable-documentation) (put ',abbrev 'variable-documentation - (purecopy ,(format "Abbrev table for `%s'." child)))))) + ,(format "Abbrev table for `%s'." child))))) (if (fboundp 'derived-mode-set-parent) ;; Emacs≥30.1 (derived-mode-set-parent ',child ',parent) (put ',child 'derived-mode-parent ',parent)) diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index f53db48f0b7..e59799df383 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -269,7 +269,7 @@ INIT-VALUE LIGHTER KEYMAP. (setq body (cdr body)) (pcase keyw (:init-value (setq init-value (pop body))) - (:lighter (setq lighter (purecopy (pop body)))) + (:lighter (setq lighter (pop body))) (:global (setq globalp (pop body)) (when (and globalp (symbolp mode)) (setq setter `(setq-default ,mode)) @@ -444,8 +444,6 @@ No problems result if this variable is not bound. ;;; ;;;###autoload -(defalias 'define-global-minor-mode #'define-globalized-minor-mode) -;;;###autoload (defmacro define-globalized-minor-mode (global-mode mode turn-on &rest body) "Make a global mode GLOBAL-MODE corresponding to buffer-local minor MODE. TURN-ON is a function that will be called with no args in every buffer @@ -763,6 +761,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,60 +831,33 @@ 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. +;; When deleting these, also delete them from loaddefs-gen.el. ;;;###autoload (define-obsolete-function-alias 'easy-mmode-define-minor-mode #'define-minor-mode "30.1") ;;;###autoload (define-obsolete-function-alias 'easy-mmode-define-global-mode #'define-globalized-minor-mode "30.1") +;;;###autoload +(define-obsolete-function-alias 'define-global-minor-mode + #'define-globalized-minor-mode "31.1") (provide 'easy-mmode) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 005865168b9..8a10f26a7b4 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1369,7 +1369,7 @@ infinite loops when the code/environment contains a circular object.") ;; Set the name here if it was not set by edebug-make-enter-wrapper. (setq edebug-def-name - (or edebug-def-name edebug-old-def-name (cl-gensym "edebug-anon"))) + (or edebug-def-name edebug-old-def-name (gensym "edebug-anon"))) ;; Add this def as a dependent of containing def. Buggy. '(if (and edebug-containing-def-name @@ -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.") @@ -4246,7 +4255,7 @@ code location is known." (let ((new-frame (copy-edebug--frame frame)) (fun (edebug--frame-fun frame)) (args (edebug--frame-args frame))) - (cl-decf index) ;; FIXME: Not used? + (decf index) ;; FIXME: Not used? (pcase fun ('edebug-enter (setq skip-next-lambda t @@ -4585,8 +4594,8 @@ With prefix argument, make it a temporary breakpoint." (let ((s 1)) (while (memq (nth 1 (backtrace-frame i 'called-interactively-p)) '(edebug-enter edebug-default-enter)) - (cl-incf s) - (cl-incf i)) + (incf s) + (incf i)) s))) ;; Finally, hook edebug into the rest of Emacs. @@ -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-custom.el b/lisp/emacs-lisp/eieio-custom.el index 60ec854bb69..3f5291d0dee 100644 --- a/lisp/emacs-lisp/eieio-custom.el +++ b/lisp/emacs-lisp/eieio-custom.el @@ -75,7 +75,7 @@ of these.") (((class color) (background light)) (:foreground "blue")) - (t (:italic t))) + (t (:slant italic))) "Face used for unpushable variable tags." :group 'custom-faces) diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el index 2acd1b8d2e4..5ae665a57fb 100644 --- a/lisp/emacs-lisp/eieio-datadebug.el +++ b/lisp/emacs-lisp/eieio-datadebug.el @@ -111,7 +111,7 @@ PREBUTTONTEXT is some text between PREFIX and the object button." ))))))) ;;; Augment the Data debug thing display list. -(data-debug-add-specialized-thing (lambda (thing) (eieio-object-p thing)) +(data-debug-add-specialized-thing #'eieio-object-p #'data-debug-insert-object-button) ;;; DEBUG METHODS diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 8b971b50490..0f029813f80 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -58,6 +58,7 @@ ;;; Defining a new class ;; +;;;###autoload (defmacro defclass (name superclasses slots &rest options-and-doc) "Define NAME as a new class derived from SUPERCLASS with SLOTS. OPTIONS-AND-DOC is used as the class' options and base documentation. @@ -114,10 +115,10 @@ and reference them using the function `class-option'." (cl-check-type superclasses list) (cond ((and (stringp (car options-and-doc)) - (/= 1 (% (length options-and-doc) 2))) + (evenp (length options-and-doc))) (error "Too many arguments to `defclass'")) ((and (symbolp (car options-and-doc)) - (/= 0 (% (length options-and-doc) 2))) + (oddp (length options-and-doc))) (error "Too many arguments to `defclass'"))) (if (stringp (car options-and-doc)) @@ -769,10 +770,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/eldoc.el b/lisp/emacs-lisp/eldoc.el index 41b735489ff..966158024dd 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -78,7 +78,7 @@ If nil, truncated messages will just have \"...\" to indicate truncation." :version "28.1") ;;;###autoload -(defcustom eldoc-minor-mode-string (purecopy " ElDoc") +(defcustom eldoc-minor-mode-string " ElDoc" "String to display in mode line when ElDoc Mode is enabled; nil for none." :type '(choice string (const :tag "None" nil))) @@ -154,7 +154,6 @@ this file since the obarray is initialized at load time. Remember to keep it a prime number to improve hash performance.") (defvar eldoc-message-commands - ;; Don't define as `defconst' since it would then go to (read-only) purespace. (obarray-make eldoc-message-commands-table-size) "Commands after which it is appropriate to print in the echo area. ElDoc does not try to print function arglists, etc., after just any command, @@ -166,7 +165,6 @@ directly. Instead, use `eldoc-add-command' and `eldoc-remove-command'.") ;; Not a constant. (defvar eldoc-last-data (make-vector 3 nil) - ;; Don't define as `defconst' since it would then go to (read-only) purespace. "Bookkeeping; elements are as follows: 0 - contains the last symbol read from the buffer. 1 - contains the string last displayed in the echo area for variables, @@ -269,6 +267,14 @@ See `eldoc-documentation-strategy' for more detail." (eldoc-mode 1))) +(defun eldoc--update () + (when (or eldoc-mode + (and global-eldoc-mode + (eldoc--supported-p))) + ;; Don't ignore, but also don't full-on signal errors + (with-demoted-errors "eldoc error: %s" + (eldoc-print-current-symbol-info)) )) + (defun eldoc-schedule-timer () "Ensure `eldoc-timer' is running. @@ -279,13 +285,7 @@ reflect the change." (setq eldoc-timer (run-with-idle-timer eldoc-idle-delay nil - (lambda () - (when (or eldoc-mode - (and global-eldoc-mode - (eldoc--supported-p))) - ;; Don't ignore, but also don't full-on signal errors - (with-demoted-errors "eldoc error: %s" - (eldoc-print-current-symbol-info)) ))))) + #'eldoc--update))) ;; If user has changed the idle delay, update the timer. (cond ((not (= eldoc-idle-delay eldoc-current-idle-delay)) diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el index 0f5d15be838..5ae8880167d 100644 --- a/lisp/emacs-lisp/elint.el +++ b/lisp/emacs-lisp/elint.el @@ -798,7 +798,7 @@ CODE can be a lambda expression, a macro, or byte-compiled code." (defun elint-check-setq-form (form env) "Lint the setq FORM in ENV." - (or (= (mod (length form) 2) 1) + (or (oddp (length form)) ;; (setq foo) is valid and equivalent to (setq foo nil). (elint-warning "Missing value in setq: %s" form)) (let ((newenv env) @@ -833,7 +833,7 @@ CODE can be a lambda expression, a macro, or byte-compiled code." "Lint the defcustom FORM in ENV." (if (and (> (length form) 3) ;; even no. of keyword/value args ? - (zerop (logand (length form) 1))) + (evenp (length form))) (elint-env-add-global-var (elint-form (nth 2 form) env) (car (cdr form))) (elint-error "Malformed variable declaration: %s" form) diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el index bb99bef55cc..784baf55c7b 100644 --- a/lisp/emacs-lisp/elp.el +++ b/lisp/emacs-lisp/elp.el @@ -395,11 +395,11 @@ original definition, use \\[elp-restore-function] or \\[elp-restore-all]." ;; we are recording times (let (enter-time) ;; increment the call-counter - (cl-incf (aref info 0)) + (incf (aref info 0)) (setq enter-time (current-time) result (apply func args)) ;; calculate total time in function - (cl-incf (aref info 1) (elp-elapsed-time enter-time nil)) + (incf (aref info 1) (elp-elapsed-time enter-time nil)) )) ;; turn off recording if this is the master function (if (and elp-master diff --git a/lisp/emacs-lisp/ert-font-lock.el b/lisp/emacs-lisp/ert-font-lock.el index 80f4a6d5467..0f8e90d747c 100644 --- a/lisp/emacs-lisp/ert-font-lock.el +++ b/lisp/emacs-lisp/ert-font-lock.el @@ -37,8 +37,6 @@ (require 'ert) (require 'ert-x) -(require 'newcomment) -(require 'pcase) (defconst ert-font-lock--face-symbol-re (rx (+ (or alphanumeric "-" "_" "." "/"))) @@ -100,25 +98,24 @@ Argument TEST-NAME - name of the currently running ert test." (defun ert-font-lock--parse-macro-args (doc-keys-mode-arg) "Parse DOC-KEYS-MODE-ARG macro argument list." - (let (doc doc-p mode arg) + (let (doc mode arg) (when (stringp (car doc-keys-mode-arg)) - (setq doc (pop doc-keys-mode-arg) - doc-p t)) + (setq doc (pop doc-keys-mode-arg))) (pcase-let ((`(,keys ,mode-arg) (ert--parse-keys-and-body doc-keys-mode-arg))) (unless (symbolp (car mode-arg)) - (error "A major mode symbol expected: %S" (car mode-arg))) + (error "Expected a major mode symbol: %S" (car mode-arg))) (setq mode (pop mode-arg)) (unless (stringp (car mode-arg)) - (error "A string or file with assertions expected: %S" (car mode-arg))) + (error "Expected a string or file with assertions: %S" (car mode-arg))) (setq arg (pop mode-arg)) - (list doc doc-p keys mode arg)))) + (list doc keys mode arg)))) ;;;###autoload (defmacro ert-font-lock-deftest (name &rest docstring-keys-mode-and-str) @@ -139,22 +136,20 @@ used through `ert'. stringp)) (doc-string 2) (indent 1)) - (pcase-let ((`(,documentation - ,documentation-supplied-p - ,keys ,mode ,arg) + (pcase-let ((`(,documentation ,keys ,mode ,arg) (ert-font-lock--parse-macro-args docstring-keys-mode-and-str))) `(ert-set-test ',name (make-ert-test :name ',name - ,@(when documentation-supplied-p + ,@(when documentation `(:documentation ,documentation)) ,@(when (map-contains-key keys :expected-result) `(:expected-result-type ,(map-elt keys :expected-result))) ,@(when (map-contains-key keys :tags) `(:tags ,(map-elt keys :tags))) - :body (lambda () (ert-font-lock--test-body-str ',mode ,arg ',name)) - + :body (lambda () + (ert-font-lock--test-body-str ',mode ,arg ',name)) :file-name ,(or (macroexp-file-name) buffer-file-name))))) ;;;###autoload @@ -178,23 +173,20 @@ through `ert'. stringp)) (doc-string 2) (indent 1)) - - (pcase-let ((`(,documentation - ,documentation-supplied-p - ,keys ,mode ,arg) + (pcase-let ((`(,documentation ,keys ,mode ,arg) (ert-font-lock--parse-macro-args docstring-keys-mode-and-file))) `(ert-set-test ',name (make-ert-test :name ',name - ,@(when documentation-supplied-p + ,@(when documentation `(:documentation ,documentation)) ,@(when (map-contains-key keys :expected-result) `(:expected-result-type ,(map-elt keys :expected-result))) ,@(when (map-contains-key keys :tags) `(:tags ,(map-elt keys :tags))) :body (lambda () (ert-font-lock--test-body-file - ',mode (ert-resource-file ,arg) ',name)) + ',mode (ert-resource-file ,arg) ',name)) :file-name ,(or (macroexp-file-name) buffer-file-name))))) (defun ert-font-lock--in-comment-p () @@ -357,10 +349,8 @@ The function is meant to be run from within an ERT test." ;; normalize both expected and resulting face - these can be ;; either symbols, nils or lists of symbols - (when (not (listp actual-face)) - (setq actual-face (list actual-face))) - (when (not (listp expected-face)) - (setq expected-face (list expected-face))) + (setq actual-face (ensure-list actual-face)) + (setq expected-face (ensure-list expected-face)) ;; fail when lists are not 'equal and the assertion is *not negated* (when (and (not negation) (not (equal actual-face expected-face))) diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index ff03a365f9e..98e6b2cb1b6 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -30,126 +30,7 @@ (eval-when-compile (require 'cl-lib)) (require 'ert) -(require 'subr-x) ; string-trim - - -;;; Test buffers. - -(defun ert--text-button (string &rest properties) - "Return a string containing STRING as a text button with PROPERTIES. - -See `make-text-button'." - (with-temp-buffer - (insert string) - (apply #'make-text-button (point-min) (point-max) properties) - (buffer-string))) - -(defun ert--format-test-buffer-name (base-name) - "Compute a test buffer name based on BASE-NAME. - -Helper function for `ert--test-buffers'." - (format "*Test buffer (%s)%s*" - (or (and (ert-running-test) - (ert-test-name (ert-running-test))) - "<anonymous test>") - (if base-name - (format ": %s" base-name) - ""))) - -(defvar ert--test-buffers (make-hash-table :weakness t) - "Table of all test buffers. Keys are the buffer objects, values are t. - -The main use of this table is for `ert-kill-all-test-buffers'. -Not all buffers in this table are necessarily live, but all live -test buffers are in this table.") - -(define-button-type 'ert--test-buffer-button - 'action #'ert--test-buffer-button-action - 'help-echo "mouse-2, RET: Pop to test buffer") - -(defun ert--test-buffer-button-action (button) - "Pop to the test buffer that BUTTON is associated with." - (pop-to-buffer (button-get button 'ert--test-buffer))) - -(defun ert--call-with-test-buffer (ert--base-name ert--thunk) - "Helper function for `ert-with-test-buffer'. - -Create a test buffer with a name based on ERT--BASE-NAME and run -ERT--THUNK with that buffer as current." - (let* ((ert--buffer (generate-new-buffer - (ert--format-test-buffer-name ert--base-name))) - (ert--button (ert--text-button (buffer-name ert--buffer) - :type 'ert--test-buffer-button - 'ert--test-buffer ert--buffer))) - (puthash ert--buffer 't ert--test-buffers) - ;; We don't use `unwind-protect' here since we want to kill the - ;; buffer only on success. - (prog1 (with-current-buffer ert--buffer - (ert-info (ert--button :prefix "Buffer: ") - (funcall ert--thunk))) - (kill-buffer ert--buffer) - (remhash ert--buffer ert--test-buffers)))) - -(cl-defmacro ert-with-test-buffer ((&key ((:name name-form))) - &body body) - "Create a test buffer and run BODY in that buffer. - -To be used in ERT tests. If BODY finishes successfully, the test -buffer is killed; if there is an error, the test buffer is kept -around for further inspection. Its name is derived from -the name of the test and the result of NAME-FORM." - (declare (debug ((":name" form) def-body)) - (indent 1)) - `(ert--call-with-test-buffer ,name-form (lambda () ,@body))) - -(cl-defmacro ert-with-buffer-selected (buffer-or-name &body body) - "Display a buffer in a temporary selected window and run BODY. - -If BUFFER-OR-NAME is nil, the current buffer is used. - -The buffer is made the current buffer, and the temporary window -becomes the `selected-window', before BODY is evaluated. The -modification hooks `before-change-functions' and -`after-change-functions' are not inhibited during the evaluation -of BODY, which makes it easier to use `execute-kbd-macro' to -simulate user interaction. The window configuration is restored -before returning, even if BODY exits nonlocally. The return -value is the last form in BODY." - (declare (debug (form body)) (indent 1)) - `(save-window-excursion - (with-current-buffer (or ,buffer-or-name (current-buffer)) - (with-selected-window (display-buffer (current-buffer)) - ,@body)))) - -(cl-defmacro ert-with-test-buffer-selected ((&key name) &body body) - "Create a test buffer, switch to it, and run BODY. - -This combines `ert-with-test-buffer' and -`ert-with-buffer-selected'. The return value is the last form in -BODY." - (declare (debug ((":name" form) body)) (indent 1)) - `(ert-with-test-buffer (:name ,name) - (ert-with-buffer-selected (current-buffer) - ,@body))) - -;;;###autoload -(defun ert-kill-all-test-buffers () - "Kill all test buffers that are still live." - (interactive) - (let ((count 0)) - (maphash (lambda (buffer _dummy) - (when (or (not (buffer-live-p buffer)) - (kill-buffer buffer)) - (cl-incf count))) - ert--test-buffers) - (message "%s out of %s test buffers killed" - count (hash-table-count ert--test-buffers))) - ;; It could be that some test buffers were actually kept alive - ;; (e.g., due to `kill-buffer-query-functions'). I'm not sure what - ;; to do about this. For now, let's just forget them. - (clrhash ert--test-buffers) - nil) - +(require 'subr-x) ;;; Simulate commands. @@ -260,42 +141,11 @@ structure with the plists in ARGS." (string (let ((begin (point))) (insert x) (set-text-properties begin (point) current-plist))) - (list (unless (zerop (mod (length x) 2)) + (list (unless (evenp (length x)) (error "Odd number of args in plist: %S" x)) (setq current-plist x)))) (buffer-string))) - -(defun ert-call-with-buffer-renamed (buffer-name thunk) - "Protect the buffer named BUFFER-NAME from side-effects and run THUNK. - -Renames the buffer BUFFER-NAME to a new temporary name, creates a -new buffer named BUFFER-NAME, executes THUNK, kills the new -buffer, and renames the original buffer back to BUFFER-NAME. - -This is useful if THUNK has undesirable side-effects on an Emacs -buffer with a fixed name such as *Messages*." - (let ((new-buffer-name (generate-new-buffer-name - (format "%s orig buffer" buffer-name)))) - (with-current-buffer (get-buffer-create buffer-name) - (rename-buffer new-buffer-name)) - (unwind-protect - (progn - (get-buffer-create buffer-name) - (funcall thunk)) - (when (get-buffer buffer-name) - (kill-buffer buffer-name)) - (with-current-buffer new-buffer-name - (rename-buffer buffer-name))))) - -(cl-defmacro ert-with-buffer-renamed ((buffer-name-form) &body body) - "Protect the buffer named BUFFER-NAME from side-effects and run BODY. - -See `ert-call-with-buffer-renamed' for details." - (declare (indent 1)) - `(ert-call-with-buffer-renamed ,buffer-name-form (lambda () ,@body))) - - (defun ert-buffer-string-reindented (&optional buffer) "Return the contents of BUFFER after reindentation. @@ -329,9 +179,7 @@ This is useful for separating the issuance of messages by the code under test from the behavior of the *Messages* buffer." (declare (debug (symbolp body)) (indent 1)) - (let ((g-message-advice (gensym)) - (g-print-advice (gensym)) - (g-collector (gensym))) + (cl-with-gensyms (g-message-advice g-print-advice g-collector) `(let* ((,var "") (,g-collector (lambda (msg) (setq ,var (concat ,var msg)))) (,g-message-advice (ert--make-message-advice ,g-collector)) @@ -395,8 +243,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 +374,9 @@ 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"))) + (require 'ffap) + (declare-function ffap--gcc-is-clang-p "ffap" ()) + (ffap--gcc-is-clang-p)) (defvar tramp-default-host-alist) (defvar tramp-methods) @@ -548,6 +394,9 @@ The same keyword arguments are supported as in (cond ((getenv "REMOTE_TEMPORARY_FILE_DIRECTORY")) ((eq system-type 'windows-nt) null-device) + ;; Android's built-in shell is far too dysfunctional to support + ;; Tramp. + ((eq system-type 'android) null-device) (t (add-to-list 'tramp-methods '("mock" @@ -567,6 +416,19 @@ The same keyword arguments are supported as in (format "/mock::%s" temporary-file-directory)))) "Temporary directory for remote file tests.") + +;;;; Obsolete + +(cl-defmacro ert-with-test-buffer-selected ((&key name) &body body) + "Create a test buffer, switch to it, and run BODY. + +This combines `ert-with-test-buffer' and `ert-with-buffer-selected'. +The return value is the last form in BODY." + (declare (obsolete ert-with-test-buffer "31.1") + (debug ((":name" form) body)) (indent 1)) + `(ert-with-test-buffer (:name ,name :selected t) + ,@body)) + (provide 'ert-x) ;;; ert-x.el ends here diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 02551bad31f..c57bd0a69e2 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) @@ -576,7 +576,7 @@ Return nil if they are." (defun ert--significant-plist-keys (plist) "Return the keys of PLIST that have non-null values, in order." - (cl-assert (zerop (mod (length plist) 2)) t) + (cl-assert (evenp (length plist)) t) (cl-loop for (key value . rest) on plist by #'cddr unless (or (null value) (memq key accu)) collect key into accu finally (cl-return accu))) @@ -587,8 +587,8 @@ Return nil if they are." Returns nil if they are equivalent, i.e., have the same value for each key, where absent values are treated as nil. The order of key/value pairs in each list does not matter." - (cl-assert (zerop (mod (length a) 2)) t) - (cl-assert (zerop (mod (length b) 2)) t) + (cl-assert (evenp (length a)) t) + (cl-assert (evenp (length b)) t) ;; Normalizing the plists would be another way to do this but it ;; requires a total ordering on all lisp objects (since any object ;; is valid as a text property key). Perhaps defining such an @@ -1159,21 +1159,21 @@ Also changes the counters in STATS to match." (aref results pos)) (cl-etypecase (aref results pos) (ert-test-passed - (cl-incf (ert--stats-passed-expected stats) d)) + (incf (ert--stats-passed-expected stats) d)) (ert-test-failed - (cl-incf (ert--stats-failed-expected stats) d)) + (incf (ert--stats-failed-expected stats) d)) (ert-test-skipped - (cl-incf (ert--stats-skipped stats) d)) + (incf (ert--stats-skipped stats) d)) (null) (ert-test-aborted-with-non-local-exit) (ert-test-quit)) (cl-etypecase (aref results pos) (ert-test-passed - (cl-incf (ert--stats-passed-unexpected stats) d)) + (incf (ert--stats-passed-unexpected stats) d)) (ert-test-failed - (cl-incf (ert--stats-failed-unexpected stats) d)) + (incf (ert--stats-failed-unexpected stats) d)) (ert-test-skipped - (cl-incf (ert--stats-skipped stats) d)) + (incf (ert--stats-skipped stats) d)) (null) (ert-test-aborted-with-non-local-exit) (ert-test-quit))))) @@ -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--test (ert-test-file-name test))))) (let* ((buffer (car loc)) (point (cdr loc)) (file (file-relative-name (buffer-file-name buffer))) @@ -1423,7 +1419,7 @@ Returns the stats object." (message "%9s %S%s" (ert-string-for-test-result result nil) (ert-test-name test) - (if (cl-plusp + (if (plusp (length (getenv "EMACS_TEST_VERBOSE"))) (ert-reason-for-test-result result) "")))) @@ -1436,7 +1432,7 @@ Returns the stats object." (message "%9s %S%s" (ert-string-for-test-result result nil) (ert-test-name test) - (if (cl-plusp + (if (plusp (length (getenv "EMACS_TEST_VERBOSE"))) (ert-reason-for-test-result result) "")))) @@ -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" @@ -1688,8 +1684,8 @@ test packages depend on each other, it might be helpful.") (insert " </error>\n" " </testcase>\n" " </testsuite>\n") - (cl-incf errors 1) - (cl-incf id 1))) + (incf errors 1) + (incf id 1))) (insert-file-contents-literally test-report) (when (looking-at-p @@ -1697,15 +1693,15 @@ test packages depend on each other, it might be helpful.") (delete-region (point) (line-beginning-position 2))) (when (looking-at "<testsuites name=\".+\" tests=\"\\(.+\\)\" errors=\"\\(.+\\)\" failures=\"\\(.+\\)\" skipped=\"\\(.+\\)\" time=\"\\(.+\\)\">") - (cl-incf tests (string-to-number (match-string 1))) - (cl-incf errors (string-to-number (match-string 2))) - (cl-incf failures (string-to-number (match-string 3))) - (cl-incf skipped (string-to-number (match-string 4))) - (cl-incf time (string-to-number (match-string 5))) + (incf tests (string-to-number (match-string 1))) + (incf errors (string-to-number (match-string 2))) + (incf failures (string-to-number (match-string 3))) + (incf skipped (string-to-number (match-string 4))) + (incf time (string-to-number (match-string 5))) (delete-region (point) (line-beginning-position 2))) (when (looking-at " <testsuite id=\"\\(0\\)\"") (replace-match (number-to-string id) nil nil nil 1) - (cl-incf id 1)) + (incf id 1)) (goto-char (point-max)) (beginning-of-line 0) (when (looking-at-p "</testsuites>") @@ -2127,7 +2123,7 @@ non-nil, returns the face for expected results.." (defun ert-face-for-stats (stats) "Return a face that represents STATS." (cond ((ert--stats-aborted-p stats) 'nil) - ((cl-plusp (ert-stats-completed-unexpected stats)) + ((plusp (ert-stats-completed-unexpected stats)) (ert-face-for-test-result nil)) ((eql (ert-stats-completed-expected stats) (ert-stats-total stats)) (ert-face-for-test-result t)) @@ -2471,7 +2467,9 @@ To be used in the ERT results buffer." (defun ert--test-name-button-action (button) "Find the definition of the test BUTTON belongs to, in another window." - (let ((name (button-get button 'ert-test-name))) + ;; work with either ert-insert-test-name-button or help-xref-button + (let ((name (or (button-get button 'ert-test-name) + (car (button-get button 'help-args))))) (ert-find-test-other-window name))) (defun ert--ewoc-position (ewoc node) @@ -2818,7 +2816,8 @@ To be used in the ERT results buffer." (file-name-nondirectory file-name))) (save-excursion (re-search-backward (substitute-command-keys "`\\([^`']+\\)'")) - (help-xref-button 1 'help-function-def test-name file-name))) + (help-xref-button 1 'ert--test-name-button + test-name file-name))) (insert ".") (fill-region-as-paragraph (point-min) (point)) (insert "\n\n") @@ -2857,14 +2856,16 @@ To be used in the ERT results buffer." (ert--tests-running-mode-line-indicator)))) (add-hook 'emacs-lisp-mode-hook #'ert--activate-font-lock-keywords) -(defun ert--unload-function () +(defun ert-unload-function () "Unload function to undo the side-effects of loading ert.el." - (ert--remove-from-list 'find-function-regexp-alist 'ert-deftest :key #'car) + (ert--remove-from-list 'find-function-regexp-alist 'ert--test :key #'car) (ert--remove-from-list 'minor-mode-alist 'ert--current-run-stats :key #'car) (ert--remove-from-list 'emacs-lisp-mode-hook 'ert--activate-font-lock-keywords) nil) +;;; erts files. + (defun ert-test-erts-file (file &optional transform) "Parse FILE as a file containing before/after parts (an erts file). @@ -2910,10 +2911,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 +2922,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 +2938,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)))) @@ -2991,8 +2992,151 @@ write erts files." (forward-line 1))) (nreverse specs)))) -(defvar ert-unload-hook ()) -(add-hook 'ert-unload-hook #'ert--unload-function) + +;;; Buffer related helpers + +(defun ert--text-button (string &rest properties) + "Return a string containing STRING as a text button with PROPERTIES. + +See `make-text-button'." + (with-temp-buffer + (insert string) + (apply #'make-text-button (point-min) (point-max) properties) + (buffer-string))) + +(defun ert--format-test-buffer-name (base-name) + "Compute a test buffer name based on BASE-NAME. + +Helper function for `ert--test-buffers'." + (format "*Test buffer (%s)%s*" + (or (and (ert-running-test) + (ert-test-name (ert-running-test))) + "<anonymous test>") + (if base-name + (format ": %s" base-name) + ""))) + +(defvar ert--test-buffers (make-hash-table :weakness t) + "Table of all test buffers. Keys are the buffer objects, values are t. + +The main use of this table is for `ert-kill-all-test-buffers'. +Not all buffers in this table are necessarily live, but all live +test buffers are in this table.") + +(define-button-type 'ert--test-buffer-button + 'action #'ert--test-buffer-button-action + 'help-echo "mouse-2, RET: Pop to test buffer") + +(defun ert--test-buffer-button-action (button) + "Pop to the test buffer that BUTTON is associated with." + (pop-to-buffer (button-get button 'ert--test-buffer))) + +(defun ert--call-with-test-buffer (ert--base-name ert--thunk) + "Helper function for `ert-with-test-buffer'. + +Create a test buffer with a name based on ERT--BASE-NAME and run +ERT--THUNK with that buffer as current." + (let* ((ert--buffer (generate-new-buffer + (ert--format-test-buffer-name ert--base-name))) + (ert--button (ert--text-button (buffer-name ert--buffer) + :type 'ert--test-buffer-button + 'ert--test-buffer ert--buffer))) + (puthash ert--buffer 't ert--test-buffers) + ;; We don't use `unwind-protect' here since we want to kill the + ;; buffer only on success. + (prog1 (with-current-buffer ert--buffer + (ert-info (ert--button :prefix "Buffer: ") + (funcall ert--thunk))) + (kill-buffer ert--buffer) + (remhash ert--buffer ert--test-buffers)))) + +(cl-defmacro ert-with-test-buffer ((&key ((:name name-form)) + ((:selected select-form))) + &body body) + "Create a test buffer and run BODY in that buffer. + +To be used in ERT tests. If BODY finishes successfully, the test buffer +is killed; if there is an error, the test buffer is kept around for +further inspection. The name of the buffer is derived from the name of +the test and the result of NAME-FORM. + +If SELECT-FORM is non-nil, switch to the test buffer before running +BODY, as if body was in `ert-with-buffer-selected'. + +The return value is the last form in BODY." + (declare (debug ((":name" form) (":selected" form) def-body)) + (indent 1)) + `(ert--call-with-test-buffer + ,name-form + ,(if select-form + `(lambda () (ert-with-buffer-selected (current-buffer) + ,@body)) + `(lambda () ,@body)))) + +(defun ert-kill-all-test-buffers () + "Kill all test buffers that are still live." + (interactive) + (let ((count 0)) + (maphash (lambda (buffer _dummy) + (when (or (not (buffer-live-p buffer)) + (kill-buffer buffer)) + (incf count))) + ert--test-buffers) + (message "%s out of %s test buffers killed" + count (hash-table-count ert--test-buffers))) + ;; It could be that some test buffers were actually kept alive + ;; (e.g., due to `kill-buffer-query-functions'). I'm not sure what + ;; to do about this. For now, let's just forget them. + (clrhash ert--test-buffers) + nil) + +(cl-defmacro ert-with-buffer-selected (buffer-or-name &body body) + "Display a buffer in a temporary selected window and run BODY. + +If BUFFER-OR-NAME is nil, the current buffer is used. + +The buffer is made the current buffer, and the temporary window +becomes the `selected-window', before BODY is evaluated. The +modification hooks `before-change-functions' and +`after-change-functions' are not inhibited during the evaluation +of BODY, which makes it easier to use `execute-kbd-macro' to +simulate user interaction. The window configuration is restored +before returning, even if BODY exits nonlocally. The return +value is the last form in BODY." + (declare (debug (form body)) (indent 1)) + `(save-window-excursion + (with-current-buffer (or ,buffer-or-name (current-buffer)) + (with-selected-window (display-buffer (current-buffer)) + ,@body)))) + +(defun ert-call-with-buffer-renamed (buffer-name thunk) + "Protect the buffer named BUFFER-NAME from side-effects and run THUNK. + +Renames the buffer BUFFER-NAME to a new temporary name, creates a +new buffer named BUFFER-NAME, executes THUNK, kills the new +buffer, and renames the original buffer back to BUFFER-NAME. + +This is useful if THUNK has undesirable side-effects on an Emacs +buffer with a fixed name such as *Messages*." + (let ((new-buffer-name (generate-new-buffer-name + (format "%s orig buffer" buffer-name)))) + (with-current-buffer (get-buffer-create buffer-name) + (rename-buffer new-buffer-name)) + (unwind-protect + (progn + (get-buffer-create buffer-name) + (funcall thunk)) + (when (get-buffer buffer-name) + (kill-buffer buffer-name)) + (with-current-buffer new-buffer-name + (rename-buffer buffer-name))))) + +(cl-defmacro ert-with-buffer-renamed ((buffer-name-form) &body body) + "Protect the buffer named BUFFER-NAME from side-effects and run BODY. + +See `ert-call-with-buffer-renamed' for details." + (declare (indent 1)) + `(ert-call-with-buffer-renamed ,buffer-name-form (lambda () ,@body))) ;;; Obsolete @@ -3001,6 +3145,8 @@ write erts files." (put 'ert-equal-including-properties 'ert-explainer 'ert--explain-equal-including-properties) +(define-obsolete-function-alias 'ert--unload-function 'ert-unload-function "31.1") + (provide 'ert) ;;; ert.el ends here diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 0a2717dfc67..455095c9be6 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: ;; @@ -123,15 +123,6 @@ should insert the feature name." :group 'xref :version "25.1") -(defcustom find-ert-deftest-regexp - "(ert-deftest +'%s" - "The regexp used to search for an `ert-deftest' definition. -Note it must contain a `%s' at the place where `format' -should insert the feature name." - :type 'regexp - :group 'xref - :version "29.1") - (defun find-function--defface (symbol) (catch 'found (while (re-search-forward (format find-face-regexp symbol) nil t) @@ -145,14 +136,17 @@ should insert the feature name." (defvar . find-variable-regexp) (defface . find-function--defface) (feature . find-feature-regexp) - (defalias . find-alias-regexp) - (ert-deftest . find-ert-deftest-regexp)) + (defalias . find-alias-regexp)) "Alist mapping definition types into regexp variables. Each regexp variable's value should actually be a format string to be used to substitute the desired symbol name into the regexp. Instead of regexp variable, types can be mapped to functions as well, in which case the function is called with one argument (the object -we're looking for) and it should search for it.") +we're looking for) and it should search for it. + +Symbols can have their own version of this alist on +the property `find-function-type-alist'. +See the function `find-function-update-type-alist'.") (put 'find-function-regexp-alist 'risky-local-variable t) (define-obsolete-variable-alias 'find-function-source-path @@ -193,6 +187,21 @@ for completion." :version "29.1" :group 'find-function) +(defcustom find-function-mode-lower-precedence nil + "If non-nil, `find-function-mode' defines keys in the global map. +This is for compatibility with the historical behavior of +the old `find-function-setup-keys'." + :type 'boolean + :version "31.1" + :group 'find-function + :set (lambda (symbol value) + ;; Toggle the mode off before changing this setting in order to + ;; avoid getting into an inconsistent state. + (let ((already-on find-function-mode)) + (when already-on (find-function-mode -1)) + (set-default symbol value) + (when already-on (find-function-mode 1))))) + ;;; Functions: (defun find-library-suffixes () @@ -323,6 +332,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 +362,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." @@ -396,9 +409,12 @@ See `find-library' for more details." Visit the library in a buffer, and return a cons cell (BUFFER . POSITION), or just (BUFFER . nil) if the definition can't be found in the file. -If TYPE is nil, look for a function definition. -Otherwise, TYPE specifies the kind of definition, -and it is interpreted via `find-function-regexp-alist'. +If TYPE is nil, look for a function definition, +otherwise, TYPE specifies the kind of definition. +TYPE is looked up in SYMBOL's property `find-function-type-alist' +(which can be maintained with `find-function-update-type-alist') +or the variable `find-function-regexp-alist'. + The search is done in the source for library LIBRARY." (if (null library) (error "Don't know where `%s' is defined" symbol)) @@ -415,7 +431,10 @@ The search is done in the source for library LIBRARY." (when (string-match "\\.emacs\\(.el\\)\\'" library) (setq library (substring library 0 (match-beginning 1)))) (let* ((filename (find-library-name library)) - (regexp-symbol (cdr (assq type find-function-regexp-alist)))) + (regexp-symbol + (or (and (symbolp symbol) + (alist-get type (get symbol 'find-function-type-alist))) + (alist-get type find-function-regexp-alist)))) (with-current-buffer (find-file-noselect filename) (let ((regexp (if (functionp regexp-symbol) regexp-symbol (format (symbol-value regexp-symbol) @@ -457,6 +476,13 @@ The search is done in the source for library LIBRARY." (find-function--search-by-expanding-macros (current-buffer) symbol type)))))))))) +;;;###autoload +(defun find-function-update-type-alist (symbol type variable) + "Update SYMBOL property `find-function-type-alist' with (TYPE . VARIABLE). +Property `find-function-type-alist' is a symbol-specific version +of variable `find-function-regexp-alist' and has the same format." + (setf (alist-get type (get symbol 'find-function-type-alist)) variable)) + (defun find-function--try-macroexpand (form) "Try to macroexpand FORM in full or partially. This is a best-effort operation in which if macroexpansion fails, @@ -575,6 +601,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 +627,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. @@ -795,21 +827,47 @@ See `find-function-on-key'." (when (and symb (not (equal symb 0))) (find-variable-other-window symb)))) +(defvar-keymap find-function-mode-map + :doc "Keymap for `find-function-mode'." + "C-x F" #'find-function + "C-x 4 F" #'find-function-other-window + "C-x 5 F" #'find-function-other-frame + + "C-x K" #'find-function-on-key + "C-x 4 K" #'find-function-on-key-other-window + "C-x 5 K" #'find-function-on-key-other-frame + + "C-x V" #'find-variable + "C-x 4 V" #'find-variable-other-window + "C-x 5 V" #'find-variable-other-frame + + "C-x L" #'find-library + "C-x 4 L" #'find-library-other-window + "C-x 5 L" #'find-library-other-frame) + +;;;###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 + (when find-function-mode-lower-precedence + (rplacd (assq 'find-function-mode minor-mode-map-alist) + (if find-function-mode + (make-sparse-keymap) + find-function-mode-map)) + (let ((parent (keymap-parent (current-global-map)))) + (if find-function-mode + (unless (memq find-function-mode-map parent) + (setf (keymap-parent (current-global-map)) + (make-composed-keymap (list find-function-mode-map + parent)))) + (when (memq find-function-mode-map parent) + (delq find-function-mode-map parent)))))) + ;;;###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/float-sup.el b/lisp/emacs-lisp/float-sup.el index bb820a2d82b..b5ee4e34dbb 100644 --- a/lisp/emacs-lisp/float-sup.el +++ b/lisp/emacs-lisp/float-sup.el @@ -25,13 +25,12 @@ ;;; Code: -;; Provide an easy hook to tell if we are running with floats or not. ;; Define pi and e via math-lib calls (much less prone to killer typos). (defconst float-pi (* 4 (atan 1)) "The value of Pi (3.1415926...).") (with-suppressed-warnings ((lexical pi)) (defconst pi float-pi "Obsolete since Emacs-23.3. Use `float-pi' instead.")) -(make-obsolete-variable 'pi 'float-pi "23.3") +(make-obsolete-variable 'pi 'float-pi "23.3") ; "28.1" (internal-make-var-non-special 'pi) (defconst float-e (exp 1) "The value of e (2.7182818...).") diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index b7b54b2a6b1..8e69c8d0447 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -182,7 +182,7 @@ If CURRENT-NAME is a string, that is the `use instead' message. WHEN should be a string indicating when the variable was first made obsolete, for example a date or a release number." (put obsolete-name 'byte-obsolete-generalized-variable - (purecopy (list current-name when))) + (list current-name when)) obsolete-name) ;; Additions for `declare'. We specify the values as named aliases so @@ -294,7 +294,7 @@ The return value is the last VAL in the list. \(fn PLACE VAL PLACE VAL ...)" (declare (debug (&rest [gv-place form]))) - (if (/= (logand (length args) 1) 0) + (if (oddp (length args)) (signal 'wrong-number-of-arguments (list 'setf (length args)))) (if (and args (null (cddr args))) (let ((place (pop args)) @@ -315,17 +315,29 @@ The return value is the last VAL in the list. ;; `(if (member ,v ,getter) nil ;; ,(funcall setter `(cons ,v ,getter)))))) -;; (defmacro gv-inc! (place &optional val) -;; "Increment PLACE by VAL (default to 1)." -;; (declare (debug (gv-place &optional form))) -;; (gv-letplace (getter setter) place -;; (funcall setter `(+ ,getter ,(or val 1))))) +;;;###autoload +(defmacro incf (place &optional delta) + "Increment PLACE by DELTA (default to 1). -;; (defmacro gv-dec! (place &optional val) -;; "Decrement PLACE by VAL (default to 1)." -;; (declare (debug (gv-place &optional form))) -;; (gv-letplace (getter setter) place -;; (funcall setter `(- ,getter ,(or val 1))))) +The DELTA is first added to PLACE, and then stored in PLACE. +Return the incremented value of PLACE. + +See also `decf'." + (declare (debug (gv-place &optional form))) + (gv-letplace (getter setter) place + (funcall setter `(+ ,getter ,(or delta 1))))) + +;;;###autoload +(defmacro decf (place &optional delta) + "Decrement PLACE by DELTA (default to 1). + +The DELTA is first subtracted from PLACE, and then stored in PLACE. +Return the decremented value of PLACE. + +See also `incf'." + (declare (debug (gv-place &optional form))) + (gv-letplace (getter setter) place + (funcall setter `(- ,getter ,(or delta 1))))) ;; For Edebug, the idea is to let Edebug instrument gv-places just like it does ;; for normal expressions, and then give it a gv-expander to DTRT. @@ -388,13 +400,15 @@ The return value is the last VAL in the list. (gv-define-simple-setter match-data set-match-data 'fix) (gv-define-simple-setter overlay-get overlay-put) (gv-define-setter overlay-start (store ov) - `(progn (move-overlay ,ov ,store (overlay-end ,ov)) ,store)) + (macroexp-let2 nil store store + `(progn (move-overlay ,ov ,store (overlay-end ,ov)) ,store))) (gv-define-setter overlay-end (store ov) - `(progn (move-overlay ,ov (overlay-start ,ov) ,store) ,store)) + (macroexp-let2 nil store store + `(progn (move-overlay ,ov (overlay-start ,ov) ,store) ,store))) (gv-define-simple-setter process-buffer set-process-buffer) (gv-define-simple-setter process-filter set-process-filter) (gv-define-simple-setter process-sentinel set-process-sentinel) -(gv-define-simple-setter process-get process-put) +(gv-define-simple-setter process-get process-put 'fix) (gv-define-simple-setter window-parameter set-window-parameter) (gv-define-setter window-buffer (v &optional w) (macroexp-let2 nil v v diff --git a/lisp/emacs-lisp/helper.el b/lisp/emacs-lisp/helper.el index d8f758d2fe5..8a173219545 100644 --- a/lisp/emacs-lisp/helper.el +++ b/lisp/emacs-lisp/helper.el @@ -80,7 +80,7 @@ (recenter)) ((and (or (eq continue 'backspace) (eq continue ?\177)) - (zerop (% state 2))) + (evenp state)) (scroll-down)) (t (setq continue nil)))))))) 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 15a9bb89a42..b79c2e51de9 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..111d512ef59 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,36 @@ package version (a string)." (lm--prepare-package-dependencies (package-read-from-string (mapconcat #'identity require-lines " ")))))) +(defun lm-package-version (&optional file) + "Return \"Package-Version\" or \"Version\" header. +Prefer Package-Version; if defined, the package author +probably wants us to use it. Otherwise try Version." + (lm-with-file file + (or (lm-header "package-version") (lm-header "version")))) + +(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 +564,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 +582,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 +623,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") @@ -637,8 +668,6 @@ which do not include a recognizable synopsis." (lm-summary)) (when must-kill (kill-buffer (current-buffer)))))))) -(defvar report-emacs-bug-address) - (defun lm-report-bug (topic) "Report a bug in the package currently being visited to its maintainer. Prompts for bug subject TOPIC. Leaves you in a mail buffer." @@ -663,6 +692,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..006b713ae6e 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -94,68 +94,67 @@ (defvar lisp-imenu-generic-expression (list (list nil - (purecopy (concat "^\\s-*(" - (regexp-opt - '("defun" "defmacro" - ;; Elisp. - "defun*" "defsubst" "define-inline" - "define-advice" "defadvice" "define-skeleton" - "define-compilation-mode" "define-minor-mode" - "define-global-minor-mode" - "define-globalized-minor-mode" - "define-derived-mode" "define-generic-mode" - "ert-deftest" - "cl-defun" "cl-defsubst" "cl-defmacro" - "cl-define-compiler-macro" "cl-defgeneric" - "cl-defmethod" - ;; CL. - "define-compiler-macro" "define-modify-macro" - "defsetf" "define-setf-expander" - "define-method-combination" - ;; CLOS and EIEIO - "defgeneric" "defmethod") - t) - "\\s-+\\(" (rx lisp-mode-symbol) "\\)")) + (concat "^\\s-*(" + (regexp-opt + '("defun" "defmacro" + ;; Elisp. + "defun*" "defsubst" "define-inline" + "define-advice" "defadvice" "define-skeleton" + "define-compilation-mode" "define-minor-mode" + "define-globalized-minor-mode" + "define-derived-mode" "define-generic-mode" + "ert-deftest" + "cl-defun" "cl-defsubst" "cl-defmacro" + "cl-define-compiler-macro" "cl-defgeneric" + "cl-defmethod" + ;; CL. + "define-compiler-macro" "define-modify-macro" + "defsetf" "define-setf-expander" + "define-method-combination" + ;; CLOS and EIEIO + "defgeneric" "defmethod") + t) + "\\s-+\\(" (rx lisp-mode-symbol) "\\)") 2) ;; Like the previous, but uses a quoted symbol as the name. (list nil - (purecopy (concat "^\\s-*(" - (regexp-opt - '("defalias" "define-obsolete-function-alias") - t) - "\\s-+'\\(" (rx lisp-mode-symbol) "\\)")) + (concat "^\\s-*(" + (regexp-opt + '("defalias" "define-obsolete-function-alias") + t) + "\\s-+'\\(" (rx lisp-mode-symbol) "\\)") 2) - (list (purecopy "Variables") - (purecopy (concat "^\\s-*(" - (regexp-opt - '(;; Elisp - "defconst" "defcustom" "defvar-keymap" - ;; CL - "defconstant" - "defparameter" "define-symbol-macro") - t) - "\\s-+\\(" (rx lisp-mode-symbol) "\\)")) + (list "Variables" + (concat "^\\s-*(" + (regexp-opt + '(;; Elisp + "defconst" "defcustom" "defvar-keymap" + ;; CL + "defconstant" + "defparameter" "define-symbol-macro") + t) + "\\s-+\\(" (rx lisp-mode-symbol) "\\)") 2) ;; For `defvar'/`defvar-local', we ignore (defvar FOO) constructs. - (list (purecopy "Variables") - (purecopy (concat "^\\s-*(defvar\\(?:-local\\)?\\s-+\\(" - (rx lisp-mode-symbol) "\\)" - "[[:space:]\n]+[^)]")) + (list "Variables" + (concat "^\\s-*(defvar\\(?:-local\\)?\\s-+\\(" + (rx lisp-mode-symbol) "\\)" + "[[:space:]\n]+[^)]") 1) - (list (purecopy "Types") - (purecopy (concat "^\\s-*(" - (regexp-opt - '(;; Elisp - "defgroup" "deftheme" - "define-widget" "define-error" - "defface" "cl-deftype" "cl-defstruct" - ;; CL - "deftype" "defstruct" - "define-condition" "defpackage" - ;; CLOS and EIEIO - "defclass") - t) - "\\s-+'?\\(" (rx lisp-mode-symbol) "\\)")) + (list "Types" + (concat "^\\s-*(" + (regexp-opt + '(;; Elisp + "defgroup" "deftheme" + "define-widget" "define-error" + "defface" "cl-deftype" "cl-defstruct" + ;; CL + "deftype" "defstruct" + "define-condition" "defpackage" + ;; CLOS and EIEIO + "defclass") + t) + "\\s-+'?\\(" (rx lisp-mode-symbol) "\\)") 2)) "Imenu generic expression for Lisp mode. See `imenu-generic-expression'.") @@ -308,7 +307,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) @@ -352,7 +351,7 @@ This will generate compile-time constants from BINDINGS." (el-fdefs '("defsubst" "cl-defsubst" "define-inline" "define-advice" "defadvice" "defalias" "define-derived-mode" "define-minor-mode" - "define-generic-mode" "define-global-minor-mode" + "define-generic-mode" "define-globalized-minor-mode" "define-skeleton" "define-widget" "ert-deftest")) (el-vdefs '("defconst" "defcustom" "defvaralias" "defvar-local" @@ -490,14 +489,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). ("\\(\\\\\\)\\([^\"\\]\\)" @@ -511,10 +513,10 @@ This will generate compile-time constants from BINDINGS." ;; Constant values. (,(lambda (bound) (lisp-mode--search-key ":" bound)) (0 font-lock-builtin-face)) - ;; ELisp and CLisp `&' keywords as types. + ;; Elisp and Common Lisp `&' keywords as types. (,(lambda (bound) (lisp-mode--search-key "&" bound)) (0 font-lock-type-face)) - ;; ELisp regexp grouping constructs + ;; Elisp regexp grouping constructs (,(lambda (bound) (catch 'found ;; The following loop is needed to continue searching after matches @@ -556,7 +558,9 @@ This will generate compile-time constants from BINDINGS." (,(concat "(" cl-errs-re "\\_>") (1 font-lock-warning-face)) ;; Words inside ‘’ and `' tend to be symbol names. - (,(concat "[`‘]\\(" (rx lisp-mode-symbol) "\\)['’]") + (,(concat "[`‘]\\(" + (rx (* lisp-mode-symbol (+ space)) lisp-mode-symbol) + "\\)['’]") (1 font-lock-constant-face prepend)) ;; Uninterned symbols, e.g., (defpackage #:my-package ...) ;; must come before keywords below to have effect @@ -564,10 +568,10 @@ This will generate compile-time constants from BINDINGS." ;; Constant values. (,(lambda (bound) (lisp-mode--search-key ":" bound)) (0 font-lock-builtin-face)) - ;; ELisp and CLisp `&' keywords as types. + ;; Elisp and Common Lisp `&' keywords as types. (,(lambda (bound) (lisp-mode--search-key "&" bound)) (0 font-lock-type-face)) - ;; ELisp regexp grouping constructs + ;; Elisp regexp grouping constructs ;; This is too general -- rms. ;; A user complained that he has functions whose names start with `do' ;; and that they get the wrong color. @@ -657,9 +661,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 +1157,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 +1175,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. @@ -1428,6 +1432,20 @@ Any non-integer value means do not use a different value of :group 'lisp :version "30.1") +(defvar lisp-fill-paragraphs-as-doc-string t + "Whether `lisp-fill-paragraph' should fill strings as Elisp doc strings. +The default behavior of `lisp-fill-paragraph' is tuned for filling Emacs +Lisp doc strings, with their special treatment for the first line. +Specifically, strings are filled in a narrowed context to avoid filling +surrounding code, which means any leading indent is disregarded, which +can cause the filled string to extend passed the configured +`fill-column' variable value. If you would rather fill the string in +its original context, disregarding the special conventions of Elisp doc +strings, and want to ensure the `fill-column' value is more strictly +respected, set this variable to nil. Doing so makes +`lisp-fill-paragraph' behave as it used to in Emacs 27 and prior +versions.") + (defun lisp-fill-paragraph (&optional justify) "Like \\[fill-paragraph], but handle Emacs Lisp comments and docstrings. If any of the current line is a comment, fill the comment or the @@ -1477,42 +1495,44 @@ and initial semicolons." (derived-mode-p 'emacs-lisp-mode)) emacs-lisp-docstring-fill-column fill-column))) - (let ((ppss (syntax-ppss)) - (start (point)) - ;; Avoid recursion if we're being called directly with - ;; `M-x lisp-fill-paragraph' in an `emacs-lisp-mode' buffer. - (fill-paragraph-function t)) + (let* ((ppss (syntax-ppss)) + (start (point)) + ;; Avoid recursion if we're being called directly with + ;; `M-x lisp-fill-paragraph' in an `emacs-lisp-mode' buffer. + (fill-paragraph-function t) + (string-start (ppss-comment-or-string-start ppss))) (save-excursion (save-restriction ;; If we're not inside a string, then do very basic ;; filling. This avoids corrupting embedded strings in ;; code. - (if (not (ppss-comment-or-string-start ppss)) + (if (not string-start) (lisp--fill-line-simple) - ;; If we're in a string, then narrow (roughly) to that - ;; string before filling. This avoids filling Lisp - ;; statements that follow the string. - (when (ppss-string-terminator ppss) - (goto-char (ppss-comment-or-string-start ppss)) - ;; The string may be unterminated -- in that case, don't - ;; narrow. - (when (ignore-errors - (progn - (forward-sexp 1) - t)) - (narrow-to-region (1+ (ppss-comment-or-string-start ppss)) - (1- (point))))) - ;; Move back to where we were. - (goto-char start) - ;; We should fill the first line of a string - ;; separately (since it's usually a doc string). - (if (= (line-number-at-pos) 1) - (narrow-to-region (line-beginning-position) - (line-beginning-position 2)) - (save-excursion - (goto-char (point-min)) - (forward-line 1) - (narrow-to-region (point) (point-max)))) + (when lisp-fill-paragraphs-as-doc-string + ;; If we're in a string, then narrow (roughly) to that + ;; string before filling. This avoids filling Lisp + ;; statements that follow the string. + (when (ppss-string-terminator ppss) + (goto-char string-start) + ;; The string may be unterminated -- in that case, don't + ;; narrow. + (when (ignore-errors + (progn + (forward-sexp 1) + t)) + (narrow-to-region (1+ string-start) + (1- (point))))) + ;; Move back to where we were. + (goto-char start) + ;; We should fill the first line of a string + ;; separately (since it's usually a doc string). + (if (= (line-number-at-pos) 1) + (narrow-to-region (line-beginning-position) + (line-beginning-position 2)) + (save-excursion + (goto-char (point-min)) + (forward-line 1) + (narrow-to-region (point) (point-max))))) (fill-paragraph justify))))))) ;; Never return nil. t) 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..8a131bf885f 100644 --- a/lisp/emacs-lisp/loaddefs-gen.el +++ b/lisp/emacs-lisp/loaddefs-gen.el @@ -2,6 +2,7 @@ ;; Copyright (C) 2022-2025 Free Software Foundation, Inc. +;; Maintainer: emacs-devel@gnu.org ;; Keywords: maint ;; Package: emacs @@ -197,11 +198,14 @@ expression, in which case we want to handle forms differently." (when exps (cons 'progn exps))))) ;; For complex cases, try again on the macro-expansion. - ((and (memq car '(easy-mmode-define-global-mode define-global-minor-mode - define-globalized-minor-mode defun defmacro - easy-mmode-define-minor-mode define-minor-mode - define-inline cl-defun cl-defmacro cl-defgeneric - cl-defstruct pcase-defmacro iter-defun cl-iter-defun)) + ((and (memq car '( define-globalized-minor-mode defun defmacro + define-minor-mode define-inline + cl-defun cl-defmacro cl-defgeneric + cl-defstruct pcase-defmacro iter-defun cl-iter-defun + ;; Obsolete; keep until the alias is removed. + easy-mmode-define-global-mode + easy-mmode-define-minor-mode + define-global-minor-mode)) (macrop car) (setq expand (let ((load-true-file-name file) (load-file-name file)) @@ -211,15 +215,18 @@ expression, in which case we want to handle forms differently." (loaddefs-generate--make-autoload expand file 'expansion)) ;; For special function-like operators, use the `autoload' function. - ((memq car '(define-skeleton define-derived-mode + ((memq car '( define-skeleton define-derived-mode define-compilation-mode define-generic-mode - easy-mmode-define-global-mode define-global-minor-mode - define-globalized-minor-mode - easy-mmode-define-minor-mode define-minor-mode + define-globalized-minor-mode + define-minor-mode cl-defun defun* cl-defmacro defmacro* define-overloadable-function transient-define-prefix transient-define-suffix - transient-define-infix transient-define-argument)) + transient-define-infix transient-define-argument + ;; Obsolete; keep until the alias is removed. + easy-mmode-define-global-mode + easy-mmode-define-minor-mode + define-global-minor-mode)) (let* ((macrop (memq car '(defmacro cl-defmacro defmacro*))) (name (nth 1 form)) (args (pcase car @@ -243,17 +250,18 @@ expression, in which case we want to handle forms differently." (loaddefs-generate--shorten-autoload `(autoload ,(if (listp name) name (list 'quote name)) ,file ,doc - ,(or (and (memq car '(define-skeleton define-derived-mode + ,(or (and (memq car '( define-skeleton define-derived-mode define-generic-mode - easy-mmode-define-global-mode - define-global-minor-mode define-globalized-minor-mode - easy-mmode-define-minor-mode define-minor-mode transient-define-prefix transient-define-suffix transient-define-infix - transient-define-argument)) + transient-define-argument + ;; Obsolete; keep until the alias is removed. + easy-mmode-define-global-mode + easy-mmode-define-minor-mode + define-global-minor-mode)) t) (and (eq (car-safe (car body)) 'interactive) ;; List of modes or just t. @@ -295,7 +303,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 +421,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 @@ -441,7 +449,7 @@ don't include." (file-name-sans-extension (file-name-nondirectory file))))) (push (list (or local-outfile main-outfile) file - `(push (purecopy ',(cons (intern package) version)) + `(push ',(cons (intern package) version) package--builtin-versions)) defs)))) @@ -499,7 +507,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..64ec634620a 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)) @@ -434,7 +435,7 @@ Assumes the caller has bound `macroexpand-all-environment'." ;; Malformed code is translated to code that signals an error ;; at run time. (let ((nargs (length args))) - (if (/= (logand nargs 1) 0) + (if (oddp nargs) (macroexp-warn-and-return (format-message "odd number of arguments in `setq' form") `(signal 'wrong-number-of-arguments '(setq ,nargs)) @@ -728,7 +729,7 @@ test of free variables in the following ways: - It does not distinguish variables from functions, so it can be used both to detect whether a given variable is used by SEXP and to detect whether a given function is used by SEXP. -- It does not actually know ELisp syntax, so it only looks for the presence +- It does not actually know Elisp syntax, so it only looks for the presence of symbols in SEXP and can't distinguish if those symbols are truly references to the given variable (or function). That can make the result include bindings which actually aren't used. diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index 5b9ffe3a03d..952497032a2 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 @@ -180,16 +185,23 @@ The function's value is the number of actions taken." (let ((overriding-text-conversion-style nil)) (when (fboundp 'set-text-conversion-style) (set-text-conversion-style text-conversion-style)) - (setq char (read-event))) + ;; Do NOT use read-event here. That + ;; function does not consult + ;; input-decode-map (bug#75886). + (setq char (read-key)) + (when (eq char ?\C-g) + (signal 'quit nil))) (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 +276,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/memory-report.el b/lisp/emacs-lisp/memory-report.el index 5b9a590c7de..8ca7c0e5f0a 100644 --- a/lisp/emacs-lisp/memory-report.el +++ b/lisp/emacs-lisp/memory-report.el @@ -168,7 +168,7 @@ by counted more than once." (total 0)) (mapatoms (lambda (symbol) - (cl-incf total (memory-report--object-size + (incf total (memory-report--object-size counted (symbol-plist symbol)))) obarray) (list @@ -217,16 +217,16 @@ by counted more than once." (let ((total 0) (size (memory-report--size 'cons))) (while value - (cl-incf total size) + (incf total size) (setf (gethash value counted) t) (when (car value) - (cl-incf total (memory-report--object-size counted (car value)))) + (incf total (memory-report--object-size counted (car value)))) (let ((next (cdr value))) (setq value (when next (if (consp next) (unless (gethash next counted) (cdr value)) - (cl-incf total (memory-report--object-size + (incf total (memory-report--object-size counted next)) nil))))) total)) @@ -235,7 +235,7 @@ by counted more than once." (let ((total (+ (memory-report--size 'vector) (* (memory-report--size 'object) (length value))))) (cl-loop for elem across value - do (cl-incf total (memory-report--object-size counted elem))) + do (incf total (memory-report--object-size counted elem))) total)) (cl-defmethod memory-report--object-size-1 (counted (value hash-table)) @@ -243,8 +243,8 @@ by counted more than once." (* (memory-report--size 'object) (hash-table-size value))))) (maphash (lambda (key elem) - (cl-incf total (memory-report--object-size counted key)) - (cl-incf total (memory-report--object-size counted elem))) + (incf total (memory-report--object-size counted key)) + (incf total (memory-report--object-size counted elem))) value) total)) 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/nadvice.el b/lisp/emacs-lisp/nadvice.el index 150332c4c5d..1172338e7ca 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -151,7 +151,8 @@ DOC is a string where \"FUNCTION\" and \"OLDFUN\" are expected.") ;; definition is loaded]", bug#21299 (if (stringp arglist) t (help--make-usage-docstring function arglist))) - (setq origdoc (cdr usage)) (car usage))) + (setq origdoc (cdr usage)) + (car usage))) (help-add-fundoc-usage (with-temp-buffer (when before @@ -319,7 +320,10 @@ These functions act like the t special value in buffer-local hooks.") ((symbolp place) `(default-value ',place)) (t place)))) -(defun nadvice--make-docstring (sym) +(defun advice--make-nadvice-docstring (sym) + "Make docstring for a nadvice function. +Modifies the function's docstring by replacing \"<<>>\" with the +description of the possible HOWs." (let* ((main (documentation (symbol-function sym) 'raw)) (ud (help-split-fundoc main 'pcase)) (doc (or (cdr ud) main)) @@ -340,7 +344,7 @@ These functions act like the t special value in buffer-local hooks.") (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc))) (put 'add-function 'function-documentation - '(nadvice--make-docstring 'add-function)) + '(advice--make-nadvice-docstring 'add-function)) ;;;###autoload (defmacro add-function (how place function &optional props) @@ -498,7 +502,7 @@ of the piece of advice." (funcall fsetfun symbol newdef)))) (put 'advice-add 'function-documentation - '(nadvice--make-docstring 'advice-add)) + '(advice--make-nadvice-docstring 'advice-add)) ;;;###autoload (defun advice-add (symbol how function &optional props) diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index 0be0a307115..d38429648e6 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -125,7 +125,7 @@ (it (make-hash-table :test #'eq))) (dolist (desc slotdescs) (let* ((slot (cl--slot-descriptor-name desc))) - (cl-incf i) + (incf i) (when (gethash slot it) (error "Duplicate slot name: %S" slot)) (setf (gethash slot it) i))) @@ -305,7 +305,7 @@ list of slot properties. The currently known properties are the following: ;; Always use a double hyphen: if users wants to ;; make it public, they can do so with an alias. (aname (intern (format "%S--%S" name slot)))) - (cl-incf i) + (incf i) (if (not mutable) `(defalias ',aname ;; We use `oclosure--copy' instead of @@ -555,7 +555,7 @@ immutable fields are indeed not mutated." (defun cconv--interactive-helper (fun if) "Add interactive \"form\" IF to FUN. Returns a new command that otherwise behaves like FUN. -IF can be an ELisp form to be interpreted or a function of no arguments." +IF can be a Lisp form to be interpreted or a function of no arguments." (oclosure-lambda (cconv--interactive-helper (fun fun) (if if)) (&rest args) (apply (if (called-interactively-p 'any) diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index ac78c5af4e4..daceb4eb9c0 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 @@ -323,7 +271,11 @@ asynchronously." (defun package-vc--generate-description-file (pkg-desc pkg-file) "Generate a package description file for PKG-DESC and write it to PKG-FILE." (let ((name (package-desc-name pkg-desc))) - ;; Infer the subject if missing. + (when (equal (package-desc-summary pkg-desc) package--default-summary) + ;; We unset the package description if it is just the default + ;; summary, so that the following heuristic can take effect. + (setf (package-desc-summary pkg-desc) nil)) + ;; Infer the package description if missing. (unless (package-desc-summary pkg-desc) (setf (package-desc-summary pkg-desc) (let ((main-file (package-vc--main-file pkg-desc))) @@ -626,13 +578,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 +591,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 +608,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 +698,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 +813,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 +862,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 +875,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 +903,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-x.el b/lisp/emacs-lisp/package-x.el deleted file mode 100644 index 31996662c38..00000000000 --- a/lisp/emacs-lisp/package-x.el +++ /dev/null @@ -1,321 +0,0 @@ -;;; package-x.el --- Package extras -*- lexical-binding: t; -*- - -;; Copyright (C) 2007-2025 Free Software Foundation, Inc. - -;; Author: Tom Tromey <tromey@redhat.com> -;; Created: 10 Mar 2007 -;; Keywords: tools -;; Package: package - -;; 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 file currently contains parts of the package system that many -;; won't need, such as package uploading. - -;; To upload to an archive, first set `package-archive-upload-base' to -;; some desired directory. For testing purposes, you can specify any -;; directory you want, but if you want the archive to be accessible to -;; others via http, this is typically a directory in the /var/www tree -;; (possibly one on a remote machine, accessed via Tramp). - -;; Then call M-x package-upload-file, which prompts for a file to -;; upload. Alternatively, M-x package-upload-buffer uploads the -;; current buffer, if it's visiting a package file. - -;; Once a package is uploaded, users can access it via the Package -;; Menu, by adding the archive to `package-archives'. - -;;; Code: - -(require 'package) -(defvar gnus-article-buffer) - -(defcustom package-archive-upload-base "/path/to/archive" - "The base location of the archive to which packages are uploaded. -The commands in the package-x library will use this as base -location. -This should be an absolute directory name. If the archive is on -another machine, you may specify a remote name in the usual way, -e.g. \"/ssh:foo@example.com:/var/www/packages/\". -See Info node `(emacs)Remote Files'. - -Unlike `package-archives', you can't specify a HTTP URL." - :type 'directory - :group 'package - :version "24.1") - -(defvar package-update-news-on-upload nil - "Whether uploading a package should also update NEWS and RSS feeds.") - -(defun package--encode (string) - "Encode a string by replacing some characters with XML entities." - ;; We need a special case for translating "&" to "&". - (let ((index)) - (while (setq index (string-match "[&]" string index)) - (setq string (replace-match "&" t nil string)) - (setq index (1+ index)))) - (while (string-match "[<]" string) - (setq string (replace-match "<" t nil string))) - (while (string-match "[>]" string) - (setq string (replace-match ">" t nil string))) - (while (string-match "[']" string) - (setq string (replace-match "'" t nil string))) - (while (string-match "[\"]" string) - (setq string (replace-match """ t nil string))) - string) - -(defun package--make-rss-entry (title text archive-url) - (let ((date-string (format-time-string "%a, %d %B %Y %T %z"))) - (concat "<item>\n" - "<title>" (package--encode title) "</title>\n" - ;; FIXME: should have a link in the web page. - "<link>" archive-url "news.html</link>\n" - "<description>" (package--encode text) "</description>\n" - "<pubDate>" date-string "</pubDate>\n" - "</item>\n"))) - -(defun package--make-html-entry (title text) - (concat "<li> " (format-time-string "%B %e") " - " - title " - " (package--encode text) - " </li>\n")) - -(defun package--update-file (file tag text) - "Update the package archive file named FILE. -FILE should be relative to `package-archive-upload-base'. -TAG is a string that can be found within the file; TEXT is -inserted after its first occurrence in the file." - (setq file (expand-file-name file package-archive-upload-base)) - (save-excursion - (let ((old-buffer (find-buffer-visiting file))) - (with-current-buffer (let ((find-file-visit-truename t)) - (or old-buffer (find-file-noselect file))) - (goto-char (point-min)) - (search-forward tag) - (forward-line) - (insert text) - (let ((file-precious-flag t)) - (save-buffer)) - (unless old-buffer - (kill-buffer (current-buffer))))))) - -(defun package--archive-contents-from-url (archive-url) - "Parse archive-contents file at ARCHIVE-URL. -Return the file contents, as a string, or nil if unsuccessful." - (when archive-url - (with-temp-buffer - (ignore-errors - (url-insert-file-contents (concat archive-url "archive-contents")) - (package-read-from-string - (buffer-substring-no-properties (point-min) (point-max))))))) - -(defun package--archive-contents-from-file () - "Parse the archive-contents at `package-archive-upload-base'." - (let ((file (expand-file-name "archive-contents" - package-archive-upload-base))) - (if (not (file-exists-p file)) - ;; No existing archive-contents means a new archive. - (list package-archive-version) - (let ((dont-kill (find-buffer-visiting file))) - (with-current-buffer (let ((find-file-visit-truename t)) - (find-file-noselect file)) - (prog1 - (package-read-from-string - (buffer-substring-no-properties (point-min) (point-max))) - (unless dont-kill - (kill-buffer (current-buffer))))))))) - -(defun package-maint-add-news-item (title description archive-url) - "Add a news item to the webpages associated with the package archive. -TITLE is the title of the news item. -DESCRIPTION is the text of the news item." - (interactive "sTitle: \nsText: ") - (package--update-file "elpa.rss" - "<description>" - (package--make-rss-entry title description archive-url)) - (package--update-file "news.html" - "New entries go here" - (package--make-html-entry title description))) - -(defun package--update-news (package version description archive-url) - "Update the ELPA web pages when a package is uploaded." - (package-maint-add-news-item (concat package " version " version) - description - archive-url)) - -(declare-function lm-commentary "lisp-mnt" (&optional file)) -(defvar tar-data-buffer) - -(defun package-upload-buffer-internal (pkg-desc extension &optional archive-url) - "Upload a package whose contents are in the current buffer. -PKG-DESC is the `package-desc'. -EXTENSION is the file extension, a string. It can be either -\"el\" or \"tar\". - -The upload destination is given by `package-archive-upload-base'. -If its value is invalid, prompt for a directory. - -Optional arg ARCHIVE-URL is the URL of the destination archive. -If it is non-nil, compute the new \"archive-contents\" file -starting from the existing \"archive-contents\" at that URL. In -addition, if `package-update-news-on-upload' is non-nil, call -`package--update-news' to add a news item at that URL. - -If ARCHIVE-URL is nil, compute the new \"archive-contents\" file -from the \"archive-contents\" at `package-archive-upload-base', -if it exists." - (let ((package-archive-upload-base package-archive-upload-base)) - ;; Check if `package-archive-upload-base' is valid. - (when (or (not (stringp package-archive-upload-base)) - (equal package-archive-upload-base - (custom--standard-value 'package-archive-upload-base))) - (setq package-archive-upload-base - (read-directory-name - "Base directory for package archive: "))) - (unless (file-directory-p package-archive-upload-base) - (if (y-or-n-p (format "%s does not exist; create it? " - package-archive-upload-base)) - (make-directory package-archive-upload-base t) - (error "Aborted"))) - (save-excursion - (save-restriction - (let* ((file-type (package-desc-kind pkg-desc)) - (pkg-name (package-desc-name pkg-desc)) - (requires (package-desc-reqs pkg-desc)) - (desc (if (eq (package-desc-summary pkg-desc) - package--default-summary) - (read-string "Description of package: ") - (package-desc-summary pkg-desc))) - (split-version (package-desc-version pkg-desc)) - (commentary - (pcase file-type - ('single (lm-commentary)) - ('tar nil))) ;; FIXME: Get it from the README file. - (extras (package-desc-extras pkg-desc)) - (pkg-version (package-version-join split-version)) - (pkg-buffer (current-buffer))) - - ;; `package-upload-file' will error if given a directory, - ;; but we check it here as well just in case. - (when (eq 'dir file-type) - (user-error "Can't upload directory, tar it instead")) - ;; Get archive-contents from ARCHIVE-URL if it's non-nil, or - ;; from `package-archive-upload-base' otherwise. - (let ((contents (or (package--archive-contents-from-url archive-url) - (package--archive-contents-from-file))) - (new-desc (package-make-ac-desc - split-version requires desc file-type extras))) - (if (> (car contents) package-archive-version) - (error "Unrecognized archive version %d" (car contents))) - (let ((elt (assq pkg-name (cdr contents)))) - (if elt - (if (version-list-<= split-version - (package--ac-desc-version (cdr elt))) - (error "New package has smaller version: %s" pkg-version) - (setcdr elt new-desc)) - (setq contents (cons (car contents) - (cons (cons pkg-name new-desc) - (cdr contents)))))) - - ;; Now CONTENTS is the updated archive contents. Upload - ;; this and the package itself. For now we assume ELPA is - ;; writable via file primitives. - (let ((print-level nil) - (print-quoted t) - (print-length nil)) - (write-region (concat (pp-to-string contents) "\n") - nil - (expand-file-name "archive-contents" - package-archive-upload-base))) - - ;; If there is a commentary section, write it. - (when commentary - (write-region commentary nil - (expand-file-name - (concat (symbol-name pkg-name) "-readme.txt") - package-archive-upload-base))) - - (set-buffer (if (eq file-type 'tar) tar-data-buffer pkg-buffer)) - (write-region (point-min) (point-max) - (expand-file-name - (format "%s-%s.%s" pkg-name pkg-version extension) - package-archive-upload-base) - nil nil nil 'excl) - - ;; Write a news entry. - (and package-update-news-on-upload - archive-url - (package--update-news (format "%s.%s" pkg-name extension) - pkg-version desc archive-url)) - - ;; special-case "package": write a second copy so that the - ;; installer can easily find the latest version. - (if (eq pkg-name 'package) - (write-region (point-min) (point-max) - (expand-file-name - (format "%s.%s" pkg-name extension) - package-archive-upload-base) - nil nil nil 'ask)))))))) - -(defun package-upload-buffer () - "Upload the current buffer as a single-file Emacs Lisp package. -If `package-archive-upload-base' does not specify a valid upload -destination, prompt for one. -Signal an error if the current buffer is not visiting a simple -package (a \".el\" file)." - (interactive) - (save-excursion - (save-restriction - ;; Find the package in this buffer. - (let ((pkg-desc (package-buffer-info))) - (package-upload-buffer-internal pkg-desc "el"))))) - -;;;###autoload -(defun package-upload-file (file) - "Upload the Emacs Lisp package FILE to the package archive. -Interactively, prompt for FILE. The package is considered a -single-file package if FILE ends in \".el\", and a multi-file -package if FILE ends in \".tar\". -Automatically extract package attributes and update the archive's -contents list with this information. -If `package-archive-upload-base' does not specify a valid upload -destination, prompt for one. If the directory does not exist, it -is created. The directory need not have any initial contents -\(i.e., you can use this command to populate an initially empty -archive)." - (interactive "fPackage file name: ") - (with-temp-buffer - (insert-file-contents file) - (let ((pkg-desc - (cond - ((string-match "\\.tar\\'" file) - (tar-mode) (package-tar-file-info)) - ((string-match "\\.el\\'" file) (package-buffer-info)) - (t (error "Unrecognized extension `%s'" - (file-name-extension file)))))) - (package-upload-buffer-internal pkg-desc (file-name-extension file))))) - -(defun package-gnus-summary-upload () - "Upload a package contained in the current *Article* buffer. -This should be invoked from the gnus *Summary* buffer." - (interactive) - (with-current-buffer gnus-article-buffer - (package-upload-buffer))) - -(provide 'package-x) - -;;; package-x.el ends here diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index be3b85f3179..b9a8dacab15 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -837,11 +837,15 @@ PKG-DESC is a `package-desc' object." (unless (equal file result) (throw 'done result)))))) -(defun package--reload-previously-loaded (pkg-desc) +(defun package--reload-previously-loaded (pkg-desc &optional warn) "Force reimportation of files in PKG-DESC already present in `load-history'. New editions of files contain macro definitions and redefinitions, the overlooking of which would cause -byte-compilation of the new package to fail." +byte-compilation of the new package to fail. +If WARN is a string, display a warning (using WARN as a format string) +before reloading the files. WARN must have two %-sequences +corresponding to package name (a symbol) and a list of files loaded (as +sexps)." (with-demoted-errors "Error in package--load-files-for-activation: %s" (let* (result (dir (package-desc-dir pkg-desc)) @@ -858,25 +862,29 @@ 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)))) + (when (and result warn) + (display-warning 'package + (format warn (package-desc-name pkg-desc) + (mapcar #'car result)))) (mapc (lambda (c) (load (car c) nil t)) (sort result (lambda (x y) (< (cdr x) (cdr y)))))))) @@ -904,8 +912,11 @@ correspond to previously loaded files." (if (listp package--quickstart-pkgs) ;; We're only collecting the set of packages to activate! (push pkg-desc package--quickstart-pkgs) - (when reload - (package--reload-previously-loaded pkg-desc)) + (when (or reload (assq name package--builtin-versions)) + (package--reload-previously-loaded + pkg-desc (unless reload + "Package %S is activated too late. +The following files have already been loaded: %S"))) (with-demoted-errors "Error loading autoloads: %s" (load (package--autoloads-file-name pkg-desc) nil t))) ;; Add info node. @@ -1157,6 +1168,7 @@ Signal an error if the entire string was not used." (declare-function lm-header "lisp-mnt" (header)) (declare-function lm-package-requires "lisp-mnt" (&optional file)) +(declare-function lm-package-version "lisp-mnt" (&optional file)) (declare-function lm-website "lisp-mnt" (&optional file)) (declare-function lm-keywords-list "lisp-mnt" (&optional file)) (declare-function lm-maintainers "lisp-mnt" (&optional file)) @@ -1172,37 +1184,16 @@ boundaries." (unless (re-search-forward "^;;; \\([^ ]*\\)\\.el ---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$" nil t) (error "Package lacks a file header")) (let ((file-name (match-string-no-properties 1)) - (desc (match-string-no-properties 2)) - (start (line-beginning-position))) + (desc (match-string-no-properties 2))) (require 'lisp-mnt) - ;; This warning was added in Emacs 27.1, and should be removed at - ;; the earliest in version 31.1. The idea is to phase out the - ;; 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")))) - ;; Try to include a trailing newline. - (forward-line) - (narrow-to-region start (point)) - ;; Use some headers we've invented to drive the process. - (let* (;; Prefer Package-Version; if defined, the package author - ;; probably wants us to use it. Otherwise try Version. - (version-info - (or (lm-header "package-version") (lm-header "version"))) + (let* ((version-info (lm-package-version)) (pkg-version (package-strip-rcs-id version-info)) (keywords (lm-keywords-list)) (website (lm-website))) (unless pkg-version - (if version-info - (error "Unrecognized package version: %s" version-info) - (error "Package lacks a \"Version\" or \"Package-Version\" header"))) + (if version-info + (error "Unrecognized package version: %s" version-info) + (error "Package lacks a \"Version\" or \"Package-Version\" header"))) (package-desc-from-define file-name pkg-version desc (lm-package-requires) @@ -1755,7 +1746,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 +1824,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. @@ -1850,8 +1842,11 @@ For each archive configured in the variable `package-archives', inform Emacs about the latest versions of all packages it offers, and make them available for download. Optional argument ASYNC specifies whether to perform the -downloads in the background." - (interactive) +downloads in the background. This is always the case when the command +is invoked interactively." + (interactive (list t)) + (when async + (message "Refreshing package contents...")) (unless (file-exists-p package-user-dir) (make-directory package-user-dir t)) (let ((default-keyring (expand-file-name "package-keyring.gpg" @@ -1860,7 +1855,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)) @@ -2200,8 +2196,9 @@ built-in package with a (possibly newer) version from a package archive." ;;;###autoload (defun package-install (pkg &optional dont-select) "Install the package PKG. -PKG can be a `package-desc' or a symbol naming one of the -available packages in an archive in `package-archives'. + +PKG can be a `package-desc', or a symbol naming one of the available +packages in an archive in `package-archives'. Mark the installed package as selected by adding it to `package-selected-packages'. @@ -2233,6 +2230,7 @@ had been enabled." package-archive-contents) nil t)) nil))) + (cl-check-type pkg (or symbol package-desc)) (package--archives-initialize) (add-hook 'post-command-hook #'package-menu--post-refresh) (let ((name (if (package-desc-p pkg) @@ -2260,21 +2258,22 @@ had been enabled." ;;;###autoload (defun package-upgrade (name) - "Upgrade package NAME if a newer version exists." + "Upgrade package NAME if a newer version exists. + +NAME should be a symbol." (interactive - (list (completing-read - "Upgrade package: " (package--upgradeable-packages t) nil t))) - (let* ((package (if (symbolp name) - name - (intern name))) - (pkg-desc (cadr (assq package package-alist))) + (list (intern (completing-read + "Upgrade package: " + (package--upgradeable-packages t) nil t)))) + (cl-check-type name symbol) + (let* ((pkg-desc (cadr (assq name package-alist))) (package-install-upgrade-built-in (not pkg-desc))) ;; `pkg-desc' will be nil when the package is an "active built-in". (if (and pkg-desc (package-vc-p pkg-desc)) (package-vc-upgrade pkg-desc) (when pkg-desc (package-delete pkg-desc 'force 'dont-unselect)) - (package-install package + (package-install name ;; An active built-in has never been "selected" ;; before. Mark it as installed explicitly. (and pkg-desc 'dont-select))))) @@ -2442,9 +2441,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 +2621,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)) @@ -2663,7 +2668,7 @@ in a clean environment." (list (cl-loop for c in (completing-read-multiple - "Packages to isolate, as comma-separated list: " table + "Packages to isolate: " table nil t) collect (alist-get c table nil nil #'string=)) current-prefix-arg))) @@ -2702,7 +2707,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. @@ -2819,7 +2824,8 @@ Helper function for `describe-package'." (status (if desc (package-desc-status desc) "orphan")) (incompatible-reason (package--incompatible-p desc)) (signed (if desc (package-desc-signed desc))) - (maintainers (cdr (assoc :maintainer extras))) + (maintainers (or (cdr (assoc :maintainer extras)) + (cdr (assoc :maintainers extras)))) (authors (cdr (assoc :authors extras))) (news (and-let* (pkg-dir ((not built-in)) @@ -2870,7 +2876,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 ".") @@ -3980,7 +3986,7 @@ Return nil if there were no errors; non-nil otherwise." (package-menu--transaction-status)) (dolist (pkg install-list) (setq package-menu--transaction-status - (format status-format (cl-incf i))) + (format status-format (incf i))) (force-mode-line-update) (redisplay 'force) ;; Don't mark as selected, `package-menu-execute' already @@ -3995,8 +4001,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) @@ -4286,7 +4293,7 @@ string, show all packages. When called interactively, prompt for ARCHIVE. To specify several archives, type their names separated by commas." (interactive (list (completing-read-multiple - "Filter by archive (comma separated): " + "Filter by archive: " (mapcar #'car package-archives))) package-menu-mode) (package--ensure-package-menu-mode) @@ -4330,7 +4337,7 @@ or \"built-in\" or \"obsolete\". When called interactively, prompt for KEYWORD. To specify several keywords, type them separated by commas." (interactive (list (completing-read-multiple - "Keywords (comma separated): " + "Keywords: " (package-all-keywords))) package-menu-mode) (package--ensure-package-menu-mode) @@ -4522,7 +4529,7 @@ of an installed ELPA package. The return value is a string (or nil in case we can't find it). It works in more cases if the call is in the file which contains the `Version:' header." - ;; In a sense, this is a lie, but it does just what we want: precompute + ;; In a sense, this is a lie, but it does just what we want: precomputes ;; the version at compile time and hardcodes it into the .elc file! (declare (pure t)) ;; Hack alert! @@ -4543,10 +4550,7 @@ the `Version:' header." (unless (file-readable-p mainfile) (setq mainfile file)) (when (file-readable-p mainfile) (require 'lisp-mnt) - (with-temp-buffer - (insert-file-contents mainfile) - (or (lm-header "package-version") - (lm-header "version"))))))))) + (lm-package-version mainfile))))))) ;;;; Quickstart: precompute activation actions for faster start up. diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 73554fd66fd..c68b8961ee3 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 ()) @@ -363,7 +370,7 @@ undetected, binding variables to arbitrary values, such as nil. (cond (args (let ((arg-length (length args))) - (unless (= 0 (mod arg-length 2)) + (unless (evenp arg-length) (signal 'wrong-number-of-arguments (list 'pcase-setq (+ 2 arg-length))))) (let ((result)) @@ -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..c183f442d8d 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -208,7 +208,14 @@ it inserts and pretty-prints that arg at point." (while (progn (funcall avoid-unbreakable) - (not (zerop (skip-chars-backward " \t({[',."))))) + (let ((pos (point))) + (skip-chars-backward " \t({[',.") + (while (and (memq (char-after) '(?\. ?\{)) + (not (memq (char-before) + '(nil ?\n ?\) \" ?\])))) + ;; `.' and `{' within symbols? (Bug#76715) + (forward-char 1)) + (not (eql pos (point)))))) (if (bolp) ;; The sexp already starts on its own line. (progn (goto-char beg) nil) @@ -308,17 +315,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 +498,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))) @@ -570,7 +584,7 @@ the bounds of a region containing Lisp code to pretty-print." (insert ")"))) (defun pp--format-definition (sexp indent edebug) - (while (and (cl-plusp indent) + (while (and (plusp indent) sexp) (insert " ") ;; We don't understand all the edebug specs. @@ -585,7 +599,7 @@ the bounds of a region containing Lisp code to pretty-print." (pp--insert-lisp (car sexp))) (pop sexp)) (pop edebug) - (cl-decf indent)) + (decf indent)) (when (stringp (car sexp)) (insert "\n") (prin1 (pop sexp) (current-buffer))) diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index 6b4f6c55d7b..849442ff133 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -77,7 +77,7 @@ ;; modes. For the `rx' syntax the function `rx-to-string' is applied to ;; the evaluated expression read. So you can use quoted arguments ;; with something like '("findme") or you can construct arguments to -;; your hearts delight with a valid ELisp expression. (The compiled +;; your hearts delight with a valid Elisp expression. (The compiled ;; string form will be copied by `reb-copy') If you want to take ;; a glance at the corresponding string you can temporarily change the ;; input syntax. diff --git a/lisp/emacs-lisp/rmc.el b/lisp/emacs-lisp/rmc.el index 27e5d6c612b..158c1e857cc 100644 --- a/lisp/emacs-lisp/rmc.el +++ b/lisp/emacs-lisp/rmc.el @@ -191,7 +191,7 @@ Usage example: (format "%s (%s): " prompt - (mapconcat (lambda (e) (cdr e)) altered-names ", "))) + (mapconcat #'cdr altered-names ", "))) tchar buf wrong-char answer command) (save-window-excursion (save-excursion @@ -216,8 +216,14 @@ Usage example: (car elem))) prompt-choices))) (condition-case nil - (let ((cursor-in-echo-area t)) - (read-event)) + (let ((cursor-in-echo-area t) + ;; Do NOT use read-event here. That + ;; function does not consult + ;; input-decode-map (bug#75886). + (key (read-key))) + (when (eq key ?\C-g) + (signal 'quit nil)) + key) (error nil)))) (if (memq (car-safe tchar) '(touchscreen-begin touchscreen-end diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index 5ee191fce56..c512d42cd15 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -1,4 +1,4 @@ -;;; rx.el --- S-exp notation for regexps --*- lexical-binding: t -*- +;;; rx.el --- S-exp notation for regexps -*- lexical-binding: t -*- ;; Copyright (C) 2001-2025 Free Software Foundation, Inc. @@ -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) @@ -1074,7 +1072,7 @@ Return (REGEXP . PRECEDENCE)." "Expand `eval' arguments. Return a new rx form." (unless (and body (null (cdr body))) (error "rx `eval' form takes exactly one argument")) - (eval (car body))) + (eval (car body) lexical-binding)) (defun rx--translate-eval (body) "Translate the `eval' form. Return (REGEXP . PRECEDENCE)." diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index e74167cb1c7..15898ac9687 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -174,6 +174,137 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), (if (eq .rose 'red) .lily))))) +(define-short-documentation-group map + "Map Basics" + (mapp + :eval (mapp (list 'bar 1 'foo 2 'baz 3)) + :eval (mapp (list '(bar . 1) '(foo . 2) '(baz . 3))) + :eval (mapp [bar foo baz]) + :eval (mapp "this is a string") + :eval (mapp #s(hash-table data (bar 1 foo 2 baz 3))) + :eval (mapp '()) + :eval (mapp nil) + :eval (mapp (make-char-table 'shortdoc-test))) + (map-empty-p + :args (map) + :eval (map-empty-p nil) + :eval (map-empty-p []) + :eval (map-empty-p '())) + (map-elt + :args (map key) + :eval (map-elt (list 'bar 1 'foo 2 'baz 3) 'foo) + :eval (map-elt (list '(bar . 1) '(foo . 2) '(baz . 3)) 'foo) + :eval (map-elt [bar foo baz] 1) + :eval (map-elt #s(hash-table data (bar 1 foo 2 baz 3)) 'foo)) + (map-contains-key + :args (map key) + :eval (map-contains-key (list 'bar 1 'foo 2 'baz 3) 'foo) + :eval (map-contains-key (list '(bar . 1) '(foo . 2) '(baz . 3)) 'foo) + :eval (map-contains-key [bar foo baz] 1) + :eval (map-contains-key #s(hash-table data (bar 1 foo 2 baz 3)) 'foo)) + (map-put! + (map key value) + :eval +"(let ((map (list 'bar 1 'baz 3))) + (map-put! map 'foo 2) + map)" +;; This signals map-not-inplace when used in shortdoc.el :-( +;; :eval +;; "(let ((map (list '(bar . 1) '(baz . 3)))) +;; (map-put! map 'foo 2) +;; map)" + :eval +"(let ((map [bar bot baz])) + (map-put! map 1 'foo) + map)" + :eval +"(let ((map #s(hash-table data (bar 1 baz 3)))) + (map-put! map 'foo 2) + map)") + (map-insert + :args (map key value) + :eval (map-insert (list 'bar 1 'baz 3 'foo 7) 'foo 2) + :eval (map-insert (list '(bar . 1) '(baz . 3) '(foo . 7)) 'foo 2) + :eval (map-insert [bar bot baz] 1 'foo) + :eval (map-insert #s(hash-table data (bar 1 baz 3 foo 7)) 'foo 2)) + (map-delete + :args (map key) + :eval (map-delete (list 'bar 1 'foo 2 'baz 3) 'foo) + :eval (map-delete (list '(bar . 1) '(foo . 2) '(baz . 3)) 'foo) + :eval (map-delete [bar foo baz] 1) + :eval (map-delete #s(hash-table data (bar 1 foo 2 baz 3)) 'foo)) + (map-keys + :eval (map-keys (list 'bar 1 'foo 2 'baz 3)) + :eval (map-keys (list '(bar . 1) '(foo . 2) '(baz . 3))) + :eval (map-keys [bar foo baz]) + :eval (map-keys #s(hash-table data (bar 1 foo 2 baz 3)))) + (map-values + :args (map) + :eval (map-values (list 'bar 1 'foo 2 'baz 3)) + :eval (map-values (list '(bar . 1) '(foo . 2) '(baz . 3))) + :eval (map-values [bar foo baz]) + :eval (map-values #s(hash-table data (bar 1 foo 2 baz 3)))) + (map-pairs + :eval (map-pairs (list 'bar 1 'foo 2 'baz 3)) + :eval (map-pairs (list '(bar . 1) '(foo . 2) '(baz . 3))) + :eval (map-pairs [bar foo baz]) + :eval (map-pairs #s(hash-table data (bar 1 foo 2 baz 3)))) + (map-length + :args (map) + :eval (map-length (list 'bar 1 'foo 2 'baz 3)) + :eval (map-length (list '(bar . 1) '(foo . 2) '(baz . 3))) + :eval (map-length [bar foo baz]) + :eval (map-length #s(hash-table data (bar 1 foo 2 baz 3)))) + (map-copy + :args (map) + :eval (map-copy (list 'bar 1 'foo 2 'baz 3)) + :eval (map-copy (list '(bar . 1) '(foo . 2) '(baz . 3))) + :eval (map-copy [bar foo baz]) + :eval (map-copy #s(hash-table data (bar 1 foo 2 baz 3)))) + "Doing things to maps and their contents" + (map-apply + :args (function map) + :eval (map-apply #'+ (list '(1 . 2) '(3 . 4)))) + (map-do + :args (function map) + :eval +"(let ((map (list '(1 . 1) '(2 . 3))) + acc) + (map-do (lambda (k v) (push (+ k v) acc)) map) + (nreverse acc))") + (map-keys-apply + :eval (map-keys-apply #'1+ (list '(1 . 2) '(3 . 4)))) + (map-values-apply + :args (function map) + :eval (map-values-apply #'1+ (list '(1 . 2) '(3 . 4)))) + (map-filter + :eval (map-filter (lambda (k _) (oddp k)) (list '(1 . 2) '(4 . 6))) + :eval (map-filter (lambda (k v) (evenp (+ k v))) (list '(1 . 2) '(4 . 6)))) + (map-remove + :eval (map-remove (lambda (k _) (oddp k)) (list '(1 . 2) '(4 . 6))) + :eval (map-remove (lambda (k v) (evenp (+ k v))) (list '(1 . 2) '(4 . 6)))) + (map-some + :eval (map-some (lambda (k _) (oddp k)) (list '(1 . 2) '(4 . 6))) + :eval (map-some (lambda (k v) (evenp (+ k v))) (list '(1 . 2) '(4 . 6)))) + (map-every-p + :eval (map-every-p (lambda (k _) (oddp k)) (list '(1 . 2) '(4 . 6))) + :eval (map-every-p (lambda (k v) (evenp (+ k v))) (list '(1 . 3) '(4 . 6)))) + "Combining and changing maps" + (map-merge + :eval (map-merge 'alist '(1 2 3 4) #s(hash-table data (5 6 7 8))) + :eval (map-merge 'list '(1 2 3 4) #s(hash-table data (5 6 7 8))) + :eval (map-merge 'plist '(1 2 3 4) #s(hash-table data (5 6 7 8))) + :eval (map-merge 'hash-table '(1 2 3 4) #s(hash-table data (5 6 7 8)))) + (map-merge-with + :eval (map-merge-with 'alist #'max '(1 2 3 4) #s(hash-table data (1 1 3 5))) + :eval (map-merge-with 'alist #'min '(1 2 3 4) #s(hash-table data (1 1 3 5))) + :eval (map-merge-with 'hash-table #'min '(1 2 3 4) #s(hash-table data (1 1 3 5)))) + (map-into + :args (map type) + :eval (map-into #s(hash-table data '(5 6 7 8)) 'list) + :eval (map-into '((5 . 6) (7 . 8)) 'plist) + :eval (map-into '((5 . 6) (7 . 8)) 'hash-table))) + (define-short-documentation-group string "Making Strings" (make-string @@ -1244,9 +1375,17 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :eval (mod 10 6) :eval (mod 10.5 6)) (1+ - :eval (1+ 2)) + :eval (1+ 2) + :eval (let ((x 2)) (1+ x) x)) (1- - :eval (1- 4)) + :eval (1- 4) + :eval (let ((x 4)) (1- x) x)) + (incf + :eval (let ((x 2)) (incf x) x) + :eval (let ((x 2)) (incf x 2) x)) + (decf + :eval (let ((x 4)) (decf x) x) + :eval (let ((x 4)) (decf x 2)) x) "Predicates" (= :args (number &rest numbers) @@ -1281,16 +1420,16 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :eval (natnump -1) :eval (natnump 0) :eval (natnump 23)) - (cl-plusp - :eval (cl-plusp 0) - :eval (cl-plusp 1)) - (cl-minusp - :eval (cl-minusp 0) - :eval (cl-minusp -1)) - (cl-oddp - :eval (cl-oddp 3)) - (cl-evenp - :eval (cl-evenp 6)) + (plusp + :eval (plusp 0) + :eval (plusp 1)) + (minusp + :eval (minusp 0) + :eval (minusp -1)) + (oddp + :eval (oddp 3)) + (evenp + :eval (evenp 6)) (bignump :eval (bignump 4) :eval (bignump (expt 2 90))) diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index 98ed7eb5e29..111d413cc42 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -176,7 +176,7 @@ ;; don't hide real conflicts. (puthash key (gethash key override) table) (display-warning 'smie (format "Conflict: %s %s/%s %s" x old val y)) - (cl-incf smie-warning-count)) + (incf smie-warning-count)) (puthash key val table)))) (defun smie-precs->prec2 (precs) @@ -585,13 +585,13 @@ PREC2 is a table as returned by `smie-precs->prec2' or (unless (caar cst) (setcar (car cst) i) ;; (smie-check-grammar table prec2 'step1) - (cl-incf i)) + (incf i)) (setq csts (delq cst csts)))) (unless progress (error "Can't resolve the precedence cycle: %s" (smie-debug--describe-cycle table (smie-debug--prec2-cycle csts))))) - (cl-incf i 10)) + (incf i 10)) ;; Propagate equality constraints back to their sources. (dolist (eq (nreverse eqs)) (when (null (cadr eq)) @@ -602,7 +602,7 @@ PREC2 is a table as returned by `smie-precs->prec2' or ;; So set it here rather than below since doing it below ;; makes it more difficult to obey the equality constraints. (setcar (cdr eq) i) - (cl-incf i)) + (incf i)) (cl-assert (or (null (caar eq)) (eq (caar eq) (cadr eq)))) (setcar (car eq) (cadr eq)) ;; (smie-check-grammar table prec2 'step2) @@ -612,10 +612,10 @@ PREC2 is a table as returned by `smie-precs->prec2' or (dolist (x table) (unless (nth 1 x) (setf (nth 1 x) i) - (cl-incf i)) ;See other (cl-incf i) above. + (incf i)) ;See other (incf i) above. (unless (nth 2 x) (setf (nth 2 x) i) - (cl-incf i)))) ;See other (cl-incf i) above. + (incf i)))) ;See other (incf i) above. ;; Mark closers and openers. (dolist (x (gethash :smie-open/close-alist prec2)) (let* ((token (car x)) @@ -2157,7 +2157,7 @@ position corresponding to each rule." (trace (mapcar #'cdr (cdr itrace))) (cur (current-indentation))) (when (numberp nindent) ;Skip `noindent' and friends. - (cl-incf (gethash (cons (- cur nindent) trace) otraces 0))))) + (incf (gethash (cons (- cur nindent) trace) otraces 0))))) (forward-line 1))) (progress-reporter-done pr) @@ -2193,14 +2193,14 @@ position corresponding to each rule." (let ((data (list 0 nil nil))) (puthash sig data sigs) data)))) - (cl-incf (nth 0 sig-data) count) + (incf (nth 0 sig-data) count) (push (cons count otrace) (nth 2 sig-data)) (let ((sig-off-data (or (assq offset (nth 1 sig-data)) (let ((off-data (cons offset 0))) (push off-data (nth 1 sig-data)) off-data)))) - (cl-incf (cdr sig-off-data) count)))))))) + (incf (cdr sig-off-data) count)))))))) otraces) ;; Finally, guess the indentation rules. @@ -2240,8 +2240,8 @@ position corresponding to each rule." (push off-data (nth 1 sig-data)) off-data)))) (cl-assert (>= (cdr ooff-data) count)) - (cl-decf (cdr ooff-data) count) - (cl-incf (cdr noff-data) count)))))))))) + (decf (cdr ooff-data) count) + (incf (cdr noff-data) count)))))))))) rules)) (defun smie-config-guess () diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 2fa0652bc5c..4ce7bd00f31 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 @@ -489,8 +551,7 @@ as changes in text properties, `buffer-file-coding-system', buffer multibyteness, etc. -- will not be noticed, and the buffer will still be marked unmodified, effectively ignoring those changes." (declare (debug t) (indent 0)) - (let ((hash (gensym)) - (buffer (gensym))) + (cl-with-gensyms (hash buffer) `(let ((,hash (and (not (buffer-modified-p)) (buffer-hash))) (,buffer (current-buffer))) diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el index 6d28adb37b9..99a64d701cf 100644 --- a/lisp/emacs-lisp/syntax.el +++ b/lisp/emacs-lisp/syntax.el @@ -276,7 +276,7 @@ all RULES in total." ;; If there's more than 1 rule, and the rule want to apply ;; highlight to match 0, create an extra group to be able to ;; tell when *this* match 0 has succeeded. - (cl-incf offset) + (incf offset) (setq re (concat "\\(" re "\\)"))) (setq re (syntax-propertize--shift-groups-and-backrefs re offset)) (let ((code '()) @@ -356,7 +356,7 @@ all RULES in total." code)))) (push (cons condition (nreverse code)) branches)) - (cl-incf offset (regexp-opt-depth orig-re)) + (incf offset (regexp-opt-depth orig-re)) re)) rules "\\|"))) @@ -586,8 +586,8 @@ The rest is only useful if you're interested in tweaking the algorithm.") syntax-ppss-stats)) (defun syntax-ppss--update-stats (i old new) (let ((pair (aref syntax-ppss-stats i))) - (cl-incf (car pair)) - (cl-incf (cdr pair) (- new old)))) + (incf (car pair)) + (incf (cdr pair) (- new old)))) (defun syntax-ppss--data () (if (eq (point-min) 1) 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 1aac53b5f33..bf899eebbe9 100644 --- a/lisp/emacs-lisp/track-changes.el +++ b/lisp/emacs-lisp/track-changes.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2024-2025 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> -;; Version: 1.2 +;; Version: 1.4 ;; Package-Requires: ((emacs "24")) ;; This file is part of GNU Emacs. @@ -76,7 +76,12 @@ ;;; News: -;; Since v1.1: +;; v1.3: +;; +;; - Fix bug#73041. +;; - New `trace' setting for `track-changes-record-errors'. +;; +;; v1.2: ;; ;; - New function `track-changes-inconsistent-state-p'. @@ -170,6 +175,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 +187,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 +223,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 +247,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 +282,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 @@ -389,6 +402,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) @@ -444,7 +480,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 @@ -455,14 +493,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)) @@ -472,6 +511,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)) @@ -556,6 +596,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..8a5c73ebd3a 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -172,7 +172,7 @@ also call that function before the next warning.") ;; safely, testing the existing value, before they call one of the ;; warnings functions. ;;;###autoload -(defvar warning-type-format (purecopy " (%s)") +(defvar warning-type-format " (%s)" "Format for displaying the warning type in the warning message. The result of formatting the type this way gets included in the message under the control of the string in `warning-levels'.") @@ -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) |