commit fe04b4fc27d50b7087ee622281672866dbf87818 (HEAD, refs/remotes/origin/master) Author: Stefan Monnier Date: Sat Feb 15 00:39:54 2025 -0500 (smerge-refine-exchange-point): Error cleanly outside refinement * lisp/vc/smerge-mode.el (smerge-refine-regions): Cover each region with an overlay. (smerge-refine-exchange-point): Use it to detect more reliably that we're not inside a refined region. diff --git a/lisp/vc/smerge-mode.el b/lisp/vc/smerge-mode.el index bce5822a042..f77b73c6170 100644 --- a/lisp/vc/smerge-mode.el +++ b/lisp/vc/smerge-mode.el @@ -1116,6 +1116,29 @@ used to replace chars to try and eliminate some spurious differences." (file2 (make-temp-file "diff2")) (smerge--refine-long-words (if smerge-refine-weight-hack (make-hash-table :test #'equal)))) + + ;; Cover the two regions with one `smerge--refine-region' overlay each. + (let ((ol1 (make-overlay beg1 end1 nil + ;; Make it shrink rather than spread when editing. + 'front-advance nil)) + (ol2 (make-overlay beg2 end2 nil + ;; Make it shrink rather than spread when editing. + 'front-advance nil)) + (common-props '((evaporate . t) (smerge--refine-region . t)))) + (dolist (prop (or props-a props-c)) + (when (and (not (memq (car prop) '(face font-lock-face))) + (member prop (or props-r props-c)) + (or (not (and props-c props-a props-r)) + (member prop props-c))) + ;; This PROP is shared among all those overlays. + ;; Better keep it also for the `smerge--refine-region' overlays, + ;; so the client package recognizes them as being part of the + ;; refinement (e.g. it will hopefully delete them like the others). + (push prop common-props))) + (dolist (prop common-props) + (overlay-put ol1 (car prop) (cdr prop)) + (overlay-put ol2 (car prop) (cdr prop)))) + (unless (markerp beg1) (setq beg1 (copy-marker beg1))) (unless (markerp beg2) (setq beg2 (copy-marker beg2))) (let ((write-region-inhibit-fsync t)) ; Don't fsync temp files (Bug#12747). @@ -1245,27 +1268,30 @@ repeating the command will highlight other two parts." (defun smerge-refine-exchange-point () "Go to the matching position in the other chunk." (interactive) - ;; FIXME: Chunks aren't marked in the same way for all users of - ;; `smerge-refine-regions' :-( - ;; (unless (get-char-property (point) 'smerge) - ;; (error "Not inside a refined chunk")) - (let* ((ref-pos + (let* ((covering-ol + (let ((ols (overlays-at (point)))) + (while (and ols (not (overlay-get (car ols) + 'smerge--refine-region))) + (pop ols)) + (or (car ols) + (user-error "Not inside a refined region")))) + (ref-pos (if (or (get-char-property (point) 'smerge--refine-other) (get-char-property (1- (point)) 'smerge--refine-other)) (point) - ;; FIXME: Bound the search to the current chunk! (let ((next (next-single-char-property-change - (point) 'smerge--refine-other)) + (point) 'smerge--refine-other nil + (overlay-end covering-ol))) (prev (previous-single-char-property-change - (point) 'smerge--refine-other))) + (point) 'smerge--refine-other nil + (overlay-start covering-ol)))) (cond - ((and prev - (or (null next) + ((and (> prev (overlay-start covering-ol)) + (or (>= next (overlay-end covering-ol)) (> (- next (point)) (- (point) prev)))) prev) - (t (or next - ;; FIXME: default to the bounds! - (user-error "No \"other\" position info found"))))))) + ((< next (overlay-end covering-ol)) next) + (t (user-error "No \"other\" position info found")))))) (boundary (cond ((< ref-pos (point)) commit 18ebbba6c422617a16cc36082a8ba871b5bfce2c Author: Stefan Monnier Date: Fri Feb 14 23:28:52 2025 -0500 (smerge-refine-exchange-point): New command * lisp/vc/smerge-mode.el (smerge--refine-highlight-change): Allow empty region and always create an overlay. Also, remember any adjustment we applied the overlay's boundaries. (smerge-refine-regions): Always create two overlays per hunk and "connect" them via `smerge--refine-other`. (smerge-refine-exchange-point): New command. diff --git a/etc/NEWS b/etc/NEWS index 31109f0857c..51f481c763c 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -434,6 +434,11 @@ default is nil, which retains the old format. *** New command 'smerge-extend' extends a conflict over surrounding lines. +*** New command 'smerge-refine-exchange-point' to jump to the other side. +When used inside a refined chunk, it jumps to the matching position in +the "other" side of the refinement: if you're in the new text, it jumps +to the corresponding position in the old text and vice versa. + ** Image Dired *** 'image-dired-show-all-from-dir' takes the same first argument as 'dired'. diff --git a/lisp/vc/smerge-mode.el b/lisp/vc/smerge-mode.el index 5d172238a60..bce5822a042 100644 --- a/lisp/vc/smerge-mode.el +++ b/lisp/vc/smerge-mode.el @@ -505,6 +505,8 @@ This relies on mode-specific knowledge and thus only works in some major modes. Uses `smerge-resolve-function' to do the actual work." (interactive) (smerge-match-conflict) + ;; FIXME: This ends up removing the refinement-highlighting when no + ;; resolution is performed. (smerge-remove-props (match-beginning 0) (match-end 0)) (let ((md (match-data)) (m0b (match-beginning 0)) @@ -526,13 +528,12 @@ major modes. Uses `smerge-resolve-function' to do the actual work." (eq (match-beginning 1) (match-beginning 3))) (smerge-keep-n 3)) ;; Mode-specific conflict resolution. - ((condition-case nil - (atomic-change-group - (if safe - (funcall smerge-resolve-function safe) - (funcall smerge-resolve-function)) - t) - (error nil)) + ((ignore-errors + (atomic-change-group + (if safe + (funcall smerge-resolve-function safe) + (funcall smerge-resolve-function)) + t)) ;; Nothing to do: the resolution function has done it already. nil) ;; Non-conflict. @@ -653,11 +654,9 @@ major modes. Uses `smerge-resolve-function' to do the actual work." (save-excursion (goto-char (point-min)) (while (re-search-forward smerge-begin-re nil t) - (condition-case nil - (progn - (smerge-match-conflict) - (smerge-resolve 'safe)) - (error nil))))) + (with-demoted-errors "%S" + (smerge-match-conflict) + (smerge-resolve 'safe))))) (defun smerge-batch-resolve () ;; command-line-args-left is what is left of the command line. @@ -1038,25 +1037,62 @@ chars to try and eliminate some spurious differences." smerge-refine-forward-function) startline) (point))) - (end (progn (funcall (if smerge-refine-weight-hack - #'forward-char - smerge-refine-forward-function) - (if match-num2 - (- (string-to-number match-num2) - startline) - 1)) - (point)))) - (when smerge-refine-ignore-whitespace - (skip-chars-backward " \t\n" beg) (setq end (point)) - (goto-char beg) - (skip-chars-forward " \t\n" end) (setq beg (point))) - (when (> end beg) + (end (if (eq t match-num2) beg + (funcall (if smerge-refine-weight-hack + #'forward-char + smerge-refine-forward-function) + (if match-num2 + (- (string-to-number match-num2) + startline) + 1)) + (point)))) + (cl-assert (<= beg end)) + (when (and (eq t match-num2) (not (eolp))) + ;; FIXME: No idea where this off-by-one comes from, nor why it's only + ;; within lines. + (setq beg (1+ beg)) + (setq end (1+ end)) + (goto-char end)) + (let ((olbeg beg) + (olend end)) + (cond + ((> end beg) + (when smerge-refine-ignore-whitespace + (let* ((newend (progn (skip-chars-backward " \t\n" beg) (point))) + (newbeg (progn (goto-char beg) + (skip-chars-forward " \t\n" newend) (point)))) + (unless (= newend newbeg) + (push `(smerge--refine-adjust ,(- newbeg beg) . ,(- end newend)) + props) + (setq olend newend) + (setq olbeg newbeg))))) + (t + (cl-assert (= end beg)) + ;; If BEG=END, we have nothing to highlight, but we still want + ;; to create an overlay that we can find with char properties, + ;; so as to keep track of the position where a text was + ;; inserted/deleted, so make it span at a char. + (push (cond + ((< beg (point-max)) + (setq olend (1+ beg)) + '(smerge--refine-adjust 0 . -1)) + (t (cl-assert (< (point-min) end)) + (setq olbeg (1- end)) + '(smerge--refine-adjust -1 . 0))) + props))) + (let ((ol (make-overlay - beg end nil + olbeg olend nil ;; Make them tend to shrink rather than spread when editing. 'front-advance nil))) + ;; (overlay-put ol 'smerge--debug + ;; (list match-num1 match-num2 startline)) (overlay-put ol 'evaporate t) - (dolist (x props) (overlay-put ol (car x) (cdr x))) + (dolist (x props) + (when (or (> end beg) + ;; Don't highlight the char we cover artificially. + (not (memq (car-safe x) '(face font-lock-face)))) + (overlay-put ol (car x) (cdr x)))) ol))))) ;;;###autoload @@ -1118,20 +1154,20 @@ used to replace chars to try and eliminate some spurious differences." (m2 (match-string 2)) (m4 (match-string 4)) (m5 (match-string 5))) - (when (memq op '(?d ?c)) - (setq last1 - (smerge--refine-highlight-change - beg1 m1 m2 - ;; Try to use props-c only for changed chars, - ;; fallback to props-r for changed/removed chars, - ;; but if props-r is nil then fallback to props-c. - (or (and (eq op '?c) props-c) props-r props-c)))) - (when (memq op '(?a ?c)) - (setq last2 - (smerge--refine-highlight-change - beg2 m4 m5 - ;; Same logic as for removed chars above. - (or (and (eq op '?c) props-c) props-a props-c))))) + (setq last1 + (smerge--refine-highlight-change + beg1 m1 (if (eq op ?a) t m2) + ;; Try to use props-c only for changed chars, + ;; fallback to props-r for changed/removed chars, + ;; but if props-r is nil then fallback to props-c. + (or (and (eq op '?c) props-c) props-r props-c))) + (setq last2 + (smerge--refine-highlight-change + beg2 m4 (if (eq op ?d) t m5) + ;; Same logic as for removed chars above. + (or (and (eq op '?c) props-c) props-a props-c)))) + (overlay-put last1 'smerge--refine-other last2) + (overlay-put last2 'smerge--refine-other last1) (forward-line 1) ;Skip hunk header. (and (re-search-forward "^[0-9]" nil 'move) ;Skip hunk body. (goto-char (match-beginning 0)))) @@ -1206,6 +1242,54 @@ repeating the command will highlight other two parts." (unless smerge-use-changed-face '((smerge . refine) (font-lock-face . smerge-refined-added)))))) +(defun smerge-refine-exchange-point () + "Go to the matching position in the other chunk." + (interactive) + ;; FIXME: Chunks aren't marked in the same way for all users of + ;; `smerge-refine-regions' :-( + ;; (unless (get-char-property (point) 'smerge) + ;; (error "Not inside a refined chunk")) + (let* ((ref-pos + (if (or (get-char-property (point) 'smerge--refine-other) + (get-char-property (1- (point)) 'smerge--refine-other)) + (point) + ;; FIXME: Bound the search to the current chunk! + (let ((next (next-single-char-property-change + (point) 'smerge--refine-other)) + (prev (previous-single-char-property-change + (point) 'smerge--refine-other))) + (cond + ((and prev + (or (null next) + (> (- next (point)) (- (point) prev)))) + prev) + (t (or next + ;; FIXME: default to the bounds! + (user-error "No \"other\" position info found"))))))) + (boundary + (cond + ((< ref-pos (point)) + (let ((adjust (get-char-property (1- ref-pos) + 'smerge--refine-adjust))) + (min (point) (+ ref-pos (or (cdr adjust) 0))))) + ((> ref-pos (point)) + (let ((adjust (get-char-property ref-pos 'smerge--refine-adjust))) + (max (point) (- ref-pos (or (car adjust) 0))))) + (t ref-pos))) + (other-forw (get-char-property ref-pos 'smerge--refine-other)) + (other-back (get-char-property (1- ref-pos) 'smerge--refine-other)) + (other (or other-forw other-back)) + (dist (- boundary (point)))) + (if (not (overlay-start other)) + (user-error "The \"other\" position has vanished") + (goto-char + (- (if other-forw + (- (overlay-start other) + (or (car (overlay-get other 'smerge--refine-adjust)) 0)) + (+ (overlay-end other) + (or (cdr (overlay-get other 'smerge--refine-adjust)) 0))) + dist))))) + (defun smerge-swap () ;; FIXME: Extend for diff3 to allow swapping the middle end as well. "Swap the \"Upper\" and the \"Lower\" chunks. @@ -1470,7 +1554,9 @@ with a \\[universal-argument] prefix, makes up a 3-way conflict." (goto-char (point-min)) (while (smerge-find-conflict) (save-excursion - (font-lock-fontify-region (match-beginning 0) (match-end 0) nil))))) + (with-demoted-errors "%S" ;Those things do happen, occasionally. + (font-lock-fontify-region + (match-beginning 0) (match-end 0) nil)))))) (if (string-match (regexp-quote smerge-parsep-re) paragraph-separate) (unless smerge-mode (setq-local paragraph-separate commit 8d968c0f22347c9a4b65fdd142c0f050db918745 Author: Stefan Monnier Date: Fri Feb 14 23:05:29 2025 -0500 lisp/term/xterm.el (xterm--query-name-and-version): Don't quote lambda diff --git a/lisp/term/xterm.el b/lisp/term/xterm.el index 15101ebd59d..4f23a909b69 100644 --- a/lisp/term/xterm.el +++ b/lisp/term/xterm.el @@ -912,10 +912,10 @@ We run the first FUNCTION whose STRING matches the input events." (catch 'result (xterm--query "\e[>0q" - '(("\eP>|" . (lambda () - ;; The reply should be: \e P > | STRING \e \\ - (let ((str (xterm--read-string ?\e ?\\))) - (throw 'result str)))))) + `(("\eP>|" . ,(lambda () + ;; The reply should be: \e P > | STRING \e \\ + (let ((str (xterm--read-string ?\e ?\\))) + (throw 'result str)))))) nil))) (defun xterm--push-map (map basemap) commit b58552ca983ad37e51fb375bd45bd12a2beda3b2 Author: Yuan Fu Date: Fri Feb 14 17:44:02 2025 -0800 ; Another attempt at fixing c-ts-common--prev-standalone-sibling * lisp/progmodes/c-ts-common.el: (c-ts-common--prev-standalone-sibling): Fix. diff --git a/lisp/progmodes/c-ts-common.el b/lisp/progmodes/c-ts-common.el index 33365a3921b..7ebd0770a5d 100644 --- a/lisp/progmodes/c-ts-common.el +++ b/lisp/progmodes/c-ts-common.el @@ -632,7 +632,7 @@ for determining standlone line." (funcall treesit-simple-indent-standalone-predicate node) - (c-ts-common--standalone-predicate parent))))) + (c-ts-common--standalone-predicate node))))) (setq node (treesit-node-prev-sibling node 'named))) (if (numberp anchor) anchor (treesit-node-start node))))) commit dc86f59e926f618d4e3568a332b42ea0647a08ba Author: Stefan Kangas Date: Sat Feb 15 00:40:52 2025 +0100 Prefer `(defsubst A ...)` to `(cl-proclaim (inline A))` * lisp/emacs-lisp/cl-macs.el: Remove cl-proclaim... * lisp/emacs-lisp/cl-extra.el (cl-map, cl-notany, cl-notevery) (cl-revappend, cl-nreconc): * lisp/emacs-lisp/cl-lib.el (cl-acons): ...and use defsubst instead. (Bug#76294) diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 62e12217e0d..09470457d93 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -127,7 +127,7 @@ strings case-insensitively." (and acc (nreverse cl-res))))) ;;;###autoload -(defun cl-map (cl-type cl-func cl-seq &rest cl-rest) +(defsubst cl-map (cl-type cl-func cl-seq &rest cl-rest) "Map a FUNCTION across one or more SEQUENCEs, returning a sequence. TYPE is the sequence type to return. \n(fn TYPE FUNCTION SEQUENCE...)" @@ -239,14 +239,14 @@ non-nil value. (null cl-seq))) ;;;###autoload -(defun cl-notany (cl-pred cl-seq &rest cl-rest) +(defsubst cl-notany (cl-pred cl-seq &rest cl-rest) "Return true if PREDICATE is false of every element of SEQ or SEQs. \n(fn PREDICATE SEQ...)" (declare (important-return-value t)) (not (apply #'cl-some cl-pred cl-seq cl-rest))) ;;;###autoload -(defun cl-notevery (cl-pred cl-seq &rest cl-rest) +(defsubst cl-notevery (cl-pred cl-seq &rest cl-rest) "Return true if PREDICATE is false of some element of SEQ or SEQs. \n(fn PREDICATE SEQ...)" (declare (important-return-value t)) @@ -589,13 +589,13 @@ 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)) diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 883a13e3244..dba01b28325 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -535,7 +535,7 @@ Return a copy of TREE with all elements `eql' to OLD replaced by NEW. cl-tree (cons a d)))) (t cl-tree))) -(defun cl-acons (key value alist) +(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)) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 44fe67b6c85..caaffcf19be 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3725,10 +3725,6 @@ macro that returns its `&whole' argument." `(cl-getf (symbol-plist ,sym) ,prop ,def) `(get ,sym ,prop))) -;;; Things that are inline. -(cl-proclaim '(inline cl-acons cl-map cl-notany cl-notevery cl-revappend - cl-nreconc)) - ;;; Types and assertions. ;;;###autoload commit f05ce9e6bbe7202060580c122e033f5e4ac98e90 Author: Stefan Kangas Date: Fri Feb 14 22:46:07 2025 +0100 Inline important-return-value declarations in cl-lib.el These declarations are now properly added to 'cl-lib.el' itself, or to 'cl-loaddefs.el'. This means that they will now correctly show up immediately when loading 'cl-lib.el', instead of only after 'cl-macs.el' is pulled in by an autoload. C.f. Bug#76247. I did not considered worth reproducing everywhere the list saying which functions among the below belong to these two categories: 1. Functions that are side-effect-free except for the behavior of functions passed as argument. 2. Functions that mutate and return a list. AFAIU, this is not actionable with our current byte-compiler, i.e. we can't add any extra declarations based on it. However, if the list should be needed at some point, for example due to improvements in the compiler, this commit will be where to find it. In the worst case, and with more work, it's also deducible from the source code itself. * lisp/emacs-lisp/cl-macs.el: Move important-return-value declarations from here... * lisp/emacs-lisp/cl-extra.el (cl-map, cl-maplist, cl-mapcan) (cl-mapcon, cl-some, cl-every, cl-notany, cl-notevery, cl-nreconc): * lisp/emacs-lisp/cl-lib.el (cl-mapcar, cl-adjoin, cl-subst): * lisp/emacs-lisp/cl-seq.el (cl-reduce, cl-remove, cl-remove-if) (cl-remove-if-not, cl-delete, cl-delete-if, cl-delete-if-not) (cl-remove-duplicates, cl-delete-duplicates, cl-substitute) (cl-substitute-if, cl-substitute-if-not, cl-nsubstitute) (cl-nsubstitute-if, cl-nsubstitute-if-not, 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-mismatch, cl-search) (cl-sort, cl-stable-sort, cl-merge, cl-member, cl-member-if) (cl-member-if-not, cl-assoc, cl-assoc-if, cl-assoc-if-not, cl-rassoc) (cl-rassoc-if, cl-rassoc-if-not, cl-union, cl-nunion, cl-intersection) (cl-nintersection, cl-set-difference, cl-nset-difference) (cl-set-exclusive-or, cl-nset-exclusive-or, cl-subsetp, cl-subst-if) (cl-subst-if-not, cl-nsubst, cl-nsubst-if, cl-nsubst-if-not, cl-sublis) (cl-nsublis, cl-tree-equal): ...to have them inline here. diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 7732a848d3b..62e12217e0d 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -131,6 +131,7 @@ strings case-insensitively." "Map a FUNCTION across one or more SEQUENCEs, returning a sequence. TYPE is the sequence type to return. \n(fn TYPE FUNCTION SEQUENCE...)" + (declare (important-return-value t)) (let ((cl-res (apply #'cl-mapcar cl-func cl-seq cl-rest))) (and cl-type (cl-coerce cl-res cl-type)))) @@ -140,6 +141,7 @@ TYPE is the sequence type to return. Like `cl-mapcar', except applies to lists and their cdr's rather than to the elements themselves. \n(fn FUNCTION LIST...)" + (declare (important-return-value t)) (if cl-rest (let ((cl-res nil) (cl-args (cons cl-list (copy-sequence cl-rest))) @@ -189,6 +191,7 @@ the elements themselves. (defun cl-mapcan (cl-func cl-seq &rest cl-rest) "Like `cl-mapcar', but nconc's together the values returned by the function. \n(fn FUNCTION SEQUENCE...)" + (declare (important-return-value t)) (if cl-rest (apply #'nconc (apply #'cl-mapcar cl-func cl-seq cl-rest)) (mapcan cl-func cl-seq))) @@ -197,6 +200,7 @@ the elements themselves. (defun cl-mapcon (cl-func cl-list &rest cl-rest) "Like `cl-maplist', but nconc's together the values returned by the function. \n(fn FUNCTION LIST...)" + (declare (important-return-value t)) (apply #'nconc (apply #'cl-maplist cl-func cl-list cl-rest))) ;;;###autoload @@ -207,6 +211,7 @@ same as the first return value of PREDICATE where PREDICATE has a non-nil value. \n(fn PREDICATE SEQ...)" + (declare (important-return-value t)) (if (or cl-rest (nlistp cl-seq)) (catch 'cl-some (apply #'cl-map nil @@ -222,6 +227,7 @@ non-nil value. (defun cl-every (cl-pred cl-seq &rest cl-rest) "Return true if PREDICATE is true of every element of SEQ or SEQs. \n(fn PREDICATE SEQ...)" + (declare (important-return-value t)) (if (or cl-rest (nlistp cl-seq)) (catch 'cl-every (apply #'cl-map nil @@ -236,12 +242,14 @@ non-nil value. (defun cl-notany (cl-pred cl-seq &rest cl-rest) "Return true if PREDICATE is false of every element of SEQ or SEQs. \n(fn PREDICATE SEQ...)" + (declare (important-return-value t)) (not (apply #'cl-some cl-pred cl-seq cl-rest))) ;;;###autoload (defun cl-notevery (cl-pred cl-seq &rest cl-rest) "Return true if PREDICATE is false of some element of SEQ or SEQs. \n(fn PREDICATE SEQ...)" + (declare (important-return-value t)) (not (apply #'cl-every cl-pred cl-seq cl-rest))) ;;;###autoload @@ -589,6 +597,7 @@ too large if positive or too small if negative)." ;;;###autoload (defun cl-nreconc (x y) "Equivalent to (nconc (nreverse X) Y)." + (declare (important-return-value t)) (nconc (nreverse x) y)) ;;;###autoload diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 1ec850cf0e8..883a13e3244 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -369,6 +369,7 @@ 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...)" + (declare (important-return-value t)) (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) @@ -506,7 +507,8 @@ The elements of LIST are not copied, just the list structure itself." Otherwise, return LIST unmodified. \nKeywords supported: :test :test-not :key \n(fn ITEM LIST [KEYWORD VALUE]...)" - (declare (compiler-macro cl--compiler-macro-adjoin)) + (declare (important-return-value t) + (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))) @@ -519,6 +521,7 @@ Otherwise, return LIST unmodified. 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]...)" + (declare (important-return-value t)) (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))) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 1da218934ab..44fe67b6c85 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3729,46 +3729,6 @@ macro that returns its `&whole' argument." (cl-proclaim '(inline cl-acons cl-map cl-notany cl-notevery cl-revappend cl-nreconc)) - -;;; 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-seq.el b/lisp/emacs-lisp/cl-seq.el index 5b4337ad9cb..651de6c4d47 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -145,6 +145,7 @@ 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)) @@ -235,6 +236,7 @@ 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]...)" + (declare (important-return-value t)) (cl--parsing-keywords (:test :test-not :key :if :if-not :count :from-end (:start 0) :end) () (let ((len (length cl-seq))) @@ -282,6 +284,7 @@ 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]...)" + (declare (important-return-value t)) (apply 'cl-remove nil cl-list :if cl-pred cl-keys)) ;;;###autoload @@ -291,6 +294,7 @@ 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]...)" + (declare (important-return-value t)) (apply 'cl-remove nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload @@ -299,6 +303,7 @@ to avoid corrupting the original 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]...)" + (declare (important-return-value t)) (cl--parsing-keywords (:test :test-not :key :if :if-not :count :from-end (:start 0) :end) () (let ((len (length cl-seq))) @@ -344,6 +349,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. 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]...)" + (declare (important-return-value t)) (apply 'cl-delete nil cl-list :if cl-pred cl-keys)) ;;;###autoload @@ -352,6 +358,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. 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]...)" + (declare (important-return-value t)) (apply 'cl-delete nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload @@ -359,6 +366,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. "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]...)" + (declare (important-return-value t)) (cl--delete-duplicates cl-seq cl-keys t)) ;;;###autoload @@ -366,6 +374,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. "Remove all duplicate elements from SEQ (destructively). \nKeywords supported: :test :test-not :key :start :end :from-end \n(fn SEQ [KEYWORD VALUE]...)" + (declare (important-return-value t)) (cl--delete-duplicates cl-seq cl-keys nil)) (defun cl--delete-duplicates (cl-seq cl-keys cl-copy) @@ -417,6 +426,7 @@ 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]...)" + (declare (important-return-value t)) (cl--parsing-keywords (:test :test-not :key :if :if-not :count (:start 0) :end :from-end) () (if (or (eq cl-old cl-new) @@ -441,6 +451,7 @@ 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]...)" + (declare (important-return-value t)) (apply 'cl-substitute cl-new nil cl-list :if cl-pred cl-keys)) ;;;###autoload @@ -450,6 +461,7 @@ 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]...)" + (declare (important-return-value t)) (apply 'cl-substitute cl-new nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload @@ -458,6 +470,7 @@ to avoid corrupting the original 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]...)" + (declare (important-return-value t)) (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)) @@ -494,6 +507,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. 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]...)" + (declare (important-return-value t)) (apply 'cl-nsubstitute cl-new nil cl-list :if cl-pred cl-keys)) ;;;###autoload @@ -502,6 +516,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. 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]...)" + (declare (important-return-value t)) (apply 'cl-nsubstitute cl-new nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload @@ -510,6 +525,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. 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]...)" + (declare (important-return-value t)) (let ((cl-pos (apply 'cl-position cl-item cl-seq cl-keys))) (and cl-pos (elt cl-seq cl-pos)))) @@ -519,6 +535,7 @@ Return the matching ITEM, or nil if not found. Return the matching item, or nil if not found. \nKeywords supported: :key :start :end :from-end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" + (declare (important-return-value t)) (apply 'cl-find nil cl-list :if cl-pred cl-keys)) ;;;###autoload @@ -527,6 +544,7 @@ Return the matching item, or nil if not found. Return the matching item, or nil if not found. \nKeywords supported: :key :start :end :from-end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" + (declare (important-return-value t)) (apply 'cl-find nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload @@ -535,6 +553,7 @@ Return the matching item, or nil if not found. 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]...)" + (declare (important-return-value t)) (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))) @@ -565,6 +584,7 @@ Return the index of the matching item, or nil if not found. 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]...)" + (declare (important-return-value t)) (apply 'cl-position nil cl-list :if cl-pred cl-keys)) ;;;###autoload @@ -573,6 +593,7 @@ Return the index of the matching item, or nil if not found. 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]...)" + (declare (important-return-value t)) (apply 'cl-position nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload @@ -580,6 +601,7 @@ Return the index of the matching item, or nil if not found. "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))) @@ -595,6 +617,7 @@ Return the index of the matching item, or nil if not found. "Count the number of items satisfying PREDICATE in SEQ. \nKeywords supported: :key :start :end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" + (declare (important-return-value t)) (apply 'cl-count nil cl-list :if cl-pred cl-keys)) ;;;###autoload @@ -602,6 +625,7 @@ Return the index of the matching item, or nil if not found. "Count the number of items not satisfying PREDICATE in SEQ. \nKeywords supported: :key :start :end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" + (declare (important-return-value t)) (apply 'cl-count nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload @@ -611,6 +635,7 @@ 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]...)" + (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 cl-seq1))) @@ -642,6 +667,7 @@ 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]...)" + (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 cl-seq1))) @@ -668,6 +694,9 @@ return nil if there are no matches. This is a destructive function; it reuses the storage of SEQ if possible. \nKeywords supported: :key \n(fn SEQ PREDICATE [KEYWORD VALUE]...)" + ;; It's safe to ignore the return value when used on arrays, + ;; but most calls pass lists. + (declare (important-return-value t)) (if (nlistp cl-seq) (if (stringp cl-seq) (concat (apply #'cl-sort (vconcat cl-seq) cl-pred cl-keys)) @@ -686,6 +715,9 @@ This is a destructive function; it reuses the storage of SEQ if possible. This is a destructive function; it reuses the storage of SEQ if possible. \nKeywords supported: :key \n(fn SEQ PREDICATE [KEYWORD VALUE]...)" + ;; 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 cl-seq cl-pred cl-keys)) ;;;###autoload @@ -695,6 +727,7 @@ 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]...)" + (declare (important-return-value t)) (or (listp cl-seq1) (setq cl-seq1 (append cl-seq1 nil))) (or (listp cl-seq2) (setq cl-seq2 (append cl-seq2 nil))) (cl--parsing-keywords (:key) () @@ -712,7 +745,8 @@ sequences, and PREDICATE is a `less-than' predicate on the elements. 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)))) @@ -727,6 +761,7 @@ Return the sublist of LIST whose car is ITEM. Return the sublist of LIST whose car matches. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" + (declare (important-return-value t)) (apply 'cl-member nil cl-list :if cl-pred cl-keys)) ;;;###autoload @@ -735,6 +770,7 @@ Return the sublist of LIST whose car matches. Return the sublist of LIST whose car matches. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" + (declare (important-return-value t)) (apply 'cl-member nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload @@ -749,7 +785,8 @@ Return the sublist of LIST whose car matches. "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 @@ -767,6 +804,7 @@ Return the sublist of LIST whose car matches. "Find the first item whose car satisfies PREDICATE in LIST. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" + (declare (important-return-value t)) (apply 'cl-assoc nil cl-list :if cl-pred cl-keys)) ;;;###autoload @@ -774,6 +812,7 @@ Return the sublist of LIST whose car matches. "Find the first item whose car does not satisfy PREDICATE in LIST. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" + (declare (important-return-value t)) (apply 'cl-assoc nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload @@ -781,6 +820,7 @@ Return the sublist of LIST whose car matches. "Find the first item whose cdr matches ITEM in LIST. \nKeywords supported: :test :test-not :key \n(fn ITEM LIST [KEYWORD VALUE]...)" + (declare (important-return-value t)) (if (or cl-keys (numberp cl-item)) (cl--parsing-keywords (:test :test-not :key :if :if-not) () (while (and cl-alist @@ -795,6 +835,7 @@ Return the sublist of LIST whose car matches. "Find the first item whose cdr satisfies PREDICATE in LIST. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" + (declare (important-return-value t)) (apply 'cl-rassoc nil cl-list :if cl-pred cl-keys)) ;;;###autoload @@ -802,6 +843,7 @@ Return the sublist of LIST whose car matches. "Find the first item whose cdr does not satisfy PREDICATE in LIST. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" + (declare (important-return-value t)) (apply 'cl-rassoc nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload @@ -812,6 +854,7 @@ 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]...)" + (declare (important-return-value t)) (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) ((and (not cl-keys) (equal cl-list1 cl-list2)) cl-list1) (t @@ -834,6 +877,7 @@ 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]...)" + (declare (important-return-value t)) (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) (t (apply 'cl-union cl-list1 cl-list2 cl-keys)))) @@ -845,6 +889,7 @@ 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]...)" + (declare (important-return-value t)) (and cl-list1 cl-list2 (if (equal cl-list1 cl-list2) cl-list1 (cl--parsing-keywords (:key) (:test :test-not) @@ -868,6 +913,7 @@ 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]...)" + (declare (important-return-value t)) (and cl-list1 cl-list2 (apply 'cl-intersection cl-list1 cl-list2 cl-keys))) ;;;###autoload @@ -878,6 +924,7 @@ 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]...)" + (declare (important-return-value t)) (if (or (null cl-list1) (null cl-list2)) cl-list1 (cl--parsing-keywords (:key) (:test :test-not) (let ((cl-res nil)) @@ -898,6 +945,7 @@ 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]...)" + (declare (important-return-value t)) (if (or (null cl-list1) (null cl-list2)) cl-list1 (apply 'cl-set-difference cl-list1 cl-list2 cl-keys))) @@ -909,6 +957,7 @@ 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]...)" + (declare (important-return-value t)) (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) @@ -922,6 +971,7 @@ 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]...)" + (declare (important-return-value t)) (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) @@ -933,6 +983,7 @@ whenever possible. I.e., if every element of LIST1 also appears in LIST2. \nKeywords supported: :test :test-not :key \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" + (declare (important-return-value t)) (cond ((null cl-list1) t) ((null cl-list2) nil) ((equal cl-list1 cl-list2) t) (t (cl--parsing-keywords (:key) (:test :test-not) @@ -948,6 +999,7 @@ I.e., if every element of LIST1 also appears in LIST2. Return a copy of TREE with all matching elements replaced by NEW. \nKeywords supported: :key \n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" + (declare (important-return-value t)) (apply 'cl-sublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys)) ;;;###autoload @@ -956,6 +1008,7 @@ Return a copy of TREE with all matching elements replaced by NEW. Return a copy of TREE with all non-matching elements replaced by NEW. \nKeywords supported: :key \n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" + (declare (important-return-value t)) (apply 'cl-sublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) ;;;###autoload @@ -965,6 +1018,7 @@ 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]...)" + (declare (important-return-value t)) (apply 'cl-nsublis (list (cons cl-old cl-new)) cl-tree cl-keys)) ;;;###autoload @@ -973,6 +1027,7 @@ to `setcar'). 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]...)" + (declare (important-return-value t)) (apply 'cl-nsublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys)) ;;;###autoload @@ -981,6 +1036,7 @@ Any element of TREE which matches is changed to NEW (via a call to `setcar'). 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]...)" + (declare (important-return-value t)) (apply 'cl-nsublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) (defvar cl--alist) @@ -991,6 +1047,7 @@ Any element of TREE which matches is changed to NEW (via a call to `setcar'). 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)))) @@ -1014,6 +1071,7 @@ Return a copy of TREE with all matching elements replaced. 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)) @@ -1040,6 +1098,7 @@ Any matching element of TREE is changed via a call to `setcar'. 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))) commit ac9cf20919c46169a2e3aaa2b75ccb37dd5b5ff1 Author: Yuan Fu Date: Fri Feb 14 08:36:24 2025 -0800 ; Fix c-ts-common--prev-standalone-sibling * lisp/progmodes/c-ts-common.el: (c-ts-common--prev-standalone-sibling): Fix. diff --git a/lisp/progmodes/c-ts-common.el b/lisp/progmodes/c-ts-common.el index c3a965b8e94..33365a3921b 100644 --- a/lisp/progmodes/c-ts-common.el +++ b/lisp/progmodes/c-ts-common.el @@ -631,10 +631,10 @@ for determining standlone line." (if treesit-simple-indent-standalone-predicate (funcall treesit-simple-indent-standalone-predicate - parent) + node) (c-ts-common--standalone-predicate parent))))) - (setq node (treesit-node-prev-sibling node 'named)))) - (if (numberp anchor) anchor (treesit-node-start node)))) + (setq node (treesit-node-prev-sibling node 'named))) + (if (numberp anchor) anchor (treesit-node-start node))))) (defun c-ts-common-parent-ignore-preproc (node) "Return the parent of NODE, skipping preproc nodes." commit 300bae4f7c75291c1d1af0eced102ce9b1c44000 Author: Stefan Monnier Date: Fri Feb 14 11:25:52 2025 -0500 Fix some uses of `%s` for non-strings/names * lisp/files.el (normal-mode, set-auto-mode--apply-alist): * lisp/gnus/nnimap.el (nnimap-command): * lisp/emacs-lisp/bytecomp.el (bytecomp--check-cus-type): Prefer %S over %s for arbitrary sexps and lists. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 2ddbb2ec1da..e48cac6c9b1 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -5275,11 +5275,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)) @@ -5287,7 +5287,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)) @@ -5299,13 +5299,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))))) @@ -5317,7 +5317,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)) @@ -5333,21 +5333,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)) ))) @@ -5355,9 +5355,9 @@ 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) diff --git a/lisp/files.el b/lisp/files.el index 499f062932f..a71d0c5c9d0 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -2970,13 +2970,13 @@ the local variables spec." (let ((enable-local-variables (or (not find-file) enable-local-variables))) ;; FIXME this is less efficient than it could be, since both ;; s-a-m and h-l-v may parse the same regions, looking for "mode:". - (with-demoted-errors "File mode specification error: %s" + (with-demoted-errors "File mode specification error: %S" (set-auto-mode)) ;; `delay-mode-hooks' being non-nil will have prevented the major ;; mode's call to `run-mode-hooks' from calling ;; `hack-local-variables'. In that case, call it now. (when delay-mode-hooks - (with-demoted-errors "File local-variables error: %s" + (with-demoted-errors "File local-variables error: %S" (hack-local-variables 'no-mode)))) ;; Turn font lock off and on, to make sure it takes account of ;; whatever file local variables are relevant to it. @@ -3517,7 +3517,7 @@ extra checks should be done." alist name case-insensitive-p)) (when (and dir-local mode (not (set-auto-mode--dir-local-valid-p mode))) - (message "Ignoring invalid mode `%s'" mode) + (message "Ignoring invalid mode `%S'" mode) (setq mode nil)) (when mode (set-auto-mode-0 mode keep-mode-if-same) diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index f63138300b1..4965e66503a 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -2004,7 +2004,7 @@ Return the server's response to the SELECT or EXAMINE command." (cons t response) (nnheader-report 'nnimap "%s" (mapconcat (lambda (a) - (format "%s" a)) + (format "%S" a)) (car response) " ")) nil))) diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 517b3d9f4f3..5906f8a0571 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -1550,6 +1550,9 @@ else cover the whole buffer." (defvar whitespace-style) (defvar whitespace-trailing-regexp) +;; Prevent applying `view-read-only' to diff-mode buffers (bug#75993). +;; We don't derive from `special-mode' because that would inhibit the +;; `self-insert-command' binding of normal keys. (put 'diff-mode 'mode-class 'special) ;;;###autoload (define-derived-mode diff-mode fundamental-mode "Diff" commit b967891088db359fe16ce8317441e930651fb2ea Author: Robert Pluim Date: Fri Feb 14 11:56:19 2025 +0100 Correct docstrings describing "Re" alternatives. * lisp/mail/mail-utils.el (mail-re-regexps): Use "Re", not "Re:". * lisp/mail/rmail.el (rmail-re-abbrevs): Here also. diff --git a/lisp/mail/mail-utils.el b/lisp/mail/mail-utils.el index 5ddcb4b7686..d7748ffe6aa 100644 --- a/lisp/mail/mail-utils.el +++ b/lisp/mail/mail-utils.el @@ -63,7 +63,7 @@ also the To field, unless this would leave an empty To field." '("RE" "R\u00c9\\.?" "FWD?" "رد" "回复" "回覆" "SV" "Antw\\.?" "VS" "REF" "AW" "ΑΠ" "ΣΧΕΤ" "השב" "Vá" "R" "RIF" "BLS" "RES" "Odp" "YNT" "ATB") - "List of localized \"Re:\" abbreviations in various languages. + "List of localized \"Re\" abbreviations in various languages. Each component can be a regular expression or a simple string. Matching is done case-insensitively. Used to initialize the legacy `rmail-re-abbrevs' and `message-subject-re-regexp' user options." diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el index 4b93f379c72..0d657aea8a1 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -537,7 +537,7 @@ Examples: (concat "\\(" (string-join mail-re-regexps "\\|") "\\)") - "Regexp with localized \"Re:\" abbreviations in various languages. + "Regexp with localized \"Re\" abbreviations in various languages. Matching is done case-insensitively. Initialized from `mail-re-regexps', which is easier to customize." :set-after '(mail-re-regexps) commit 7c22f13ba394d47992a0df3678d23b5bd3da3820 Author: Stefan Kangas Date: Fri Feb 14 16:09:32 2025 +0100 ; * doc/misc/message.texi (Message Headers): Improve wording. (Bug#72442) diff --git a/doc/misc/message.texi b/doc/misc/message.texi index 418eb14e042..5cad78b4c48 100644 --- a/doc/misc/message.texi +++ b/doc/misc/message.texi @@ -1695,7 +1695,7 @@ result is inserted. Responses to messages have subjects that start with @samp{Re: }. This is @emph{not} an abbreviation of the English word ``response'', but it comes from the Latin ``res'', and means ``in the matter of''. Some -standards-challenged companies have failed to grasp this fact, and have +companies, seemingly allergic to standards, have failed to grasp this fact, and have ``internationalized'' their software to use abominations like @samp{Aw: } (``antwort'') or @samp{Sv: } (``svar'') instead, which is meaningless and evil. However, you may have to deal with users that commit 2b68e3f48b81dd0303f3f7e83f8c62ebc26e87df Author: Basil L. Contovounesios Date: Fri Feb 14 15:36:19 2025 +0100 ; Suppress obsoletion warning in package-x tests. diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el index f13ac3fa8d8..b779dcee393 100644 --- a/test/lisp/emacs-lisp/package-tests.el +++ b/test/lisp/emacs-lisp/package-tests.el @@ -826,7 +826,8 @@ but with a different end of line convention (bug#48137)." ;;; Tests for package-x features. -(require 'package-x) +(with-suppressed-warnings ((obsolete package-x)) + (require 'package-x)) (defvar package-x-test--single-archive-entry-1-3 (cons 'simple-single commit ac143186c04ffd729cfe11abd99f02abdf742f64 Author: Basil L. Contovounesios Date: Sun Feb 2 18:05:57 2025 +0100 Document cl-n... set operations consistently The docstrings of cl-nintersection and cl-nset-difference have been inconsistent with their manual entries since the beginning of emacs.git history (bug#76017). This patch settles on the weaker and thus backward-compatible requirement that only their first argument be safe to mutate. * lisp/emacs-lisp/bytecomp.el: Include only first argument in mutates-arguments property. * lisp/emacs-lisp/cl-seq.el (cl-nintersection, cl-nset-difference): Make docstring consistent with manual in that the second argument is not modified. * test/lisp/emacs-lisp/cl-seq-tests.el (cl-nintersection-test) (cl-nset-difference-test): Simplify. (cl-nset-difference): Pass fresh list as second argument, otherwise destructive modifications to it could go undetected. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 931b155313e..2ddbb2ec1da 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3583,7 +3583,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) diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index 1878153f811..5b4337ad9cb 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -864,8 +864,8 @@ to avoid corrupting the original LIST1 and LIST2. (defun cl-nintersection (cl-list1 cl-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))) @@ -894,8 +894,8 @@ to avoid corrupting the original LIST1 and LIST2. (defun cl-nset-difference (cl-list1 cl-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 diff --git a/test/lisp/emacs-lisp/cl-seq-tests.el b/test/lisp/emacs-lisp/cl-seq-tests.el index 2348a7fc812..f72596e4a4b 100644 --- a/test/lisp/emacs-lisp/cl-seq-tests.el +++ b/test/lisp/emacs-lisp/cl-seq-tests.el @@ -914,18 +914,18 @@ Additionally register an `ert-info' to help identify test failures." (ert-deftest cl-nintersection-test () (should-not (cl-nintersection () ())) - (should-not (cl-nintersection () (list 1 2 3))) - (should-not (cl-nintersection (list 1 2) (list 3 4))) - (should (equal (cl-nintersection (list 1 2 3 4) (list 3 4 5 6)) + (should-not (cl-nintersection () '(1 2 3))) + (should-not (cl-nintersection (list 1 2) '(3 4))) + (should (equal (cl-nintersection (list 1 2 3 4) '(3 4 5 6)) '(4 3))) - (should (equal (cl-nintersection (list 1 2 3) (list 1 2 3)) + (should (equal (cl-nintersection (list 1 2 3) '(1 2 3)) '(1 2 3))) - (should (equal (cl-nintersection (list 1 1 2 2 3) (list 2 2 3 4)) + (should (equal (cl-nintersection (list 1 1 2 2 3) '(2 2 3 4)) '(3 2 2))) (should (equal (cl-nintersection (list 1 (copy-sequence "two") 3) - (list 3 "two" 4)) + '(3 "two" 4)) '(3))) - (should (equal (cl-nintersection (list 1 2 3) (list 3 2 1) :test #'equal) + (should (equal (cl-nintersection (list 1 2 3) '(3 2 1) :test #'equal) '(1 2 3)))) (ert-deftest cl-set-difference-test () @@ -961,47 +961,49 @@ Additionally register an `ert-info' to help identify test failures." (ert-deftest cl-nset-difference () ;; Our nset-difference doesn't preserve order. - (let* ((l1 (list 1 2 3 4)) (l2 '(3 4 5 6)) + (let* ((l1 (list 1 2 3 4)) (l2 (list 3 4 5 6)) (diff (cl-nset-difference l1 l2))) (should (memq 1 diff)) (should (memq 2 diff)) - (should (= (length diff) 2)) + (should (length= diff 2)) (should (equal l2 '(3 4 5 6)))) - (let* ((l1 (list "1" "2" "3" "4")) (l2 '("3" "4" "5" "6")) + (let* ((l1 (list "1" "2" "3" "4")) (l2 (list "3" "4" "5" "6")) (diff (cl-nset-difference l1 l2 :test #'equal))) (should (member "1" diff)) (should (member "2" diff)) - (should (= (length diff) 2)) + (should (length= diff 2)) (should (equal l2 '("3" "4" "5" "6")))) (let* ((l1 (list '(a . 1) '(b . 2) '(c . 3) '(d . 4))) (l2 (list '(c . 3) '(d . 4) '(e . 5) '(f . 6))) (diff (cl-nset-difference l1 l2 :key #'car))) (should (member '(a . 1) diff)) (should (member '(b . 2) diff)) - (should (= (length diff) 2))) + (should (length= diff 2)) + (should (equal l2 '((c . 3) (d . 4) (e . 5) (f . 6))))) (let* ((l1 (list '("a" . 1) '("b" . 2) '("c" . 3) '("d" . 4))) (l2 (list '("c" . 3) '("d" . 4) '("e" . 5) '("f" . 6))) (diff (cl-nset-difference l1 l2 :key #'car :test #'string=))) (should (member '("a" . 1) diff)) (should (member '("b" . 2) diff)) - (should (= (length diff) 2)))) + (should (length= diff 2)) + (should (equal l2 '(("c" . 3) ("d" . 4) ("e" . 5) ("f" . 6)))))) (ert-deftest cl-nset-difference-test () (should-not (cl-nset-difference () ())) (should-not (cl-nset-difference () (list 1 2 3))) - (should-not (cl-nset-difference (list 1 2 3) (list 1 2 3))) - (should-not (cl-nset-difference (list 1 2 3) (list 3 2 1) :test #'equal)) + (should-not (cl-nset-difference (list 1 2 3) '(1 2 3))) + (should-not (cl-nset-difference (list 1 2 3) '(3 2 1) :test #'equal)) (should (equal (cl-nset-difference (list 1 2 3) ()) '(1 2 3))) - (should (equal (cl-nset-difference (list 1 2 3 4) (list 3 4 5 6)) + (should (equal (cl-nset-difference (list 1 2 3 4) '(3 4 5 6)) '(1 2))) - (should (equal (cl-nset-difference (list 1 1 2 2 3) (list 3 4 5)) + (should (equal (cl-nset-difference (list 1 1 2 2 3) '(3 4 5)) '(1 1 2 2))) - (should (equal (cl-nset-difference (list 1 2 3) (list 3 2 4)) + (should (equal (cl-nset-difference (list 1 2 3) '(3 2 4)) '(1))) - (should (equal (cl-nset-difference (list 1 2 3 4 5) (list 3 4 5 6 7)) + (should (equal (cl-nset-difference (list 1 2 3 4 5) '(3 4 5 6 7)) '(1 2))) - (should (equal (cl-nset-difference (list 1 (copy-sequence "a")) (list 1 "a")) + (should (equal (cl-nset-difference (list 1 (copy-sequence "a")) '(1 "a")) '("a")))) (ert-deftest cl-set-exclusive-or-test () commit 0edf094e54c721f6039b878cafb8ed02fac74a0f Author: Basil L. Contovounesios Date: Sun Feb 2 17:18:52 2025 +0100 Consolidate some cl-lib tests For discussion, see bug#75633#16 and the following thread: https://lists.gnu.org/r/emacs-devel/2025-02/msg00053.html * test/lisp/emacs-lisp/cl-extra-tests.el (cl-lib-test-remprop) (cl-lib-test-coerce-to-vector, cl-parse-integer): Move here from cl-lib-tests.el. (cl-extra-test-remprop): Remove duplicate test, folding body... (cl-get): ...into this test. (cl-extra-test-concatenate): Remove duplicate test, folding body... (cl-concatenate): ...into this test. * test/lisp/emacs-lisp/cl-lib-tests.el: Update historic commentary. (cl-lib-test-remprop, cl-lib-test-coerce-to-vector) (cl-parse-integer): Move to cl-extra-tests.el. (cl-lib-test-remove-if-not, cl-lib-test-remove) (cl-lib-test-set-functions, cl-lib-test-string-position) (cl-lib-test-mismatch, cl-nset-difference): Move to cl-seq-tests.el. (cl-lib-test-gensym, cl-lib-keyword-names-versus-values) (cl-lib-empty-keyargs, mystruct, cl-lib-struct-accessors) (cl-lib-struct-constructors, cl-lib-arglist-performance, cl-the) (cl-flet-test, cl-lib-test-typep, cl-lib-symbol-macrolet) (cl-lib-symbol-macrolet-4+5, cl-lib-symbol-macrolet-2) (cl-lib-symbol-macrolet-hide, cl-lib-defstruct-record): Move to cl-macs-tests.el. (cl-lib-test-endp): Remove duplicate test, folding body into cl-seq-endp-test. (cl-lib-set-difference): Remove duplicate test, folding body into cl-set-difference-test. * test/lisp/emacs-lisp/cl-macs-tests.el: Do not require cl-macs and pcase. (mystruct, cl-lib-struct-accessors, cl-lib-struct-constructors) (cl-lib-arglist-performance, cl-lib-defstruct-record) (cl-lib-symbol-macrolet, cl-lib-symbol-macrolet-4+5) (cl-lib-symbol-macrolet-2, cl-lib-symbol-macrolet-hide, cl-flet-test) (cl-lib-keyword-names-versus-values, cl-lib-empty-keyargs) (cl-lib-test-gensym, cl-the, cl-lib-test-typep): Move here from cl-lib-tests.el. (cl-case-error, cl-case-warning): Fix indentation. * test/lisp/emacs-lisp/cl-seq-tests.el: Require cl-lib rather than cl-seq. (cl-seq-endp-test): Absorb body of cl-lib-test-endp. (cl-lib-test-remove, cl-lib-test-remove-if-not) (cl-lib-test-string-position, cl-lib-test-mismatch) (cl-lib-test-set-functions, cl-nset-difference): Move here from cl-lib-tests.el. (cl-set-difference-test): Absorb body of cl-lib-set-difference. diff --git a/test/lisp/emacs-lisp/cl-extra-tests.el b/test/lisp/emacs-lisp/cl-extra-tests.el index bec4e373201..75533b36f29 100644 --- a/test/lisp/emacs-lisp/cl-extra-tests.el +++ b/test/lisp/emacs-lisp/cl-extra-tests.el @@ -22,12 +22,55 @@ (require 'cl-lib) (require 'ert) +(ert-deftest cl-lib-test-remprop () + (let ((x (cl-gensym))) + (should (equal (symbol-plist x) '())) + ;; Remove nonexistent property on empty plist. + (cl-remprop x 'b) + (should (equal (symbol-plist x) '())) + (put x 'a 1) + (should (equal (symbol-plist x) '(a 1))) + ;; Remove nonexistent property on nonempty plist. + (cl-remprop x 'b) + (should (equal (symbol-plist x) '(a 1))) + (put x 'b 2) + (put x 'c 3) + (put x 'd 4) + (should (equal (symbol-plist x) '(a 1 b 2 c 3 d 4))) + ;; Remove property that is neither first nor last. + (cl-remprop x 'c) + (should (equal (symbol-plist x) '(a 1 b 2 d 4))) + ;; Remove last property from a plist of length >1. + (cl-remprop x 'd) + (should (equal (symbol-plist x) '(a 1 b 2))) + ;; Remove first property from a plist of length >1. + (cl-remprop x 'a) + (should (equal (symbol-plist x) '(b 2))) + ;; Remove property when there is only one. + (cl-remprop x 'b) + (should (equal (symbol-plist x) '())))) + (ert-deftest cl-get () (put 'cl-get-test 'x 1) (put 'cl-get-test 'y nil) (should (eq (cl-get 'cl-get-test 'x) 1)) (should (eq (cl-get 'cl-get-test 'y :none) nil)) - (should (eq (cl-get 'cl-get-test 'z :none) :none))) + (should (eq (cl-get 'cl-get-test 'z :none) :none)) + (let ((sym (make-symbol "test"))) + (put sym 'foo 'bar) + (should (equal (cl-get sym 'foo) 'bar)) + (cl-remprop sym 'foo) + (should (equal (cl-get sym 'foo 'default) 'default)))) + +(ert-deftest cl-lib-test-coerce-to-vector () + (let* ((a (vector)) + (b (vector 1 a 3)) + (c (list)) + (d (list b a))) + (should (eql (cl-coerce a 'vector) a)) + (should (eql (cl-coerce b 'vector) b)) + (should (equal (cl-coerce c 'vector) (vector))) + (should (equal (cl-coerce d 'vector) (vector b a))))) (ert-deftest cl-extra-test-coerce () (should (equal (cl-coerce "abc" 'list) '(?a ?b ?c))) @@ -152,7 +195,8 @@ (should (equal (cl-concatenate 'vector [1 2 3] [4 5 6]) [1 2 3 4 5 6])) (should (equal (cl-concatenate 'string "123" "456") - "123456"))) + "123456")) + (should (equal (cl-concatenate 'list '(1 2) '(3 4) '(5 6)) '(1 2 3 4 5 6)))) (ert-deftest cl-extra-test-mapcan () (should (equal (cl-mapcan #'list '(1 2 3)) '(1 2 3))) @@ -258,6 +302,17 @@ (should (equal (cl-signum -10) -1)) (should (equal (cl-signum 0) 0))) +(ert-deftest cl-parse-integer () + (should-error (cl-parse-integer "abc")) + (should (null (cl-parse-integer "abc" :junk-allowed t))) + (should (null (cl-parse-integer "" :junk-allowed t))) + (should (= 342391 (cl-parse-integer "0123456789" :radix 8 :junk-allowed t))) + (should-error (cl-parse-integer "0123456789" :radix 8)) + (should (= -239 (cl-parse-integer "-efz" :radix 16 :junk-allowed t))) + (should-error (cl-parse-integer "efz" :radix 16)) + (should (= 239 (cl-parse-integer "zzef" :radix 16 :start 2))) + (should (= -123 (cl-parse-integer " -123 ")))) + (ert-deftest cl-extra-test-parse-integer () (should (equal (cl-parse-integer "10") 10)) (should (equal (cl-parse-integer "-10") -10)) @@ -274,10 +329,6 @@ (should (equal (cl-subseq '(1 2 3 4 5) 2) '(3 4 5))) (should (equal (cl-subseq '(1 2 3 4 5) 1 3) '(2 3)))) -(ert-deftest cl-extra-test-concatenate () - (should (equal (cl-concatenate 'string "hello " "world") "hello world")) - (should (equal (cl-concatenate 'list '(1 2) '(3 4) '(5 6)) '(1 2 3 4 5 6)))) - (ert-deftest cl-extra-test-revappend () (should (equal (cl-revappend '(1 2 3) '(4 5 6)) '(3 2 1 4 5 6)))) @@ -297,11 +348,4 @@ (should (cl-tailp l l)) (should (not (cl-tailp '(4 5) l))))) -(ert-deftest cl-extra-test-remprop () - (let ((sym (make-symbol "test"))) - (put sym 'foo 'bar) - (should (equal (cl-get sym 'foo) 'bar)) - (cl-remprop sym 'foo) - (should (equal (cl-get sym 'foo 'default) 'default)))) - ;;; cl-extra-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index ff860d94468..12de268bced 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -19,229 +19,14 @@ ;;; Commentary: -;; Extracted from ert-tests.el, back when ert used to reimplement some -;; cl functions. +;; Some of these tests were extracted from ert-tests.el, back when ert +;; used to reimplement some cl functions. ;;; Code: (require 'cl-lib) (require 'ert) -(ert-deftest cl-lib-test-remprop () - (let ((x (cl-gensym))) - (should (equal (symbol-plist x) '())) - ;; Remove nonexistent property on empty plist. - (cl-remprop x 'b) - (should (equal (symbol-plist x) '())) - (put x 'a 1) - (should (equal (symbol-plist x) '(a 1))) - ;; Remove nonexistent property on nonempty plist. - (cl-remprop x 'b) - (should (equal (symbol-plist x) '(a 1))) - (put x 'b 2) - (put x 'c 3) - (put x 'd 4) - (should (equal (symbol-plist x) '(a 1 b 2 c 3 d 4))) - ;; Remove property that is neither first nor last. - (cl-remprop x 'c) - (should (equal (symbol-plist x) '(a 1 b 2 d 4))) - ;; Remove last property from a plist of length >1. - (cl-remprop x 'd) - (should (equal (symbol-plist x) '(a 1 b 2))) - ;; Remove first property from a plist of length >1. - (cl-remprop x 'a) - (should (equal (symbol-plist x) '(b 2))) - ;; Remove property when there is only one. - (cl-remprop x 'b) - (should (equal (symbol-plist x) '())))) - -(ert-deftest cl-lib-test-remove-if-not () - (let ((list (list 'a 'b 'c 'd)) - (i 0)) - (let ((result (cl-remove-if-not (lambda (x) - (should (eql x (nth i list))) - (cl-incf i) - (member i '(2 3))) - list))) - (should (equal i 4)) - (should (equal result '(b c))) - (should (equal list '(a b c d))))) - (should (equal '() - (cl-remove-if-not (lambda (_x) (should nil)) '())))) - -(ert-deftest cl-lib-test-remove () - (let ((list (list 'a 'b 'c 'd)) - (key-index 0) - (test-index 0)) - (let ((result - (cl-remove 'foo list - :key (lambda (x) - (should (eql x (nth key-index list))) - (prog1 - (list key-index x) - (cl-incf key-index))) - :test - (lambda (a b) - (should (eql a 'foo)) - (should (equal b (list test-index - (nth test-index list)))) - (cl-incf test-index) - (member test-index '(2 3)))))) - (should (equal key-index 4)) - (should (equal test-index 4)) - (should (equal result '(a d))) - (should (equal list '(a b c d))))) - (let ((x (cons nil nil)) - (y (cons nil nil))) - (should (equal (cl-remove x (list x y)) - ;; or (list x), since we use `equal' -- the - ;; important thing is that only one element got - ;; removed, this proves that the default test is - ;; `eql', not `equal' - (list y))))) - - -(ert-deftest cl-lib-test-set-functions () - (let ((c1 (cons nil nil)) - (c2 (cons nil nil)) - (sym (make-symbol "a"))) - (let ((e '()) - (a (list 'a 'b sym nil "" "x" c1 c2)) - (b (list c1 'y 'b sym 'x))) - (should (equal (cl-set-difference e e) e)) - (should (equal (cl-set-difference a e) a)) - (should (equal (cl-set-difference e a) e)) - (should (equal (cl-set-difference a a) e)) - (should (equal (cl-set-difference b e) b)) - (should (equal (cl-set-difference e b) e)) - (should (equal (cl-set-difference b b) e)) - ;; Note: this test (and others) is sensitive to the order of the - ;; result, which is not documented. - (should (equal (cl-set-difference a b) (list 'a nil "" "x" c2))) - (should (equal (cl-set-difference b a) (list 'y 'x))) - - ;; We aren't testing whether this is really using `eq' rather than `eql'. - (should (equal (cl-set-difference e e :test 'eq) e)) - (should (equal (cl-set-difference a e :test 'eq) a)) - (should (equal (cl-set-difference e a :test 'eq) e)) - (should (equal (cl-set-difference a a :test 'eq) e)) - (should (equal (cl-set-difference b e :test 'eq) b)) - (should (equal (cl-set-difference e b :test 'eq) e)) - (should (equal (cl-set-difference b b :test 'eq) e)) - (should (equal (cl-set-difference a b :test 'eq) (list 'a nil "" "x" c2))) - (should (equal (cl-set-difference b a :test 'eq) (list 'y 'x))) - - (should (equal (cl-union e e) e)) - (should (equal (cl-union a e) a)) - (should (equal (cl-union e a) a)) - (should (equal (cl-union a a) a)) - (should (equal (cl-union b e) b)) - (should (equal (cl-union e b) b)) - (should (equal (cl-union b b) b)) - (should (equal (cl-union a b) (list 'x 'y 'a 'b sym nil "" "x" c1 c2))) - - (should (equal (cl-union b a) (list 'x 'y 'a 'b sym nil "" "x" c1 c2))) - - (should (equal (cl-intersection e e) e)) - (should (equal (cl-intersection a e) e)) - (should (equal (cl-intersection e a) e)) - (should (equal (cl-intersection a a) a)) - (should (equal (cl-intersection b e) e)) - (should (equal (cl-intersection e b) e)) - (should (equal (cl-intersection b b) b)) - (should (equal (cl-intersection a b) (list sym 'b c1))) - (should (equal (cl-intersection b a) (list sym 'b c1)))))) - -(ert-deftest cl-lib-test-gensym () - ;; Since the expansion of `should' calls `cl-gensym' and thus has a - ;; side-effect on `cl--gensym-counter', we have to make sure all - ;; macros in our test body are expanded before we rebind - ;; `cl--gensym-counter' and run the body. Otherwise, the test would - ;; fail if run interpreted. - (let ((body (byte-compile - '(lambda () - (should (equal (symbol-name (cl-gensym)) "G0")) - (should (equal (symbol-name (cl-gensym)) "G1")) - (should (equal (symbol-name (cl-gensym)) "G2")) - (should (equal (symbol-name (cl-gensym "foo")) "foo3")) - (should (equal (symbol-name (cl-gensym "bar")) "bar4")) - (should (equal cl--gensym-counter 5)))))) - (let ((cl--gensym-counter 0)) - (funcall body)))) - -(ert-deftest cl-lib-test-coerce-to-vector () - (let* ((a (vector)) - (b (vector 1 a 3)) - (c (list)) - (d (list b a))) - (should (eql (cl-coerce a 'vector) a)) - (should (eql (cl-coerce b 'vector) b)) - (should (equal (cl-coerce c 'vector) (vector))) - (should (equal (cl-coerce d 'vector) (vector b a))))) - -(ert-deftest cl-lib-test-string-position () - (should (eql (cl-position ?x "") nil)) - (should (eql (cl-position ?a "abc") 0)) - (should (eql (cl-position ?b "abc") 1)) - (should (eql (cl-position ?c "abc") 2)) - (should (eql (cl-position ?d "abc") nil)) - (should (eql (cl-position ?A "abc") nil))) - -(ert-deftest cl-lib-test-mismatch () - (should (eql (cl-mismatch "" "") nil)) - (should (eql (cl-mismatch "" "a") 0)) - (should (eql (cl-mismatch "a" "a") nil)) - (should (eql (cl-mismatch "ab" "a") 1)) - (should (eql (cl-mismatch "Aa" "aA") 0)) - (should (eql (cl-mismatch '(a b c) '(a b d)) 2))) - -(ert-deftest cl-lib-keyword-names-versus-values () - (should (equal - (funcall (cl-function (lambda (&key a b) (list a b))) - :b :a :a 42) - '(42 :a)))) - -(ert-deftest cl-lib-empty-keyargs () - (should-error (funcall (cl-function (lambda (&key) 1)) - :b 1))) - -(cl-defstruct (mystruct - (:constructor cl-lib--con-1 (&aux (abc 1))) - (:constructor cl-lib--con-2 (&optional def) "Constructor docstring.")) - "General docstring." - (abc 5 :readonly t) (def nil)) -(ert-deftest cl-lib-struct-accessors () - (let ((x (make-mystruct :abc 1 :def 2))) - (should (eql (cl-struct-slot-value 'mystruct 'abc x) 1)) - (should (eql (cl-struct-slot-value 'mystruct 'def x) 2)) - (setf (cl-struct-slot-value 'mystruct 'def x) -1) - (should (eql (cl-struct-slot-value 'mystruct 'def x) -1)) - (should (eql (cl-struct-slot-offset 'mystruct 'abc) 1)) - (should-error (cl-struct-slot-offset 'mystruct 'marypoppins)) - (should (pcase (cl-struct-slot-info 'mystruct) - (`((cl-tag-slot) (abc 5 :readonly t) - (def . ,(or 'nil '(nil)))) - t))))) -(ert-deftest cl-lib-struct-constructors () - (should (string-match "\\`Constructor docstring." - (documentation 'cl-lib--con-2 t))) - (should (mystruct-p (cl-lib--con-1))) - (should (mystruct-p (cl-lib--con-2)))) - -(ert-deftest cl-lib-arglist-performance () - ;; An `&aux' should not cause lambda's arglist to be turned into an &rest - ;; that's parsed by hand. - (should (equal () (help-function-arglist 'cl-lib--con-1))) - (should (pcase (help-function-arglist 'cl-lib--con-2) - (`(&optional ,_) t)))) - -(ert-deftest cl-the () - (should (eql (cl-the integer 42) 42)) - (should-error (cl-the integer "abc")) - (let ((side-effect 0)) - (should (= (cl-the integer (cl-incf side-effect)) 1)) - (should (= side-effect 1)))) - (ert-deftest cl-lib-test-pushnew () (let ((list '(1 2 3))) (cl-pushnew 0 list) @@ -468,12 +253,6 @@ (should (equal (cl-pairlis '(a nil c) '(1 2 3)) '((a . 1) (nil . 2) (c . 3)))) (should (equal (cl-pairlis '(a b c) '(1 nil 3)) '((a . 1) (b) (c . 3))))) -(ert-deftest cl-lib-test-endp () - (should (cl-endp '())) - (should-not (cl-endp '(1))) - (should-error (cl-endp 1) :type 'wrong-type-argument) - (should-error (cl-endp [1]) :type 'wrong-type-argument)) - (ert-deftest cl-lib-test-nth-value () (let ((vals (cl-values 2 3))) (should (= (cl-nth-value 0 vals) 2)) @@ -544,70 +323,6 @@ (should-error (cl-adjoin 1 nums :key 'int-to-string :test-not myfn-p) :type 'wrong-type-argument))) -(ert-deftest cl-parse-integer () - (should-error (cl-parse-integer "abc")) - (should (null (cl-parse-integer "abc" :junk-allowed t))) - (should (null (cl-parse-integer "" :junk-allowed t))) - (should (= 342391 (cl-parse-integer "0123456789" :radix 8 :junk-allowed t))) - (should-error (cl-parse-integer "0123456789" :radix 8)) - (should (= -239 (cl-parse-integer "-efz" :radix 16 :junk-allowed t))) - (should-error (cl-parse-integer "efz" :radix 16)) - (should (= 239 (cl-parse-integer "zzef" :radix 16 :start 2))) - (should (= -123 (cl-parse-integer " -123 ")))) - -(ert-deftest cl-flet-test () - (should (equal (cl-flet ((f1 (x) x)) (let ((x #'f1)) (funcall x 5))) 5))) - -(ert-deftest cl-lib-test-typep () - (cl-deftype cl-lib-test-type (&optional x) `(member ,x)) - ;; Make sure we correctly implement the rule that deftype's optional args - ;; default to `*' rather than to nil. - (should (cl-typep '* 'cl-lib-test-type)) - (should-not (cl-typep 1 'cl-lib-test-type))) - -(ert-deftest cl-lib-symbol-macrolet () - ;; bug#26325 - (should (equal (cl-flet ((f (x) (+ x 5))) - (let ((x 5)) - (f (+ x 6)))) - ;; Go through `eval', otherwise the macro-expansion - ;; error prevents running the whole test suite :-( - (eval '(cl-symbol-macrolet ((f (+ x 6))) - (cl-flet ((f (x) (+ x 5))) - (let ((x 5)) - (f f)))) - t)))) - -(defmacro cl-lib-symbol-macrolet-4+5 () - ;; bug#26068 - (let* ((sname "x") - (s1 (make-symbol sname)) - (s2 (make-symbol sname))) - `(cl-symbol-macrolet ((,s1 4) - (,s2 5)) - (+ ,s1 ,s2)))) - -(ert-deftest cl-lib-symbol-macrolet-2 () - (should (equal (cl-lib-symbol-macrolet-4+5) (+ 4 5)))) - - -(ert-deftest cl-lib-symbol-macrolet-hide () - ;; bug#26325, bug#26073 - (should (equal (let ((y 5)) - (cl-symbol-macrolet ((x y)) - (list x - (let ((x 6)) (list x y)) - (cl-letf ((x 6)) (list x y)) - (apply (lambda (x) (+ x 1)) (list 8))))) - '(5 (6 5) (6 6) 9)))) - -(ert-deftest cl-lib-defstruct-record () - (cl-defstruct foo x) - (let ((x (make-foo :x 42))) - (should (recordp x)) - (should (eq (type-of x) 'foo)) - (should (eql (foo-x x) 42)))) - (ert-deftest old-struct () (cl-defstruct foo x) (with-suppressed-warnings ((obsolete cl-old-struct-compat-mode)) @@ -638,37 +353,4 @@ (should (equal (mapcar (cl-constantly 3) '(a b c d)) '(3 3 3 3)))) -(ert-deftest cl-lib-set-difference () - ;; our set-difference preserves order, though it is not required to - ;; by cl standards. Nevertheless better keep that invariant - (should (equal (cl-set-difference '(1 2 3 4) '(3 4 5 6)) - '(1 2)))) - -(ert-deftest cl-nset-difference () - ;; our nset-difference doesn't - (let* ((l1 (list 1 2 3 4)) (l2 '(3 4 5 6)) - (diff (cl-nset-difference l1 l2))) - (should (memq 1 diff)) - (should (memq 2 diff)) - (should (= (length diff) 2)) - (should (equal l2 '(3 4 5 6)))) - (let* ((l1 (list "1" "2" "3" "4")) (l2 '("3" "4" "5" "6")) - (diff (cl-nset-difference l1 l2 :test #'equal))) - (should (member "1" diff)) - (should (member "2" diff)) - (should (= (length diff) 2)) - (should (equal l2 '("3" "4" "5" "6")))) - (let* ((l1 (list '(a . 1) '(b . 2) '(c . 3) '(d . 4))) - (l2 (list '(c . 3) '(d . 4) '(e . 5) '(f . 6))) - (diff (cl-nset-difference l1 l2 :key #'car))) - (should (member '(a . 1) diff)) - (should (member '(b . 2) diff)) - (should (= (length diff) 2))) - (let* ((l1 (list '("a" . 1) '("b" . 2) '("c" . 3) '("d" . 4))) - (l2 (list '("c" . 3) '("d" . 4) '("e" . 5) '("f" . 6))) - (diff (cl-nset-difference l1 l2 :key #'car :test #'string=))) - (should (member '("a" . 1) diff)) - (should (member '("b" . 2) diff)) - (should (= (length diff) 2)))) - ;;; cl-lib-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index 628bae36e48..4fa5c4edba1 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -22,11 +22,9 @@ ;;; Code: (require 'cl-lib) -(require 'cl-macs) (require 'edebug) (require 'ert) (require 'ert-x) -(require 'pcase) ;;;; cl-loop tests -- many adapted from Steele's CLtL2 @@ -518,6 +516,45 @@ collection clause." collect (list k x)))))) +(cl-defstruct (mystruct + (:constructor cl-lib--con-1 (&aux (abc 1))) + (:constructor cl-lib--con-2 (&optional def) "Constructor docstring.")) + "General docstring." + (abc 5 :readonly t) (def nil)) + +(ert-deftest cl-lib-struct-accessors () + (let ((x (make-mystruct :abc 1 :def 2))) + (should (eql (cl-struct-slot-value 'mystruct 'abc x) 1)) + (should (eql (cl-struct-slot-value 'mystruct 'def x) 2)) + (setf (cl-struct-slot-value 'mystruct 'def x) -1) + (should (eql (cl-struct-slot-value 'mystruct 'def x) -1)) + (should (eql (cl-struct-slot-offset 'mystruct 'abc) 1)) + (should-error (cl-struct-slot-offset 'mystruct 'marypoppins)) + (should (pcase (cl-struct-slot-info 'mystruct) + (`((cl-tag-slot) (abc 5 :readonly t) + (def . ,(or 'nil '(nil)))) + t))))) + +(ert-deftest cl-lib-struct-constructors () + (should (string-match "\\`Constructor docstring." + (documentation 'cl-lib--con-2 t))) + (should (mystruct-p (cl-lib--con-1))) + (should (mystruct-p (cl-lib--con-2)))) + +(ert-deftest cl-lib-arglist-performance () + ;; An `&aux' should not cause lambda's arglist to be turned into an &rest + ;; that's parsed by hand. + (should (equal () (help-function-arglist 'cl-lib--con-1))) + (should (pcase (help-function-arglist 'cl-lib--con-2) + (`(&optional ,_) t)))) + +(ert-deftest cl-lib-defstruct-record () + (cl-defstruct foo x) + (let ((x (make-foo :x 42))) + (should (recordp x)) + (should (eq (type-of x) 'foo)) + (should (eql (foo-x x) 42)))) + (ert-deftest cl-defstruct/builtin-type () (should-error (macroexpand '(cl-defstruct hash-table)) @@ -563,6 +600,41 @@ collection clause." m))) '(42 5 42)))) +(ert-deftest cl-lib-symbol-macrolet () + ;; bug#26325 + (should (equal (cl-flet ((f (x) (+ x 5))) + (let ((x 5)) + (f (+ x 6)))) + ;; Go through `eval', otherwise the macro-expansion + ;; error prevents running the whole test suite :-( + (eval '(cl-symbol-macrolet ((f (+ x 6))) + (cl-flet ((f (x) (+ x 5))) + (let ((x 5)) + (f f)))) + t)))) + +(defmacro cl-lib-symbol-macrolet-4+5 () + ;; bug#26068 + (let* ((sname "x") + (s1 (make-symbol sname)) + (s2 (make-symbol sname))) + `(cl-symbol-macrolet ((,s1 4) + (,s2 5)) + (+ ,s1 ,s2)))) + +(ert-deftest cl-lib-symbol-macrolet-2 () + (should (equal (cl-lib-symbol-macrolet-4+5) (+ 4 5)))) + +(ert-deftest cl-lib-symbol-macrolet-hide () + ;; bug#26325, bug#26073 + (should (equal (let ((y 5)) + (cl-symbol-macrolet ((x y)) + (list x + (let ((x 6)) (list x y)) + (cl-letf ((x 6)) (list x y)) + (apply (lambda (x) (+ x 1)) (list 8))))) + '(5 (6 5) (6 6) 9)))) + (ert-deftest cl-macs-loop-conditional-step-clauses () "These tests failed under the initial fixes in #bug#29799." (should (cl-loop for i from 1 upto 100 and j = 1 then (1+ j) @@ -718,6 +790,9 @@ collection clause." (f lex-var))))) (should (equal (f nil) 'a))))) +(ert-deftest cl-flet-test () + (should (equal (cl-flet ((f1 (x) x)) (let ((x #'f1)) (funcall x 5))) 5))) + (ert-deftest cl-macs--test-flet-block () (should (equal (cl-block f1 (cl-flet ((f1 (a) (cons (cl-return-from f1 a) 6))) @@ -803,9 +878,9 @@ collection clause." (cl-ecase val (t 1) (123 2)) (cl-ecase val (123 2) (t 1)))) (ert-info ((prin1-to-string form) :prefix "Form: ") - (let ((error (should-error (macroexpand form)))) - (should (equal (cdr error) - '("Misplaced t or `otherwise' clause")))))))) + (let ((error (should-error (macroexpand form)))) + (should (equal (cdr error) + '("Misplaced t or `otherwise' clause")))))))) (ert-deftest cl-case-warning () "Test that `cl-case' and `cl-ecase' warn about suspicious @@ -833,10 +908,10 @@ constructs." (dolist (macro '(cl-case cl-ecase)) (let ((form `(,macro val (,case 1)))) (ert-info ((prin1-to-string form) :prefix "Form: ") - (ert-with-message-capture messages - (macroexpand form) - (should (equal messages - (concat "Warning: " message "\n")))))))))) + (ert-with-message-capture messages + (macroexpand form) + (should (equal messages + (concat "Warning: " message "\n")))))))))) (ert-deftest cl-case-no-warning () "Test that `cl-case' and `cl-ecase' don't warn in some valid cases. @@ -875,4 +950,45 @@ See Bug#57915." (should (equal (cl--test-s-cl--test-a x) 4)) (should (equal (cl--test-s-b x) 'dyn))))) +(ert-deftest cl-lib-keyword-names-versus-values () + (should (equal + (funcall (cl-function (lambda (&key a b) (list a b))) + :b :a :a 42) + '(42 :a)))) + +(ert-deftest cl-lib-empty-keyargs () + (should-error (funcall (cl-function (lambda (&key) 1)) + :b 1))) + +(ert-deftest cl-lib-test-gensym () + ;; Since the expansion of `should' calls `cl-gensym' and thus has a + ;; side-effect on `cl--gensym-counter', we have to make sure all + ;; macros in our test body are expanded before we rebind + ;; `cl--gensym-counter' and run the body. Otherwise, the test would + ;; fail if run interpreted. + (let ((body (byte-compile + '(lambda () + (should (equal (symbol-name (cl-gensym)) "G0")) + (should (equal (symbol-name (cl-gensym)) "G1")) + (should (equal (symbol-name (cl-gensym)) "G2")) + (should (equal (symbol-name (cl-gensym "foo")) "foo3")) + (should (equal (symbol-name (cl-gensym "bar")) "bar4")) + (should (equal cl--gensym-counter 5)))))) + (let ((cl--gensym-counter 0)) + (funcall body)))) + +(ert-deftest cl-the () + (should (eql (cl-the integer 42) 42)) + (should-error (cl-the integer "abc")) + (let ((side-effect 0)) + (should (= (cl-the integer (cl-incf side-effect)) 1)) + (should (= side-effect 1)))) + +(ert-deftest cl-lib-test-typep () + (cl-deftype cl-lib-test-type (&optional x) `(member ,x)) + ;; Make sure we correctly implement the rule that deftype's optional args + ;; default to `*' rather than to nil. + (should (cl-typep '* 'cl-lib-test-type)) + (should-not (cl-typep 1 'cl-lib-test-type))) + ;;; cl-macs-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-seq-tests.el b/test/lisp/emacs-lisp/cl-seq-tests.el index 97276be3870..2348a7fc812 100644 --- a/test/lisp/emacs-lisp/cl-seq-tests.el +++ b/test/lisp/emacs-lisp/cl-seq-tests.el @@ -22,7 +22,7 @@ ;;; Code: (require 'ert) -(require 'cl-seq) +(require 'cl-lib) (ert-deftest cl-union-test-00 () "Test for bug#22729." @@ -54,8 +54,10 @@ Additionally register an `ert-info' to help identify test failures." (ert-deftest cl-seq-endp-test () (should (cl-endp '())) - (should (not (cl-endp '(1 2 3)))) - (should-error (cl-endp 42) :type 'wrong-type-argument)) + (should-not (cl-endp '(1))) + (should-not (cl-endp '(1 2 3))) + (should-error (cl-endp 1) :type 'wrong-type-argument) + (should-error (cl-endp [1]) :type 'wrong-type-argument)) (ert-deftest cl-seq-reduce-test () (should (equal 6 (cl-reduce #'+ '(1 2 3)))) @@ -97,6 +99,37 @@ Additionally register an `ert-info' to help identify test failures." (should (equal '(1 2 a a 5 2 6) (cl-replace l1 l2 :start1 2 :end1 4))) (should (equal '(a a 3 4 5 2 6) (cl-replace l1 l2 :start2 2 :end2 4))))) +(ert-deftest cl-lib-test-remove () + (let ((list (list 'a 'b 'c 'd)) + (key-index 0) + (test-index 0)) + (let ((result + (cl-remove 'foo list + :key (lambda (x) + (should (eql x (nth key-index list))) + (prog1 + (list key-index x) + (cl-incf key-index))) + :test + (lambda (a b) + (should (eql a 'foo)) + (should (equal b (list test-index + (nth test-index list)))) + (cl-incf test-index) + (member test-index '(2 3)))))) + (should (equal key-index 4)) + (should (equal test-index 4)) + (should (equal result '(a d))) + (should (equal list '(a b c d))))) + (let ((x (cons nil nil)) + (y (cons nil nil))) + (should (equal (cl-remove x (list x y)) + ;; or (list x), since we use `equal' -- the + ;; important thing is that only one element got + ;; removed, this proves that the default test is + ;; `eql', not `equal' + (list y))))) + ;; keywords supported: :test :test-not :key :count :start :end :from-end (ert-deftest cl-seq-remove-test () (let ((list '(1 2 3 4 5 2 6))) @@ -122,6 +155,20 @@ Additionally register an `ert-info' to help identify test failures." (should (equal '() (cl-remove-if #'cl-evenp '()))) (should (equal '() (cl-remove-if #'cl-evenp '(2))))) +(ert-deftest cl-lib-test-remove-if-not () + (let ((list (list 'a 'b 'c 'd)) + (i 0)) + (let ((result (cl-remove-if-not (lambda (x) + (should (eql x (nth i list))) + (cl-incf i) + (member i '(2 3))) + list))) + (should (equal i 4)) + (should (equal result '(b c))) + (should (equal list '(a b c d))))) + (should (equal '() + (cl-remove-if-not (lambda (_x) (should nil)) '())))) + (ert-deftest cl-remove-if-not-test () (should (equal '(2 4) (cl-remove-if-not #'cl-evenp '(1 2 3 4)))) (should (equal '(2 4) (cl-remove-if-not #'cl-evenp '(1 2 3 4) :count 2))) @@ -309,6 +356,14 @@ Additionally register an `ert-info' to help identify test failures." (let ((pred (lambda (x) (> (cl-position x orig :from-end t) 1)))) (should (equal '(b 2 3 4 5 2 6) (cl-nsubstitute 'b nil l :if-not pred)))))) +(ert-deftest cl-lib-test-string-position () + (should (eql (cl-position ?x "") nil)) + (should (eql (cl-position ?a "abc") 0)) + (should (eql (cl-position ?b "abc") 1)) + (should (eql (cl-position ?c "abc") 2)) + (should (eql (cl-position ?d "abc") nil)) + (should (eql (cl-position ?A "abc") nil))) + ;; keywords supported: :test :test-not :key :start :end :from-end (ert-deftest cl-seq-position-test () (let ((list '(1 2 3 4 5 2 6))) @@ -401,6 +456,14 @@ Additionally register an `ert-info' to help identify test failures." '(1 2 3 4 5 6)))) (should (equal result 2)))) +(ert-deftest cl-lib-test-mismatch () + (should (eql (cl-mismatch "" "") nil)) + (should (eql (cl-mismatch "" "a") 0)) + (should (eql (cl-mismatch "a" "a") nil)) + (should (eql (cl-mismatch "ab" "a") 1)) + (should (eql (cl-mismatch "Aa" "aA") 0)) + (should (eql (cl-mismatch '(a b c) '(a b d)) 2))) + ;; keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end (ert-deftest cl-seq-mismatch-test () (let ((list '(1 2 3 4 5 2 6)) @@ -776,6 +839,57 @@ Additionally register an `ert-info' to help identify test failures." '(((1 2) . 1) ((3 4) . 2) ((5) . 2))))) (should (equal result '((1 2) . 1))))) +(ert-deftest cl-lib-test-set-functions () + (let ((c1 (cons nil nil)) + (c2 (cons nil nil)) + (sym (make-symbol "a"))) + (let ((e '()) + (a (list 'a 'b sym nil "" "x" c1 c2)) + (b (list c1 'y 'b sym 'x))) + (should (equal (cl-set-difference e e) e)) + (should (equal (cl-set-difference a e) a)) + (should (equal (cl-set-difference e a) e)) + (should (equal (cl-set-difference a a) e)) + (should (equal (cl-set-difference b e) b)) + (should (equal (cl-set-difference e b) e)) + (should (equal (cl-set-difference b b) e)) + ;; Note: this test (and others) is sensitive to the order of the + ;; result, which is not documented. + (should (equal (cl-set-difference a b) (list 'a nil "" "x" c2))) + (should (equal (cl-set-difference b a) (list 'y 'x))) + + ;; We aren't testing whether this is really using `eq' rather than `eql'. + (should (equal (cl-set-difference e e :test 'eq) e)) + (should (equal (cl-set-difference a e :test 'eq) a)) + (should (equal (cl-set-difference e a :test 'eq) e)) + (should (equal (cl-set-difference a a :test 'eq) e)) + (should (equal (cl-set-difference b e :test 'eq) b)) + (should (equal (cl-set-difference e b :test 'eq) e)) + (should (equal (cl-set-difference b b :test 'eq) e)) + (should (equal (cl-set-difference a b :test 'eq) (list 'a nil "" "x" c2))) + (should (equal (cl-set-difference b a :test 'eq) (list 'y 'x))) + + (should (equal (cl-union e e) e)) + (should (equal (cl-union a e) a)) + (should (equal (cl-union e a) a)) + (should (equal (cl-union a a) a)) + (should (equal (cl-union b e) b)) + (should (equal (cl-union e b) b)) + (should (equal (cl-union b b) b)) + (should (equal (cl-union a b) (list 'x 'y 'a 'b sym nil "" "x" c1 c2))) + + (should (equal (cl-union b a) (list 'x 'y 'a 'b sym nil "" "x" c1 c2))) + + (should (equal (cl-intersection e e) e)) + (should (equal (cl-intersection a e) e)) + (should (equal (cl-intersection e a) e)) + (should (equal (cl-intersection a a) a)) + (should (equal (cl-intersection b e) e)) + (should (equal (cl-intersection e b) e)) + (should (equal (cl-intersection b b) b)) + (should (equal (cl-intersection a b) (list sym 'b c1))) + (should (equal (cl-intersection b a) (list sym 'b c1)))))) + (ert-deftest cl-intersection-test () (let ((result (cl-intersection '(1 2 3 4) '(3 4 5 6)))) (should (equal result '(4 3)))) @@ -815,8 +929,10 @@ Additionally register an `ert-info' to help identify test failures." '(1 2 3)))) (ert-deftest cl-set-difference-test () - (let ((result (cl-set-difference '(1 2 3 4) '(3 4 5 6)))) - (should (equal result '(1 2)))) + ;; Our set-difference preserves order, though it is not required to + ;; by CL standards. Nevertheless better keep that invariant. + (should (equal (cl-set-difference '(1 2 3 4) '(3 4 5 6)) + '(1 2))) (let ((result (cl-set-difference '(1 2 3) '()))) (should (equal result '(1 2 3)))) (let ((result (cl-set-difference '(1 2 3) '(1 2 3)))) @@ -843,6 +959,33 @@ Additionally register an `ert-info' to help identify test failures." (should (equal list1 '(1 2 3))) (should (equal list2 '(2 3 4))))) +(ert-deftest cl-nset-difference () + ;; Our nset-difference doesn't preserve order. + (let* ((l1 (list 1 2 3 4)) (l2 '(3 4 5 6)) + (diff (cl-nset-difference l1 l2))) + (should (memq 1 diff)) + (should (memq 2 diff)) + (should (= (length diff) 2)) + (should (equal l2 '(3 4 5 6)))) + (let* ((l1 (list "1" "2" "3" "4")) (l2 '("3" "4" "5" "6")) + (diff (cl-nset-difference l1 l2 :test #'equal))) + (should (member "1" diff)) + (should (member "2" diff)) + (should (= (length diff) 2)) + (should (equal l2 '("3" "4" "5" "6")))) + (let* ((l1 (list '(a . 1) '(b . 2) '(c . 3) '(d . 4))) + (l2 (list '(c . 3) '(d . 4) '(e . 5) '(f . 6))) + (diff (cl-nset-difference l1 l2 :key #'car))) + (should (member '(a . 1) diff)) + (should (member '(b . 2) diff)) + (should (= (length diff) 2))) + (let* ((l1 (list '("a" . 1) '("b" . 2) '("c" . 3) '("d" . 4))) + (l2 (list '("c" . 3) '("d" . 4) '("e" . 5) '("f" . 6))) + (diff (cl-nset-difference l1 l2 :key #'car :test #'string=))) + (should (member '("a" . 1) diff)) + (should (member '("b" . 2) diff)) + (should (= (length diff) 2)))) + (ert-deftest cl-nset-difference-test () (should-not (cl-nset-difference () ())) (should-not (cl-nset-difference () (list 1 2 3))) commit 9ded6fd73e929977a38d4c644aa4e9fe66e76e90 Author: Michael Albinus Date: Fri Feb 14 15:21:30 2025 +0100 Adapt PuTTY integration into Tramp * doc/misc/tramp.texi (Inline methods, External methods): PuTTY must be at least version 0.82. * lisp/net/tramp-cache.el (with-tramp-saved-connection-property) (with-tramp-saved-connection-properties): Add traces. * lisp/net/tramp-sh.el (tramp-methods) : Adapt `tramp-login-args' and `tramp-copy-args' arguments. (Bug#75746) diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 86ffba29744..ac0bb63335c 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -955,9 +955,10 @@ This is another method from the Kerberos suite. It behaves like @cindex @option{plink} method @item @option{plink} -@option{plink} method is for MS Windows users with the PuTTY -implementation of SSH@. It uses @samp{plink -ssh} to log in to the -remote host. It supports changing the remote login shell @command{/bin/sh}. +@option{plink} method is for MS Windows users with the +PuTTY@footnote{It requires at least PuTTY 0.82.} implementation of +SSH@. It uses @samp{plink -ssh} to log in to the remote host. It +supports changing the remote login shell @command{/bin/sh}. Check the @samp{Share SSH connections if possible} control for that session. @@ -1190,7 +1191,8 @@ This method supports the @samp{-p} argument. These methods are similar to @option{scp} or @option{sftp}, but they use the @command{plink} command to connect to the remote host, and they use @command{pscp} or @command{psftp} for transferring the files. -These programs are part of PuTTY, an SSH implementation for MS Windows. +These programs are part of PuTTY@footnote{It requires at least PuTTY +0.82.}, an SSH implementation for MS Windows. They support changing the remote login shell @command{/bin/sh}. diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index a5245deaf2b..e7ad565dc30 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -482,8 +482,10 @@ used to cache connection properties of the local machine." (hash (tramp-get-hash-table key)) (cached (and (hash-table-p hash) (gethash ,property hash tramp-cache-undefined)))) + (tramp-message key 7 "Saved %s %s" property cached) (unwind-protect (progn ,@body) ;; Reset PROPERTY. Recompute hash, it could have been flushed. + (tramp-message key 7 "Restored %s %s" property cached) (setq hash (tramp-get-hash-table key)) (if (not (eq cached tramp-cache-undefined)) (puthash ,property cached hash) @@ -501,8 +503,10 @@ PROPERTIES is a list of file properties (strings)." (lambda (property) (cons property (gethash property hash tramp-cache-undefined))) ,properties))) + (tramp-message key 7 "Saved %s" values) (unwind-protect (progn ,@body) ;; Reset PROPERTIES. Recompute hash, it could have been flushed. + (tramp-message key 7 "Restored %s" values) (setq hash (tramp-get-hash-table key)) (dolist (value values) (if (not (eq (cdr value) tramp-cache-undefined)) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index a21af990e0e..f85a371cded 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -322,6 +322,8 @@ The string is used in `tramp-methods'.") `("plink" (tramp-login-program "plink") (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%c") + ;; Since PuTTY 0.82. + ("-legacy-stdio-prompts") ("-t") ("%h") ("\"") (,(format "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" @@ -335,6 +337,8 @@ The string is used in `tramp-methods'.") `("plinkx" (tramp-login-program "plink") (tramp-login-args (("-load") ("%h") ("%c") ("-t") ("\"") + ;; Since PuTTY 0.82. + ("-legacy-stdio-prompts") (,(format "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" tramp-terminal-type @@ -347,6 +351,8 @@ The string is used in `tramp-methods'.") `("pscp" (tramp-login-program "plink") (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%c") + ;; Since PuTTY 0.82. + ("-legacy-stdio-prompts") ("-t") ("%h") ("\"") (,(format "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" @@ -358,6 +364,8 @@ The string is used in `tramp-methods'.") (tramp-remote-shell-args ("-c")) (tramp-copy-program "pscp") (tramp-copy-args (("-l" "%u") ("-P" "%p") ("-scp") + ;; Since PuTTY 0.82. + ("-legacy-stdio-prompts") ("-p" "%k") ("-q") ("-r"))) (tramp-copy-keep-date t) (tramp-copy-recursive t))) @@ -365,6 +373,8 @@ The string is used in `tramp-methods'.") `("psftp" (tramp-login-program "plink") (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%c") + ;; Since PuTTY 0.82. + ("-legacy-stdio-prompts") ("-t") ("%h") ("\"") (,(format "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" @@ -376,6 +386,8 @@ The string is used in `tramp-methods'.") (tramp-remote-shell-args ("-c")) (tramp-copy-program "pscp") (tramp-copy-args (("-l" "%u") ("-P" "%p") ("-sftp") + ;; Since PuTTY 0.82. + ("-legacy-stdio-prompts") ("-p" "%k"))) (tramp-copy-keep-date t))) commit 608113628c2750b09b925b17c96a29b2dc9abc37 Author: Pip Cet Date: Fri Feb 14 13:49:49 2025 +0000 Avoid crashes in lread.c when invalid characters are read * src/lread.c (readchar): Don't crash for non-fixnum return values. (read_filtered_event): Don't crash for invalid symbol properties. (Fread_char): (Fread_char_exclusive): (character_name_to_code): Check 'FIXNUMP' before using 'XFIXNUM'. (read_char_escape): Crash on invalid Lisp-supplied data when ENABLE_CHECKING; otherwise, signal an error. diff --git a/src/lread.c b/src/lread.c index 6af95873bb8..46c705e5c76 100644 --- a/src/lread.c +++ b/src/lread.c @@ -398,7 +398,7 @@ readchar (Lisp_Object readcharfun, bool *multibyte) tem = call0 (readcharfun); - if (NILP (tem)) + if (!FIXNUMP (tem)) return -1; return XFIXNUM (tem); @@ -816,7 +816,7 @@ read_filtered_event (bool no_switch_frame, bool ascii_required, tem1 = Fget (Fcar (tem), Qascii_character); /* Merge this symbol's modifier bits with the ASCII equivalent of its basic code. */ - if (!NILP (tem1)) + if (FIXNUMP (tem1) && FIXNUMP (Fcar (Fcdr (tem)))) XSETFASTINT (val, XFIXNUM (tem1) | XFIXNUM (Fcar (Fcdr (tem)))); } } @@ -898,7 +898,7 @@ If `inhibit-interaction' is non-nil, this function will signal an } val = read_filtered_event (1, 1, 1, ! NILP (inherit_input_method), seconds); - return (NILP (val) ? Qnil + return (!FIXNUMP (val) ? Qnil : make_fixnum (char_resolve_modifier_mask (XFIXNUM (val)))); } @@ -976,7 +976,7 @@ If `inhibit-interaction' is non-nil, this function will signal an val = read_filtered_event (1, 1, 0, ! NILP (inherit_input_method), seconds); - return (NILP (val) ? Qnil + return (!FIXNUMP (val) ? Qnil : make_fixnum (char_resolve_modifier_mask (XFIXNUM (val)))); } @@ -2820,7 +2820,7 @@ character_name_to_code (char const *name, ptrdiff_t name_len, invalid_syntax_lisp (CALLN (Fformat, format, namestr), readcharfun); } - return XFIXNUM (code); + return FIXNUMP (code) ? XFIXNUM (code) : -1; } /* Bound on the length of a Unicode character name. As of @@ -3059,6 +3059,8 @@ read_char_escape (Lisp_Object readcharfun, int next_char) break; } eassert (chr >= 0 && chr < (1 << CHARACTERBITS)); + if (chr < 0 || chr >= (1 << CHARACTERBITS)) + invalid_syntax ("Invalid character", readcharfun); /* Apply Control modifiers, using the rules: \C-X = ascii_ctrl(nomod(X)) | mods(X) if nomod(X) is one of: commit 4d6f40dfc9075d64275da97dc35a2becc9eca4a2 Author: Po Lu Date: Fri Feb 14 17:56:22 2025 +0800 * lisp/x-dnd.el (x-dnd-do-direct-save): Remove redundant stmts. diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el index 760dd0a42bf..13fe3842f18 100644 --- a/lisp/x-dnd.el +++ b/lisp/x-dnd.el @@ -1544,41 +1544,39 @@ was taken, or the direct save failed." (x-dnd-use-offix-drop nil) (x-dnd-use-unsupported-drop nil) (prop-deleted nil) - (action nil) encoded-name) (unwind-protect - (setq action - (progn - (when (file-remote-p file) - (setq file-name (file-local-copy file)) - (setq dnd-last-dragged-remote-file file-name) - (add-hook 'kill-emacs-hook - #'dnd-remove-last-dragged-remote-file)) - (setq encoded-name - (encode-coding-string name - (or file-name-coding-system - default-file-name-coding-system))) - (setq x-dnd-xds-current-file file-name) - (x-change-window-property "XdndDirectSave0" encoded-name - frame "text/plain" 8 nil) - (gui-set-selection 'XdndSelection (concat "file://" file-name)) - ;; FIXME: this does not work with GTK file managers, - ;; since they always reach for `text/uri-list' first, - ;; contrary to the spec. - (let ((action (x-begin-drag '("XdndDirectSave0" "text/uri-list" - "application/octet-stream") - 'XdndActionDirectSave - frame nil allow-same-frame))) - (if (not x-dnd-xds-performed) - action - (let ((property (x-window-property "XdndDirectSave0" frame - "AnyPropertyType" nil t))) - (setq prop-deleted t) - ;; "System-G" deletes the property upon success. - (and (or (null property) - (and (stringp property) - (not (equal property "")))) - action)))))) + (progn + (when (file-remote-p file) + (setq file-name (file-local-copy file)) + (setq dnd-last-dragged-remote-file file-name) + (add-hook 'kill-emacs-hook + #'dnd-remove-last-dragged-remote-file)) + (setq encoded-name + (encode-coding-string name + (or file-name-coding-system + default-file-name-coding-system))) + (setq x-dnd-xds-current-file file-name) + (x-change-window-property "XdndDirectSave0" encoded-name + frame "text/plain" 8 nil) + (gui-set-selection 'XdndSelection (concat "file://" file-name)) + ;; FIXME: this does not work with GTK file managers, + ;; since they always reach for `text/uri-list' first, + ;; contrary to the spec. + (let ((action (x-begin-drag '("XdndDirectSave0" "text/uri-list" + "application/octet-stream") + 'XdndActionDirectSave + frame nil allow-same-frame))) + (if (not x-dnd-xds-performed) + action + (let ((property (x-window-property "XdndDirectSave0" frame + "AnyPropertyType" nil t))) + (setq prop-deleted t) + ;; "System-G" deletes the property upon success. + (and (or (null property) + (and (stringp property) + (not (equal property "")))) + action))))) (unless prop-deleted (x-delete-window-property "XdndDirectSave0" frame)) ;; Delete any remote copy that was made.