diff options
Diffstat (limited to 'lisp/emacs-lisp')
27 files changed, 435 insertions, 398 deletions
diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el index 120972d6cd8..eddb006c500 100644 --- a/lisp/emacs-lisp/backtrace.el +++ b/lisp/emacs-lisp/backtrace.el @@ -33,7 +33,6 @@ (eval-when-compile (require 'cl-lib)) (eval-when-compile (require 'pcase)) -(eval-when-compile (require 'subr-x)) ; if-let (require 'find-func) (require 'help-mode) ; Define `help-function-def' button type. (require 'lisp-mode) @@ -202,6 +201,7 @@ frames where the source code location is known.") "+" #'backtrace-multi-line "-" #'backtrace-single-line "." #'backtrace-expand-ellipses + "C-]" #'abort-recursive-edit "<follow-link>" 'mouse-face "<mouse-2>" #'mouse-select-window diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index d8dbfa62bf9..0a89a33cbc3 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -483,7 +483,7 @@ There can be multiple entries for the same NAME if it has several aliases.") `(,fn ,name . ,optimized-rest))) ((guard (when for-effect - (if-let ((tmp (byte-opt--fget fn 'side-effect-free))) + (if-let* ((tmp (byte-opt--fget fn 'side-effect-free))) (or byte-compile-delete-errors (eq tmp 'error-free))))) (byte-compile-log " %s called for effect; deleted" fn) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 29e7882c851..f058fc48cc7 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -5470,9 +5470,9 @@ FORM is used to provide location, `bytecomp--cus-function' and (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))))) + (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)) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index b37f744b175..65bc2cb9173 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2247,15 +2247,35 @@ Like `cl-flet' but the definitions can refer to previous ones. . ,optimized-body)) ,retvar))))))) +(defun cl--self-tco-on-form (var form) + ;; Apply self-tco to the function returned by FORM, assuming that + ;; it will be bound to VAR. + (pcase form + (`(function (lambda ,fargs . ,ebody)) form + (pcase-let* ((`(,decls . ,body) (macroexp-parse-body ebody)) + (`(,ofargs . ,obody) (cl--self-tco var fargs body))) + `(function (lambda ,ofargs ,@decls . ,obody)))) + (`(let ,bindings ,form) + `(let ,bindings ,(cl--self-tco-on-form var form))) + (`(if ,cond ,exp1 ,exp2) + `(if ,cond ,(cl--self-tco-on-form var exp1) + ,(cl--self-tco-on-form var exp2))) + (`(oclosure--fix-type ,exp1 ,exp2) + `(oclosure--fix-type ,exp1 ,(cl--self-tco-on-form var exp2))) + (_ form))) + ;;;###autoload (defmacro cl-labels (bindings &rest body) "Make local (recursive) function definitions. -BINDINGS is a list of definitions of the form (FUNC ARGLIST BODY...) where +BINDINGS is a list of definitions of the form either (FUNC EXP) +where EXP is a form that should return the function to bind to the +function name FUNC, or (FUNC ARGLIST BODY...) where FUNC is the function name, ARGLIST its arguments, and BODY the -forms of the function body. FUNC is defined in any BODY, as well +forms of the function body. FUNC is in scope in any BODY or EXP, as well as FORM, so you can write recursive and mutually recursive -function definitions. See info node `(cl) Function Bindings' for -details. +function definitions, with the caveat that EXPs are evaluated in sequence +and you cannot call a FUNC before its EXP has been evaluated. +See info node `(cl) Function Bindings' for details. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" (declare (indent 1) (debug cl-flet)) @@ -2273,18 +2293,16 @@ details. (unless (assq 'function newenv) (push (cons 'function #'cl--labels-convert) newenv)) ;; Perform self-tail call elimination. - (setq binds (mapcar - (lambda (bind) - (pcase-let* - ((`(,var ,sargs . ,sbody) bind) - (`(function (lambda ,fargs . ,ebody)) - (macroexpand-all `(cl-function (lambda ,sargs . ,sbody)) - newenv)) - (`(,ofargs . ,obody) - (cl--self-tco var fargs ebody))) - `(,var (function (lambda ,ofargs . ,obody))))) - (nreverse binds))) - `(letrec ,binds + `(letrec ,(mapcar + (lambda (bind) + (pcase-let* ((`(,var ,sargs . ,sbody) bind)) + `(,var ,(cl--self-tco-on-form + var (macroexpand-all + (if (null sbody) + sargs ;A (FUNC EXP) definition. + `(cl-function (lambda ,sargs . ,sbody))) + newenv))))) + (nreverse binds)) . ,(macroexp-unprogn (macroexpand-all (macroexp-progn body) diff --git a/lisp/emacs-lisp/comp-common.el b/lisp/emacs-lisp/comp-common.el index e9b94681a4b..78720949b67 100644 --- a/lisp/emacs-lisp/comp-common.el +++ b/lisp/emacs-lisp/comp-common.el @@ -510,13 +510,13 @@ comes from `comp-primitive-type-specifiers' or the function type declaration itself." (let ((kind 'declared) type-spec) - (when-let ((res (assoc function comp-primitive-type-specifiers))) + (when-let* ((res (assoc function comp-primitive-type-specifiers))) ;; Declared primitive (setf type-spec (cadr res))) (let ((f (and (symbolp function) (symbol-function function)))) (when (and f (null type-spec)) - (if-let ((delc-type (function-get function 'function-type))) + (if-let* ((delc-type (function-get function 'function-type))) ;; Declared Lisp function (setf type-spec delc-type) (when (native-comp-function-p f) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 3f70b42774f..e1350370750 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -89,10 +89,10 @@ Integer values are handled in the `range' slot.") "Return all non built-in type names currently defined." (let (res) (mapatoms (lambda (x) - (when-let ((class (cl-find-class x)) - ;; Ignore EIEIO classes as they can be - ;; redefined at runtime. - (gate (not (eq 'eieio--class (type-of class))))) + (when-let* ((class (cl-find-class x)) + ;; Ignore EIEIO classes as they can be + ;; redefined at runtime. + (gate (not (eq 'eieio--class (type-of class))))) (push x res))) obarray) res)) @@ -528,8 +528,8 @@ Return them as multiple value." `(with-comp-cstr-accessors (if (or (neg src1) (neg src2)) (setf (typeset ,dst) '(number)) - (when-let ((r1 (range ,src1)) - (r2 (range ,src2))) + (when-let* ((r1 (range ,src1)) + (r2 (range ,src2))) (let* ((l1 (comp-cstr-smallest-in-range r1)) (l2 (comp-cstr-smallest-in-range r2)) (h1 (comp-cstr-greatest-in-range r1)) @@ -620,7 +620,7 @@ DST is returned." ;; Check first if we are in the simple case of all input non-negate ;; or negated so we don't have to cons. - (when-let ((res (comp--cstrs-homogeneous srcs))) + (when-let* ((res (comp--cstrs-homogeneous srcs))) (apply #'comp--cstr-union-homogeneous range dst srcs) (cl-return-from comp--cstr-union-1-no-mem dst)) @@ -805,7 +805,7 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (range dst) () (neg dst) nil) (cl-return-from comp-cstr-intersection-no-mem dst))) - (when-let ((res (comp--cstrs-homogeneous srcs))) + (when-let* ((res (comp--cstrs-homogeneous srcs))) (if (eq res 'neg) (apply #'comp--cstr-union-homogeneous t dst srcs) (apply #'comp-cstr-intersection-homogeneous dst srcs)) @@ -917,7 +917,7 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (when (and (null (neg cstr)) (null (valset cstr)) (null (typeset cstr))) - (when-let (range (range cstr)) + (when-let* ((range (range cstr))) (let* ((low (caar range)) (high (cdar (last range)))) (unless (or (eq low '-) @@ -949,7 +949,7 @@ 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)) (if (null (typeset cstr)) diff --git a/lisp/emacs-lisp/comp-run.el b/lisp/emacs-lisp/comp-run.el index 3c7802c2ee0..b4f8b46b93a 100644 --- a/lisp/emacs-lisp/comp-run.el +++ b/lisp/emacs-lisp/comp-run.el @@ -370,8 +370,8 @@ Return the trampoline if found or nil otherwise." (memq subr-name native-comp-never-optimize-functions) (gethash subr-name comp-installed-trampolines-h)) (cl-assert (subr-primitive-p subr)) - (when-let ((trampoline (or (comp--trampoline-search subr-name) - (comp-trampoline-compile subr-name)))) + (when-let* ((trampoline (or (comp--trampoline-search subr-name) + (comp-trampoline-compile subr-name)))) (comp--install-trampoline subr-name trampoline))))) ;;;###autoload @@ -423,7 +423,7 @@ bytecode definition was not changed in the meantime)." (t (signal 'native-compiler-error (list "Not a file nor directory" file-or-dir))))) (dolist (file file-list) - (if-let ((entry (seq-find (lambda (x) (string= file (car x))) comp-files-queue))) + (if-let* ((entry (seq-find (lambda (x) (string= file (car x))) comp-files-queue))) ;; Most likely the byte-compiler has requested a deferred ;; compilation, so update `comp-files-queue' to reflect that. (unless (or (null load) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f72d23fee1a..da351e99d91 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -201,9 +201,9 @@ Useful to hook into pass checkers.") "Given FUNCTION return the corresponding `comp-constraint'." (when (symbolp function) (or (gethash function comp-primitive-func-cstr-h) - (when-let ((type (or (when-let ((f (comp--symbol-func-to-fun function))) - (comp-func-declared-type f)) - (function-get function 'function-type)))) + (when-let* ((type (or (when-let* ((f (comp--symbol-func-to-fun function))) + (comp-func-declared-type f)) + (function-get function 'function-type)))) (comp-type-spec-to-cstr type))))) ;; Keep it in sync with the `cl-deftype-satisfies' property set in @@ -617,7 +617,7 @@ In use by the back-end." (defun comp--function-pure-p (f) "Return t if F is pure." (or (get f 'pure) - (when-let ((func (comp--symbol-func-to-fun f))) + (when-let* ((func (comp--symbol-func-to-fun f))) (comp-func-pure func)))) (defun comp--alloc-class-to-container (alloc-class) @@ -819,7 +819,7 @@ clashes." (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) @@ -1705,7 +1705,7 @@ into the C code forwarding the compilation unit." ;; FIXME Actually we could have another hash for this. (cl-flet ((pred (bb) (equal (comp-block-lap-addr bb) addr))) - (if-let ((pending (cl-find-if #'pred + (if-let* ((pending (cl-find-if #'pred (comp-limplify-pending-blocks comp-pass)))) (comp-block-name pending) (cl-loop for bb being the hash-value in (comp-func-blocks comp-func) @@ -1882,9 +1882,9 @@ The assume is emitted at the beginning of the block BB." rhs))) (comp-block-insns bb)))) ((pred comp--arithm-cmp-fun-p) - (when-let ((kind (if negated - (comp--negate-arithm-cmp-fun kind) - kind))) + (when-let* ((kind (if negated + (comp--negate-arithm-cmp-fun kind) + kind))) (push `(assume ,(make--comp-mvar :slot lhs-slot) (,kind ,lhs ,(if-let* ((vld (comp-cstr-imm-vld-p rhs)) @@ -1900,10 +1900,10 @@ The assume is emitted at the beginning of the block BB." (defun comp--maybe-add-vmvar (op cmp-res insns-seq) "If CMP-RES is clobbering OP emit a new constrained mvar and return it. Return OP otherwise." - (if-let ((match (eql (comp-mvar-slot op) (comp-mvar-slot cmp-res))) - (new-mvar (make--comp-mvar - :slot - (- (cl-incf (comp-func-vframe-size comp-func)))))) + (if-let* ((match (eql (comp-mvar-slot op) (comp-mvar-slot cmp-res))) + (new-mvar (make--comp-mvar + :slot + (- (cl-incf (comp-func-vframe-size comp-func)))))) (progn (push `(assume ,new-mvar ,op) (cdr insns-seq)) new-mvar) @@ -2139,14 +2139,14 @@ TARGET-BB-SYM is the symbol name of the target block." for bb being each hash-value of (comp-func-blocks comp-func) do (comp--loop-insn-in-block bb - (when-let ((match - (pcase insn - (`(set ,lhs (,(pred comp--call-op-p) ,f . ,args)) - (when-let ((cstr-f (comp--get-function-cstr f))) - (cl-values f cstr-f lhs args))) - (`(,(pred comp--call-op-p) ,f . ,args) - (when-let ((cstr-f (comp--get-function-cstr f))) - (cl-values f cstr-f nil args)))))) + (when-let* ((match + (pcase insn + (`(set ,lhs (,(pred comp--call-op-p) ,f . ,args)) + (when-let* ((cstr-f (comp--get-function-cstr f))) + (cl-values f cstr-f lhs args))) + (`(,(pred comp--call-op-p) ,f . ,args) + (when-let* ((cstr-f (comp--get-function-cstr f))) + (cl-values f cstr-f nil args)))))) (cl-multiple-value-bind (f cstr-f lhs args) match (cl-loop with gen = (comp--lambda-list-gen (comp-cstr-f-args cstr-f)) @@ -2340,14 +2340,14 @@ blocks." finger2 (comp-block-post-num b2)))) b1)) (first-processed (l) - (if-let ((p (cl-find-if #'comp-block-idom l))) + (if-let* ((p (cl-find-if #'comp-block-idom l))) p (signal 'native-ice '("can't find first preprocessed"))))) - (when-let ((blocks (comp-func-blocks comp-func)) - (entry (gethash 'entry blocks)) - ;; No point to go on if the only bb is 'entry'. - (bb0 (gethash 'bb_0 blocks))) + (when-let* ((blocks (comp-func-blocks comp-func)) + (entry (gethash 'entry blocks)) + ;; No point to go on if the only bb is 'entry'. + (bb0 (gethash 'bb_0 blocks))) (cl-loop with rev-bb-list = (comp--collect-rev-post-order entry) with changed = t @@ -2450,7 +2450,7 @@ blocks." PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (when pre-lambda (funcall pre-lambda bb)) - (when-let ((out-edges (comp-block-out-edges bb))) + (when-let* ((out-edges (comp-block-out-edges bb))) (cl-loop for ed in out-edges for child = (comp-edge-dst ed) when (eq bb (comp-block-idom child)) @@ -2508,7 +2508,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." do (comp--ssa-rename-insn insn in-frame)) (setf (comp-block-final-frame bb) (copy-sequence in-frame)) - (when-let ((out-edges (comp-block-out-edges bb))) + (when-let* ((out-edges (comp-block-out-edges bb))) (cl-loop for ed in out-edges for child = (comp-edge-dst ed) @@ -2668,7 +2668,7 @@ Return non-nil if the function is folded successfully." ;; should do basic block pruning in order to be sure that this ;; is not dead-code. This is now left to gcc, to be ;; implemented only if we want a reliable diagnostic here. - (let* ((f (if-let (f-in-ctxt (comp--symbol-func-to-fun f)) + (let* ((f (if-let* ((f-in-ctxt (comp--symbol-func-to-fun f))) ;; If the function is IN the compilation ctxt ;; and know to be pure. (comp-func-byte-func f-in-ctxt) @@ -2685,7 +2685,7 @@ Fold the call in case." (comp-cstr-imm-vld-p (car args))) (setf f (comp-cstr-imm (car args)) args (cdr args))) - (when-let ((cstr-f (comp--get-function-cstr f))) + (when-let* ((cstr-f (comp--get-function-cstr f))) (let ((cstr (comp-cstr-f-ret cstr-f))) (when (comp-cstr-empty-p cstr) ;; Store it to be rewritten as non local exit. @@ -2968,14 +2968,14 @@ FUNCTION can be a function-name or byte compiled function." do (comp--loop-insn-in-block b (pcase insn (`(set ,lval (callref funcall ,f . ,rest)) - (when-let ((ok (comp-cstr-imm-vld-p f)) - (new-form (comp--call-optim-form-call - (comp-cstr-imm f) rest))) + (when-let* ((ok (comp-cstr-imm-vld-p f)) + (new-form (comp--call-optim-form-call + (comp-cstr-imm f) rest))) (setf insn `(set ,lval ,new-form)))) (`(callref funcall ,f . ,rest) - (when-let ((ok (comp-cstr-imm-vld-p f)) - (new-form (comp--call-optim-form-call - (comp-cstr-imm f) rest))) + (when-let* ((ok (comp-cstr-imm-vld-p f)) + (new-form (comp--call-optim-form-call + (comp-cstr-imm f) rest))) (setf insn new-form))))))) (defun comp--call-optim (_) @@ -3643,12 +3643,8 @@ 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))) @@ -3667,6 +3663,17 @@ the compilation was successful return the compiled function." (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 perfomed 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. diff --git a/lisp/emacs-lisp/cond-star.el b/lisp/emacs-lisp/cond-star.el index 9495ad96a6c..0e4718f088d 100644 --- a/lisp/emacs-lisp/cond-star.el +++ b/lisp/emacs-lisp/cond-star.el @@ -31,28 +31,35 @@ ;; 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. +;; ??? 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 + (defmacro cond* (&rest clauses) "Extended form of traditional Lisp `cond' construct. A `cond*' construct is a series of clauses, and a clause normally has the form (CONDITION BODY...). CONDITION can be a Lisp expression, as in `cond'. -Or it can be `(bind* BINDINGS...)' or `(match* PATTERN DATUM)'. +Or it can be one of `(pcase* PATTERN DATUM)', +`(bind* BINDINGS...)', or `(match* PATTERN DATUM)', + +`(pcase* PATTERN DATUM)' means to match DATUM against the +pattern PATTERN, using the same pattern syntax as `pcase'. +The condition counts as true if PATTERN matches DATUM. `(bind* BINDINGS...)' means to bind BINDINGS (as if they were in `let*') for the body of the clause. As a condition, it counts as true if the first binding's value is non-nil. All the bindings are made unconditionally for whatever scope they cover. -`(match* PATTERN DATUM)' means to match DATUM against the pattern PATTERN -The condition counts as true if PATTERN matches DATUM. +`(match* PATTERN DATUM)' is an alternative to `pcase*' that uses another +syntax for its patterns, see `match*'. When a clause's condition is true, and it exits the `cond*' or is the last clause, the value of the last expression @@ -70,7 +77,7 @@ 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) +(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. @@ -133,7 +140,7 @@ ATOM (meaning any other kind of non-list not described above) \(constrain SYMBOL EXP) matches datum if the form EXP is true. EXP can refer to symbols bound earlier in the pattern." - (ignore datum) + ;; 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) @@ -245,8 +252,8 @@ This is used for conditional exit clauses." ;; 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*? +;;; ??? 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) @@ -262,6 +269,24 @@ This is used for conditional exit clauses." (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 @@ -369,11 +394,11 @@ as in `cond*-condition'." ;; because they are all gensyms anyway. (if (cdr backtrack-aliases) (setq expression - `(let ,(mapcar 'cdr (cdr backtrack-aliases)) + `(let ,(mapcar #'cdr (cdr backtrack-aliases)) ,expression))) (if retrieve-value-swap-outs (setq expression - `(let ,(mapcar 'cadr retrieve-value-swap-outs) + `(let ,(mapcar #'cadr retrieve-value-swap-outs) ,expression))) ;; If we used a gensym, wrap on code to bind it. (if gensym @@ -397,8 +422,8 @@ This is used for the bindings specified explicitly in match* patterns." (defvar cond*-debug-pattern nil) -;;; ??? Structure type patterns not implemented yet. -;;; ??? Probably should optimize the `nth' calls in handling `list'. +;; ??? 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*'. @@ -486,7 +511,7 @@ whether SUBPAT (as well as the subpatterns that contain/precede it) matches," (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)) + (setq bindings (nconc (mapcar #'list vars) bindings)) ;; Make the expressions to set the variables. (setq setqs (mapcar (lambda (var) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index deebe5109bd..d09229ee890 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1803,12 +1803,21 @@ infinite loops when the code/environment contains a circular object.") (cl-defmethod edebug--match-&-spec-op ((_ (eql '&interpose)) cursor specs) "Compute the specs for `&interpose SPEC FUN ARGS...'. -Extracts the head of the data by matching it against SPEC, -and then matches the rest by calling (FUN HEAD PF ARGS...) -where PF is the parsing function which FUN can call exactly once, -passing it the specs that it needs to match. -Note that HEAD will always be a list, since specs are defined to match -a sequence of elements." +SPECS is a list (SPEC FUN ARGS...), where SPEC is an edebug +specification, FUN is the function from the &interpose form which +transforms the edebug spec, and the optional ARGS is a list of final +arguments to be supplied to FUN. + +Extracts the head of the data by matching it against SPEC, and then +matches the rest by calling (FUN HEAD PF ARGS...). PF is the parsing +function which FUN must call exactly once, passing it one argument, the +specs that it needs to match. FUN's value must be the value of this PF +call, which in turn will be the value of this function. + +Note that HEAD will always be a list, since specs is defined to match a +sequence of elements." + ;; Note: PF is called in FUN rather than in this function, so that it + ;; can use any dynamic bindings created there. (pcase-let* ((`(,spec ,fun . ,args) specs) (exps (edebug-cursor-expressions cursor)) @@ -1817,14 +1826,14 @@ a sequence of elements." (length (edebug-cursor-expressions cursor)))) (head (seq-subseq exps 0 consumed))) (cl-assert (eq (edebug-cursor-expressions cursor) (nthcdr consumed exps))) - (apply fun `(,head - ,(lambda (newspecs) - ;; FIXME: What'd be the difference if we used - ;; `edebug-match-sublist', which is what - ;; `edebug-list-form-args' uses for the similar purpose - ;; when matching "normal" forms? - (append instrumented-head (edebug-match cursor newspecs))) - ,@args)))) + (apply fun head + (lambda (newspecs) + ;; FIXME: What'd be the difference if we used + ;; `edebug-match-sublist', which is what + ;; `edebug-list-form-args' uses for the similar purpose + ;; when matching "normal" forms? + (append instrumented-head (edebug-match cursor newspecs))) + args))) (cl-defmethod edebug--match-&-spec-op ((_ (eql '¬)) cursor specs) ;; If any specs match, then fail @@ -3922,8 +3931,8 @@ be installed in `emacs-lisp-mode-map'.") (define-obsolete-variable-alias 'global-edebug-prefix 'edebug-global-prefix "28.1") (defvar edebug-global-prefix - (when-let ((binding - (car (where-is-internal 'Control-X-prefix (list global-map))))) + (when-let* ((binding + (car (where-is-internal 'Control-X-prefix (list global-map))))) (concat binding [?X])) "Prefix key for global edebug commands, available from any buffer.") @@ -4659,8 +4668,8 @@ instrumentation for, defaulting to all functions." functions))))) ;; Remove instrumentation. (dolist (symbol functions) - (when-let ((unwrapped - (edebug--unwrap*-symbol-function symbol))) + (when-let* ((unwrapped + (edebug--unwrap*-symbol-function symbol))) (edebug--strip-plist symbol) (defalias symbol unwrapped))) (message "Removed edebug instrumentation from %s" diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 74f5e21db7d..98d9a2d2f4f 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -769,10 +769,10 @@ dynamically set from ARGS." (let* ((slot (aref slots i)) (slot-name (eieio-slot-descriptor-name slot)) (initform (cl--slot-descriptor-initform slot))) - (unless (or (when-let ((initarg - (car (rassq slot-name - (eieio--class-initarg-tuples - this-class))))) + (unless (or (when-let* ((initarg + (car (rassq slot-name + (eieio--class-initarg-tuples + this-class))))) (plist-get initargs initarg)) ;; Those slots whose initform is constant already have ;; the right value set in the default-object. diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index cd60f9f457f..8469440c982 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -395,8 +395,8 @@ variable `ert-resource-directory-format'. Before formatting, the file name will be trimmed using `string-trim' with arguments `ert-resource-directory-trim-left-regexp' and `ert-resource-directory-trim-right-regexp'." - `(when-let ((testfile ,(or (macroexp-file-name) - buffer-file-name))) + `(when-let* ((testfile ,(or (macroexp-file-name) + buffer-file-name))) (let ((default-directory (file-name-directory testfile))) (file-truename (if (file-accessible-directory-p "resources/") diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index fa1b7a60a90..97aa233f6e2 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) @@ -1352,10 +1352,10 @@ RESULT must be an `ert-test-result-with-condition'." (defun ert-test-location (test) "Return a string description the source location of TEST." - (when-let ((loc - (ignore-errors - (find-function-search-for-symbol - (ert-test-name test) 'ert-deftest (ert-test-file-name test))))) + (when-let* ((loc + (ignore-errors + (find-function-search-for-symbol + (ert-test-name test) 'ert-deftest (ert-test-file-name test))))) (let* ((buffer (car loc)) (point (cdr loc)) (file (file-relative-name (buffer-file-name buffer))) @@ -1548,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" @@ -2906,10 +2906,10 @@ write erts files." (setq end-before end-after start-after start-before)) ;; Update persistent specs. - (when-let ((point-char (assq 'point-char specs))) + (when-let* ((point-char (assq 'point-char specs))) (setq gen-specs (map-insert gen-specs 'point-char (cdr point-char)))) - (when-let ((code (cdr (assq 'code specs)))) + (when-let* ((code (cdr (assq 'code specs)))) (setq gen-specs (map-insert gen-specs 'code (car (read-from-string code))))) ;; Get the "after" strings. @@ -2917,12 +2917,12 @@ write erts files." (insert-buffer-substring file-buffer start-after end-after) (ert--erts-unquote) ;; Remove the newline at the end of the buffer. - (when-let ((no-newline (cdr (assq 'no-after-newline specs)))) + (when-let* ((no-newline (cdr (assq 'no-after-newline specs)))) (goto-char (point-min)) (when (re-search-forward "\n\\'" nil t) (delete-region (match-beginning 0) (match-end 0)))) ;; Get the expected "after" point. - (when-let ((point-char (cdr (assq 'point-char gen-specs)))) + (when-let* ((point-char (cdr (assq 'point-char gen-specs)))) (goto-char (point-min)) (when (search-forward point-char nil t) (delete-region (match-beginning 0) (match-end 0)) @@ -2933,13 +2933,13 @@ write erts files." (insert-buffer-substring file-buffer start-before end-before) (ert--erts-unquote) ;; Remove the newline at the end of the buffer. - (when-let ((no-newline (cdr (assq 'no-before-newline specs)))) + (when-let* ((no-newline (cdr (assq 'no-before-newline specs)))) (goto-char (point-min)) (when (re-search-forward "\n\\'" nil t) (delete-region (match-beginning 0) (match-end 0)))) (goto-char (point-min)) ;; Place point in the specified place. - (when-let ((point-char (cdr (assq 'point-char gen-specs)))) + (when-let* ((point-char (cdr (assq 'point-char gen-specs)))) (when (search-forward point-char nil t) (delete-region (match-beginning 0) (match-end 0)))) (let ((code (cdr (assq 'code gen-specs)))) diff --git a/lisp/emacs-lisp/icons.el b/lisp/emacs-lisp/icons.el index 847ef53a1cb..144b60a2c1d 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/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 601cc7bf712..220bb5175ea 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -1153,7 +1153,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 +1171,11 @@ STATE is the `parse-partial-sexp' state for current position." (let (local-definitions-starting-point) (and (save-excursion (goto-char (1+ second-order-parent)) - (when-let ((head (ignore-errors - ;; FIXME: This does not distinguish - ;; between reading nil and a read error. - ;; We don't care but still, better fix this. - (read (current-buffer))))) + (when-let* ((head (ignore-errors + ;; FIXME: This does not distinguish + ;; between reading nil and a read error. + ;; We don't care but still, better fix this. + (read (current-buffer))))) (when (memq head '( cl-flet cl-labels cl-macrolet cl-flet* cl-symbol-macrolet)) ;; In what follows, we rely on (point) returning non-nil. diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el index 50e90cdf94c..6e843f741d8 100644 --- a/lisp/emacs-lisp/loaddefs-gen.el +++ b/lisp/emacs-lisp/loaddefs-gen.el @@ -295,7 +295,7 @@ expression, in which case we want to handle forms differently." (null (plist-get props :set)) (error nil))) ;; Propagate the :safe property to the loaddefs file. - ,@(when-let ((safe (plist-get props :safe))) + ,@(when-let* ((safe (plist-get props :safe))) `((put ',varname 'safe-local-variable ,safe)))))) ;; Extract theme properties. @@ -413,8 +413,8 @@ don't include." (save-excursion ;; Since we're "open-coding", we have to repeat more ;; complicated logic in `hack-local-variables'. - (when-let ((beg - (re-search-forward "read-symbol-shorthands: *" nil t))) + (when-let* ((beg + (re-search-forward "read-symbol-shorthands: *" nil t))) ;; `read-symbol-shorthands' alist ends with two parens. (let* ((end (re-search-forward ")[;\n\s]*)")) (commentless (replace-regexp-in-string @@ -499,7 +499,7 @@ don't include." (when (and autoload-compute-prefixes compute-prefixes) (with-demoted-errors "%S" - (when-let + (when-let* ((form (loaddefs-generate--compute-prefixes load-name))) ;; This output needs to always go in the main loaddefs.el, ;; regardless of `generated-autoload-file'. @@ -591,7 +591,7 @@ instead of just updating them with the new/changed autoloads." ;; we don't want to depend on whether Emacs was ;; built with or without modules support, nor ;; what is the suffix for the underlying OS. - (unless (string-match "\\.\\(elc\\|so\\|dll\\)" suf) + (unless (string-match "\\.\\(elc\\|so\\|dll\\|dylib\\)" suf) (push suf tmp))) (concat "\\`[^=.].*" (regexp-opt tmp t) "\\'"))) (files (apply #'nconc diff --git a/lisp/emacs-lisp/multisession.el b/lisp/emacs-lisp/multisession.el index c923c29bbf7..71be928e30f 100644 --- a/lisp/emacs-lisp/multisession.el +++ b/lisp/emacs-lisp/multisession.el @@ -428,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) @@ -456,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 36df143a82a..ac9254c867a 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -584,7 +584,7 @@ of the piece of advice." ;;;###autoload (defmacro define-advice (symbol args &rest body) "Define an advice and add it to function named SYMBOL. -See `advice-add' and `add-function' for explanation on the +See `advice-add' and `add-function' for explanation of the arguments. If NAME is non-nil, the advice is named `SYMBOL@NAME' and installed with the name NAME; otherwise, the advice is anonymous. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index e168096e153..d30f616f6ea 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -63,71 +63,19 @@ (defconst package-vc--elpa-packages-version 1 "Version number of the package specification format understood by package-vc.") -(defconst package-vc--backend-type - `(choice :convert-widget - ,(lambda (widget) - (let (opts) - (dolist (be vc-handled-backends) - (when (or (vc-find-backend-function be 'clone) - (alist-get 'clone (get be 'vc-functions))) - (push (widget-convert (list 'const be)) opts))) - (widget-put widget :args opts)) - widget)) - "The type of VC backends that support cloning package VCS repositories.") - -(defcustom package-vc-heuristic-alist - `((,(rx bos "http" (? "s") "://" - (or (: (? "www.") "github.com" - "/" (+ (or alnum "-" "." "_")) - "/" (+ (or alnum "-" "." "_"))) - (: "codeberg.org" - "/" (+ (or alnum "-" "." "_")) - "/" (+ (or alnum "-" "." "_"))) - (: (? "www.") "gitlab" (+ "." (+ alnum)) - "/" (+ (or alnum "-" "." "_")) - "/" (+ (or alnum "-" "." "_"))) - (: "git.sr.ht" - "/~" (+ (or alnum "-" "." "_")) - "/" (+ (or alnum "-" "." "_"))) - (: "git." (or "savannah" "sv") "." (? "non") "gnu.org/" - (or "r" "git") "/" - (+ (or alnum "-" "." "_")) (? "/"))) - (or (? "/") ".git") eos) - . Git) - (,(rx bos "http" (? "s") "://" - (or (: "hg.sr.ht" - "/~" (+ (or alnum "-" "." "_")) - "/" (+ (or alnum "-" "." "_"))) - (: "hg." (or "savannah" "sv") "." (? "non") "gnu.org/hgweb/" - (+ (or alnum "-" "." "_")) (? "/"))) - eos) - . Hg) - (,(rx bos "http" (? "s") "://" - (or (: "bzr." (or "savannah" "sv") "." (? "non") "gnu.org/r/" - (+ (or alnum "-" "." "_")) (? "/"))) - eos) - . Bzr)) - "Alist mapping repository URLs to VC backends. -`package-vc-install' consults this alist to determine the VC -backend from the repository URL when you call it without -specifying a backend. Each element of the alist has the form -\(URL-REGEXP . BACKEND). `package-vc-install' will use BACKEND of -the first association for which the URL of the repository matches -the URL-REGEXP of the association. If no match is found, -`package-vc-install' uses `package-vc-default-backend' instead." - :type `(alist :key-type (regexp :tag "Regular expression matching URLs") - :value-type ,package-vc--backend-type) - :version "29.1") +(define-obsolete-variable-alias + 'package-vc-heuristic-alist + 'vc-clone-heuristic-alist "31.1") (defcustom package-vc-default-backend 'Git "Default VC backend to use for cloning package repositories. `package-vc-install' uses this backend when you specify neither the backend nor a repository URL that's recognized via -`package-vc-heuristic-alist'. +`vc-clone-heuristic-alist'. The value must be a member of `vc-handled-backends' that supports the `clone' VC function." - :type package-vc--backend-type + :type vc-cloneable-backends-custom-type :version "29.1") (defcustom package-vc-register-as-project t @@ -247,8 +195,8 @@ This function is meant to be used as a hook for `package-read-archive-hook'." (car spec))) (setf (alist-get (intern archive) package-vc--archive-data-alist) (cdr spec)) - (when-let ((default-vc (plist-get (cdr spec) :default-vc)) - ((not (memq default-vc vc-handled-backends)))) + (when-let* ((default-vc (plist-get (cdr spec) :default-vc)) + ((not (memq default-vc vc-handled-backends)))) (warn "Archive `%S' expects missing VC backend %S" archive (plist-get (cdr spec) :default-vc))))))))) @@ -279,7 +227,7 @@ asynchronously." (defun package-vc--version (pkg) "Return the version number for the VC package PKG." (cl-assert (package-vc-p pkg)) - (if-let ((main-file (package-vc--main-file pkg))) + (if-let* ((main-file (package-vc--main-file pkg))) (with-temp-buffer (insert-file-contents main-file) (package-strip-rcs-id @@ -626,13 +574,6 @@ documentation and marking the package as installed." ""))) t)) -(defun package-vc--guess-backend (url) - "Guess the VC backend for URL. -This function will internally query `package-vc-heuristic-alist' -and return nil if it cannot reasonably guess." - (and url (alist-get url package-vc-heuristic-alist - nil nil #'string-match-p))) - (declare-function project-remember-projects-under "project" (dir &optional recursive)) (defun package-vc--clone (pkg-desc pkg-spec dir rev) @@ -646,7 +587,7 @@ attribute in PKG-SPEC." (unless (file-exists-p dir) (make-directory (file-name-directory dir) t) (let ((backend (or (plist-get pkg-spec :vc-backend) - (package-vc--guess-backend url) + (vc-guess-url-backend url) (plist-get (alist-get (package-desc-archive pkg-desc) package-vc--archive-data-alist nil nil #'string=) @@ -663,7 +604,7 @@ attribute in PKG-SPEC." ;; Check out the latest release if requested (when (eq rev :last-release) - (if-let ((release-rev (package-vc--release-rev pkg-desc))) + (if-let* ((release-rev (package-vc--release-rev pkg-desc))) (vc-retrieve-tag dir release-rev) (message "No release revision was found, continuing..."))))) @@ -753,7 +694,7 @@ VC packages that have already been installed." ;; pointing towards a repository, and use that as a backup (and-let* ((extras (package-desc-extras (cadr pkg))) (url (alist-get :url extras)) - ((package-vc--guess-backend url))))))) + ((vc-guess-url-backend url))))))) (not allow-url))) (defun package-vc--read-package-desc (prompt &optional installed) @@ -868,7 +809,7 @@ If PACKAGE is a string, it specifies the URL of the package repository. In this case, optional argument BACKEND specifies the VC backend to use for cloning the repository; if it's nil, this function tries to infer which backend to use according to -the value of `package-vc-heuristic-alist' and if that fails it +the value of `vc-clone-heuristic-alist' and if that fails it uses `package-vc-default-backend'. Optional argument NAME specifies the package name in this case; if it's nil, this package uses `file-name-base' on the URL to obtain the package @@ -917,7 +858,7 @@ installs takes precedence." (cdr package) rev)) ((and-let* (((stringp package)) - (backend (or backend (package-vc--guess-backend package)))) + (backend (or backend (vc-guess-url-backend package)))) (package-vc--unpack (package-desc-create :name (or name (intern (file-name-base package))) @@ -930,7 +871,7 @@ installs takes precedence." (or (package-vc--desc->spec (cadr desc)) (and-let* ((extras (package-desc-extras (cadr desc))) (url (alist-get :url extras)) - (backend (package-vc--guess-backend url))) + (backend (vc-guess-url-backend url))) (list :vc-backend backend :url url)) (user-error "Package `%s' has no VC data" package)) rev))) @@ -958,7 +899,7 @@ for the last released version of the package." (let ((pkg-spec (or (package-vc--desc->spec pkg-desc) (and-let* ((extras (package-desc-extras pkg-desc)) (url (alist-get :url extras)) - (backend (package-vc--guess-backend url))) + (backend (vc-guess-url-backend url))) (list :vc-backend backend :url url)) (user-error "Package `%s' has no VC data" (package-desc-name pkg-desc))))) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 90d6150ed0b..af07ba44e28 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -858,22 +858,22 @@ byte-compilation of the new package to fail." (cl-remove-if-not #'stringp (mapcar #'car load-history))))) (dolist (file files) - (when-let ((library (package--library-stem - (file-relative-name file dir))) - (canonical (locate-library library nil effective-path)) - (truename (file-truename canonical)) - ;; Normally, all files in a package are compiled by - ;; now, but don't assume that. E.g. different - ;; versions can add or remove `no-byte-compile'. - (altname (if (string-suffix-p ".el" truename) - (replace-regexp-in-string - "\\.el\\'" ".elc" truename t) - (replace-regexp-in-string - "\\.elc\\'" ".el" truename t))) - (found (or (member truename history) - (and (not (string= altname truename)) - (member altname history)))) - (recent-index (length found))) + (when-let* ((library (package--library-stem + (file-relative-name file dir))) + (canonical (locate-library library nil effective-path)) + (truename (file-truename canonical)) + ;; Normally, all files in a package are compiled by + ;; now, but don't assume that. E.g. different + ;; versions can add or remove `no-byte-compile'. + (altname (if (string-suffix-p ".el" truename) + (replace-regexp-in-string + "\\.el\\'" ".elc" truename t) + (replace-regexp-in-string + "\\.elc\\'" ".el" truename t))) + (found (or (member truename history) + (and (not (string= altname truename)) + (member altname history)))) + (recent-index (length found))) (unless (equal (file-name-base library) (format "%s-autoloads" (package-desc-name pkg-desc))) (push (cons (expand-file-name library dir) recent-index) result)))) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 898d460c144..9812621d50e 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." diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index 12346b3d285..e246e4211bb 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -491,8 +491,8 @@ the bounds of a region containing Lisp code to pretty-print." (cons (cond ((consp (cdr sexp)) (let ((head (car sexp))) - (if-let (((null (cddr sexp))) - (syntax-entry (assq head pp--quoting-syntaxes))) + (if-let* (((null (cddr sexp))) + (syntax-entry (assq head pp--quoting-syntaxes))) (progn (insert (cdr syntax-entry)) (pp--insert-lisp (cadr sexp))) diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 3b4907b8f43..df825bd68c8 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -357,7 +357,9 @@ automatically killed, which means that in a such case ;; 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)) + (let ((inhibit-read-only t) + ;; Avoid deactivating the region as side effect. + deactivate-mark) (erase-buffer)) (delete-all-overlays) (let (change-major-mode-hook) @@ -398,22 +400,25 @@ substring that does not include newlines." ;; Keeping a work buffer around is more efficient than creating a ;; new temporary buffer. (with-work-buffer - ;; If `display-line-numbers' is enabled in internal - ;; buffers (e.g. globally), it breaks width calculation - ;; (bug#59311). Disable `line-prefix' and `wrap-prefix', - ;; for the same reason. - (setq display-line-numbers nil - line-prefix nil wrap-prefix nil) (if buffer (setq-local face-remapping-alist (with-current-buffer buffer face-remapping-alist)) (kill-local-variable 'face-remapping-alist)) - (insert string) + ;; 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 @@ -475,7 +480,7 @@ this defaults to the current buffer." (t disp))) ;; Remove any old instances. - (when-let ((old (assoc prop disp))) + (when-let* ((old (assoc prop disp))) (setq disp (delete old disp))) (setq disp (cons (list prop value) disp)) (when vector diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 30397137efb..eaf3c5cb561 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/timer.el b/lisp/emacs-lisp/timer.el index f6f2a8d87c0..166755e4dcc 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/vtable.el b/lisp/emacs-lisp/vtable.el index d58c6894c16..c4f14d7b4b2 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 68db33bfa68..b11e1ebeb70 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -285,7 +285,7 @@ entirely by setting `warning-suppress-types' or (unless buffer-name (setq buffer-name "*Warnings*")) (with-suppressed-warnings ((obsolete warning-level-aliases)) - (when-let ((new (cdr (assq level warning-level-aliases)))) + (when-let* ((new (cdr (assq level warning-level-aliases)))) (warn "Warning level `%s' is obsolete; use `%s' instead" level new) (setq level new))) (or (< (warning-numeric-level level) |