diff options
| author | Stefan Monnier <monnier@iro.umontreal.ca> | 2012-07-10 07:51:54 -0400 |
|---|---|---|
| committer | Stefan Monnier <monnier@iro.umontreal.ca> | 2012-07-10 07:51:54 -0400 |
| commit | f58e0fd503567288bb30e243595acaa589034929 (patch) | |
| tree | e40cb0a5c087c0af4bdd41948d655358b0fcd56e /lisp | |
| parent | dfa96edd13d1db4a90fa0977d06b6bdeab2f642e (diff) | |
| download | emacs-f58e0fd503567288bb30e243595acaa589034929.tar.gz | |
Reduce use of (require 'cl).
* admin/bzrmerge.el: Use cl-lib.
* leim/quail/hangul.el: Don't require CL.
* leim/quail/ipa.el: Use cl-lib.
* vc/smerge-mode.el, vc/pcvs.el, vc/pcvs-util.el, vc/pcvs-info.el:
* vc/diff-mode.el, vc/cvs-status.el, uniquify.el, scroll-bar.el:
* register.el, progmodes/sh-script.el, net/gnutls.el, net/dbus.el:
* msb.el, mpc.el, minibuffer.el, international/ucs-normalize.el:
* international/quail.el, info-xref.el, imenu.el, image-mode.el:
* font-lock.el, filesets.el, edmacro.el, doc-view.el, bookmark.el:
* battery.el, avoid.el, abbrev.el: Use cl-lib.
* vc/pcvs-parse.el, vc/pcvs-defs.el, vc/log-view.el, vc/log-edit.el:
* vc/diff.el, simple.el, pcomplete.el, lpr.el, comint.el, loadhist.el:
* jit-lock.el, international/iso-ascii.el, info.el, frame.el, bs.el:
* emulation/crisp.el, electric.el, dired.el, cus-dep.el, composite.el:
* calculator.el, autorevert.el, apropos.el: Don't require CL.
* emacs-bytecomp.el (byte-recompile-directory, display-call-tree)
(byte-compile-unfold-bcf, byte-compile-check-variable):
* emacs-byte-opt.el (byte-compile-trueconstp)
(byte-compile-nilconstp):
* emacs-autoload.el (make-autoload): Use pcase.
* face-remap.el (text-scale-adjust): Simplify pcase patterns.
Diffstat (limited to 'lisp')
57 files changed, 715 insertions, 728 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog index a441bd0456f..a82048617cf 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,25 @@ 2012-07-10 Stefan Monnier <monnier@iro.umontreal.ca> + Reduce use of (require 'cl). + * vc/smerge-mode.el, vc/pcvs.el, vc/pcvs-util.el, vc/pcvs-info.el: + * vc/diff-mode.el, vc/cvs-status.el, uniquify.el, scroll-bar.el: + * register.el, progmodes/sh-script.el, net/gnutls.el, net/dbus.el: + * msb.el, mpc.el, minibuffer.el, international/ucs-normalize.el: + * international/quail.el, info-xref.el, imenu.el, image-mode.el: + * font-lock.el, filesets.el, edmacro.el, doc-view.el, bookmark.el: + * battery.el, avoid.el, abbrev.el: Use cl-lib. + * vc/pcvs-parse.el, vc/pcvs-defs.el, vc/log-view.el, vc/log-edit.el: + * vc/diff.el, simple.el, pcomplete.el, lpr.el, comint.el, loadhist.el: + * jit-lock.el, international/iso-ascii.el, info.el, frame.el, bs.el: + * emulation/crisp.el, electric.el, dired.el, cus-dep.el, composite.el: + * calculator.el, autorevert.el, apropos.el: Don't require CL. + * emacs-lisp/bytecomp.el (byte-recompile-directory, display-call-tree) + (byte-compile-unfold-bcf, byte-compile-check-variable): + * emacs-lisp/byte-opt.el (byte-compile-trueconstp) + (byte-compile-nilconstp): + * emacs-lisp/autoload.el (make-autoload): Use pcase. + * face-remap.el (text-scale-adjust): Simplify pcase patterns. + * emacs-lisp/gv.el (cond): Make it a valid place. (if): Simplify slightly. diff --git a/lisp/abbrev.el b/lisp/abbrev.el index 9b82b3bc893..114afd8c813 100644 --- a/lisp/abbrev.el +++ b/lisp/abbrev.el @@ -31,7 +31,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defgroup abbrev-mode nil "Word abbreviations mode." @@ -540,7 +540,7 @@ the current abbrev table before abbrev lookup happens." (dotimes (i (length table)) (aset table i 0)) ;; Preserve the table's properties. - (assert sym) + (cl-assert sym) (let ((newsym (intern "" table))) (set newsym nil) ; Make sure it won't be confused for an abbrev. (setplist newsym (symbol-plist sym))) @@ -583,8 +583,8 @@ An obsolete but still supported calling form is: \(define-abbrev TABLE NAME EXPANSION &optional HOOK COUNT SYSTEM)." (when (and (consp props) (or (null (car props)) (numberp (car props)))) ;; Old-style calling convention. - (setq props (list* :count (car props) - (if (cadr props) (list :system (cadr props)))))) + (setq props `(:count ,(car props) + ,@(if (cadr props) (list :system (cadr props)))))) (unless (plist-get props :count) (setq props (plist-put props :count 0))) (let ((system-flag (plist-get props :system)) @@ -621,7 +621,7 @@ current (if global is nil) or standard syntax table." (let ((badchars ()) (pos 0)) (while (string-match "\\W" abbrev pos) - (pushnew (aref abbrev (match-beginning 0)) badchars) + (cl-pushnew (aref abbrev (match-beginning 0)) badchars) (setq pos (1+ pos))) (error "Some abbrev characters (%s) are not word constituents %s" (apply 'string (nreverse badchars)) @@ -836,8 +836,7 @@ return value is that of `abbrev-insert'.)" (interactive) (run-hooks 'pre-abbrev-expand-hook) (with-wrapper-hook abbrev-expand-functions () - (destructuring-bind (&optional sym name wordstart wordend) - (abbrev--before-point) + (pcase-let ((`(,sym ,name ,wordstart ,wordend) (abbrev--before-point))) (when sym (let ((startpos (copy-marker (point) t)) (endmark (copy-marker wordend t))) diff --git a/lisp/apropos.el b/lisp/apropos.el index f5373b38682..e1c3e06752d 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -36,12 +36,12 @@ ;; Fixed bug, current-local-map can return nil. ;; Change, doesn't calculate key-bindings unless needed. ;; Added super-apropos capability, changed print functions. -;;; Made fast-apropos and super-apropos share code. -;;; Sped up fast-apropos again. +;; Made fast-apropos and super-apropos share code. +;; Sped up fast-apropos again. ;; Added apropos-do-all option. -;;; Added fast-command-apropos. +;; Added fast-command-apropos. ;; Changed doc strings to comments for helping functions. -;;; Made doc file buffer read-only, buried it. +;; Made doc file buffer read-only, buried it. ;; Only call substitute-command-keys if do-all set. ;; Optionally use configurable faces to make the output more legible. @@ -57,7 +57,6 @@ ;;; Code: (require 'button) -(eval-when-compile (require 'cl)) (defgroup apropos nil "Apropos commands for users and programmers." @@ -640,11 +639,11 @@ the output includes key-bindings of commands." (setq lh (cdr lh))))) (unless lh-entry (error "Unknown library `%s'" file))) (dolist (x (cdr lh-entry)) - (case (car-safe x) + (pcase (car-safe x) ;; (autoload (push (cdr x) autoloads)) - (require (push (cdr x) requires)) - (provide (push (cdr x) provides)) - (t (push (or (cdr-safe x) x) symbols)))) + (`require (push (cdr x) requires)) + (`provide (push (cdr x) provides)) + (_ (push (or (cdr-safe x) x) symbols)))) (let ((apropos-pattern "")) ;Dummy binding for apropos-symbols-internal. (apropos-symbols-internal symbols apropos-do-all diff --git a/lisp/autorevert.el b/lisp/autorevert.el index 11005f49f44..0f082d2ee9c 100644 --- a/lisp/autorevert.el +++ b/lisp/autorevert.el @@ -94,9 +94,6 @@ (require 'timer) -(eval-when-compile (require 'cl)) - - ;; Custom Group: ;; ;; The two modes will be placed next to Auto Save Mode under the diff --git a/lisp/avoid.el b/lisp/avoid.el index bfe15de0ca2..2fa6ef39e70 100644 --- a/lisp/avoid.el +++ b/lisp/avoid.el @@ -67,7 +67,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defgroup avoid nil "Make mouse pointer stay out of the way of editing." @@ -206,30 +206,30 @@ If you want the mouse banished to a different corner set (let* ((fra-or-win (assoc-default 'frame-or-window mouse-avoidance-banish-position 'eq)) - (list-values (case fra-or-win - (frame (list 0 0 (frame-width) (frame-height))) - (window (window-edges)))) - (alist (loop for v in list-values - for k in '(left top right bottom) - collect (cons k v))) + (list-values (pcase fra-or-win + (`frame (list 0 0 (frame-width) (frame-height))) + (`window (window-edges)))) + (alist (cl-loop for v in list-values + for k in '(left top right bottom) + collect (cons k v))) (side (assoc-default 'side - mouse-avoidance-banish-position 'eq)) + mouse-avoidance-banish-position #'eq)) (side-dist (assoc-default 'side-pos - mouse-avoidance-banish-position 'eq)) + mouse-avoidance-banish-position #'eq)) (top-or-bottom (assoc-default 'top-or-bottom - mouse-avoidance-banish-position 'eq)) + mouse-avoidance-banish-position #'eq)) (top-or-bottom-dist (assoc-default 'top-or-bottom-pos - mouse-avoidance-banish-position 'eq)) - (side-fn (case side - (left '+) - (right '-))) - (top-or-bottom-fn (case top-or-bottom - (top '+) - (bottom '-)))) + mouse-avoidance-banish-position #'eq)) + (side-fn (pcase side + (`left '+) + (`right '-))) + (top-or-bottom-fn (pcase top-or-bottom + (`top '+) + (`bottom '-)))) (cons (funcall side-fn ; -/+ (assoc-default side alist 'eq) ; right or left side-dist) ; distance from side diff --git a/lisp/battery.el b/lisp/battery.el index dcfe07121b3..8e98291b11c 100644 --- a/lisp/battery.el +++ b/lisp/battery.el @@ -31,8 +31,7 @@ ;;; Code: (require 'timer) -(eval-when-compile (require 'cl)) - +(eval-when-compile (require 'cl-lib)) (defgroup battery nil "Display battery status information." @@ -360,16 +359,16 @@ The following %-sequences are provided: (when (re-search-forward "present: +yes$" nil t) (when (re-search-forward "design capacity: +\\([0-9]+\\) m[AW]h$" nil t) - (incf design-capacity (string-to-number (match-string 1)))) + (cl-incf design-capacity (string-to-number (match-string 1)))) (when (re-search-forward "last full capacity: +\\([0-9]+\\) m[AW]h$" nil t) - (incf last-full-capacity (string-to-number (match-string 1)))) + (cl-incf last-full-capacity (string-to-number (match-string 1)))) (when (re-search-forward "design capacity warning: +\\([0-9]+\\) m[AW]h$" nil t) - (incf warn (string-to-number (match-string 1)))) + (cl-incf warn (string-to-number (match-string 1)))) (when (re-search-forward "design capacity low: +\\([0-9]+\\) m[AW]h$" nil t) - (incf low (string-to-number (match-string 1))))))) + (cl-incf low (string-to-number (match-string 1))))))) (setq full-capacity (if (> last-full-capacity 0) last-full-capacity design-capacity)) (and capacity rate diff --git a/lisp/bookmark.el b/lisp/bookmark.el index bf2ea9a9517..8e6fb94c0dd 100644 --- a/lisp/bookmark.el +++ b/lisp/bookmark.el @@ -33,7 +33,7 @@ ;;; Code: (require 'pp) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;;; Misc comments: ;; @@ -2015,11 +2015,11 @@ To carry out the deletions that you've marked, use \\<bookmark-bmenu-mode-map>\\ (tmp-list ())) (while (let ((char (read-key (concat prompt bookmark-search-pattern)))) - (case char - ((?\e ?\r) nil) ; RET or ESC break the search loop. + (pcase char + ((or ?\e ?\r) nil) ; RET or ESC break the search loop. (?\C-g (setq bookmark-quit-flag t) nil) (?\d (pop tmp-list) t) ; Delete last char of pattern with DEL - (t + (_ (if (characterp char) (push char tmp-list) (setq unread-command-events @@ -2034,9 +2034,9 @@ To carry out the deletions that you've marked, use \\<bookmark-bmenu-mode-map>\\ (defun bookmark-bmenu-filter-alist-by-regexp (regexp) "Filter `bookmark-alist' with bookmarks matching REGEXP and rebuild list." (let ((bookmark-alist - (loop for i in bookmark-alist - when (string-match regexp (car i)) collect i into new - finally return new))) + (cl-loop for i in bookmark-alist + when (string-match regexp (car i)) collect i into new + finally return new))) (bookmark-bmenu-list))) diff --git a/lisp/bs.el b/lisp/bs.el index 08d05a946e3..09aefee416e 100644 --- a/lisp/bs.el +++ b/lisp/bs.el @@ -124,8 +124,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - ;; ---------------------------------------------------------------------- ;; Globals for customization ;; ---------------------------------------------------------------------- @@ -830,10 +828,10 @@ See `visit-tags-table'." (interactive) (let ((res (with-current-buffer (bs--current-buffer) - (setq bs-buffer-show-mark (case bs-buffer-show-mark - ((nil) 'never) - ((never) 'always) - (t nil)))))) + (setq bs-buffer-show-mark (pcase bs-buffer-show-mark + (`nil 'never) + (`never 'always) + (_ nil)))))) (bs--update-current-line) (bs--set-window-height) (bs--show-config-message res))) diff --git a/lisp/calculator.el b/lisp/calculator.el index 14f50a0adcb..b1a3f9e0759 100644 --- a/lisp/calculator.el +++ b/lisp/calculator.el @@ -43,8 +43,6 @@ ;;; History: ;; I hate history. -(eval-when-compile (require 'cl)) - ;;;===================================================================== ;;; Customization: diff --git a/lisp/comint.el b/lisp/comint.el index 4ccbfb5f9c8..431d05b75c2 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -101,7 +101,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'ring) (require 'ansi-color) (require 'regexp-opt) ;For regexp-opt-charset. diff --git a/lisp/composite.el b/lisp/composite.el index 72317ac470e..4832848cb90 100644 --- a/lisp/composite.el +++ b/lisp/composite.el @@ -29,8 +29,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (defconst reference-point-alist '((tl . 0) (tc . 1) (tr . 2) (Bl . 3) (Bc . 4) (Br . 5) diff --git a/lisp/cus-dep.el b/lisp/cus-dep.el index cd946bdc99b..bfe3ae36c7e 100644 --- a/lisp/cus-dep.el +++ b/lisp/cus-dep.el @@ -25,7 +25,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'widget) (require 'cus-face) diff --git a/lisp/dired.el b/lisp/dired.el index 68e1e574a00..18480acd968 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -34,8 +34,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - ;;; Customizable variables (defgroup dired nil diff --git a/lisp/doc-view.el b/lisp/doc-view.el index f526825b0bd..72b36feb1d8 100644 --- a/lisp/doc-view.el +++ b/lisp/doc-view.el @@ -133,7 +133,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'dired) (require 'image-mode) (require 'jka-compr) @@ -259,9 +259,9 @@ of the page moves to the previous page." (setq ol nil)) (if ol (progn - (assert (eq (overlay-buffer ol) (current-buffer))) + (cl-assert (eq (overlay-buffer ol) (current-buffer))) (setq ol (copy-overlay ol))) - (assert (not (get-char-property (point-min) 'display))) + (cl-assert (not (get-char-property (point-min) 'display))) (setq ol (make-overlay (point-min) (point-max) nil t)) (overlay-put ol 'doc-view t)) (overlay-put ol 'window (car winprops)) @@ -892,30 +892,30 @@ Start by converting PAGES, and then the rest." (defun doc-view-doc->txt (txt callback) "Convert the current document to text and call CALLBACK when done." (make-directory (doc-view-current-cache-dir) t) - (case doc-view-doc-type - (pdf + (pcase doc-view-doc-type + (`pdf ;; Doc is a PDF, so convert it to TXT (doc-view-pdf->txt doc-view-buffer-file-name txt callback)) - (ps + (`ps ;; Doc is a PS, so convert it to PDF (which will be converted to ;; TXT thereafter). (let ((pdf (expand-file-name "doc.pdf" (doc-view-current-cache-dir)))) (doc-view-ps->pdf doc-view-buffer-file-name pdf (lambda () (doc-view-pdf->txt pdf txt callback))))) - (dvi + (`dvi ;; Doc is a DVI. This means that a doc.pdf already exists in its ;; cache subdirectory. (doc-view-pdf->txt (expand-file-name "doc.pdf" (doc-view-current-cache-dir)) txt callback)) - (odf + (`odf ;; Doc is some ODF (or MS Office) doc. This means that a doc.pdf ;; already exists in its cache subdirectory. (doc-view-pdf->txt (expand-file-name "doc.pdf" (doc-view-current-cache-dir)) txt callback)) - (t (error "DocView doesn't know what to do")))) + (_ (error "DocView doesn't know what to do")))) (defun doc-view-ps->pdf (ps pdf callback) "Convert PS to PDF asynchronously and call CALLBACK when finished." @@ -950,14 +950,14 @@ Those files are saved in the directory given by the function (let ((png-file (expand-file-name "page-%d.png" (doc-view-current-cache-dir)))) (make-directory (doc-view-current-cache-dir) t) - (case doc-view-doc-type - (dvi + (pcase doc-view-doc-type + (`dvi ;; DVI files have to be converted to PDF before Ghostscript can process ;; it. (let ((pdf (expand-file-name "doc.pdf" doc-view-current-cache-dir))) (doc-view-dvi->pdf doc-view-buffer-file-name pdf (lambda () (doc-view-pdf/ps->png pdf png-file))))) - (odf + (`odf ;; ODF files have to be converted to PDF before Ghostscript can ;; process it. (let ((pdf (expand-file-name "doc.pdf" doc-view-current-cache-dir)) @@ -973,11 +973,11 @@ Those files are saved in the directory given by the function ;; Rename to doc.pdf (rename-file opdf pdf) (doc-view-pdf/ps->png pdf png-file))))) - (pdf + (`pdf (let ((pages (doc-view-active-pages))) ;; Convert PDF to PNG images starting with the active pages. (doc-view-pdf->png doc-view-buffer-file-name png-file pages))) - (t + (_ ;; Convert to PNG images. (doc-view-pdf/ps->png doc-view-buffer-file-name png-file))))) @@ -1103,7 +1103,7 @@ have the page we want to view." (and (not (member pagefile prev-pages)) (member pagefile doc-view-current-files))) (with-selected-window win - (assert (eq (current-buffer) buffer)) + (cl-assert (eq (current-buffer) buffer)) (doc-view-goto-page page)))))))) (defun doc-view-buffer-message () diff --git a/lisp/edmacro.el b/lisp/edmacro.el index 4bc7f6af69a..b1a24bc88a6 100644 --- a/lisp/edmacro.el +++ b/lisp/edmacro.el @@ -63,8 +63,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'kmacro) @@ -319,17 +318,18 @@ or nil, use a compact 80-column format." mac)))) (if no-keys (when cmd - (loop for key in (where-is-internal cmd '(keymap)) do - (global-unset-key key))) + (cl-loop for key in (where-is-internal cmd '(keymap)) do + (global-unset-key key))) (when keys (if (= (length mac) 0) - (loop for key in keys do (global-unset-key key)) - (loop for key in keys do - (global-set-key key - (or cmd - (if (and mac-counter mac-format) - (kmacro-lambda-form mac mac-counter mac-format) - mac)))))))))) + (cl-loop for key in keys do (global-unset-key key)) + (cl-loop for key in keys do + (global-set-key key + (or cmd + (if (and mac-counter mac-format) + (kmacro-lambda-form + mac mac-counter mac-format) + mac)))))))))) (kill-buffer buf) (when (buffer-name obuf) (switch-to-buffer obuf)) @@ -437,9 +437,9 @@ doubt, use whitespace." (one-line (eq verbose 1))) (if one-line (setq verbose nil)) (when (stringp macro) - (loop for i below (length macro) do - (when (>= (aref rest-mac i) 128) - (incf (aref rest-mac i) (- ?\M-\^@ 128))))) + (cl-loop for i below (length macro) do + (when (>= (aref rest-mac i) 128) + (cl-incf (aref rest-mac i) (- ?\M-\^@ 128))))) (while (not (eq (aref rest-mac 0) 'end-macro)) (let* ((prefix (or (and (integerp (aref rest-mac 0)) @@ -448,57 +448,58 @@ doubt, use whitespace." '(digit-argument negative-argument)) (let ((i 1)) (while (memq (aref rest-mac i) (cdr mdigs)) - (incf i)) + (cl-incf i)) (and (not (memq (aref rest-mac i) pkeys)) (prog1 (vconcat "M-" (edmacro-subseq rest-mac 0 i) " ") - (callf edmacro-subseq rest-mac i))))) + (cl-callf edmacro-subseq rest-mac i))))) (and (eq (aref rest-mac 0) ?\C-u) (eq (key-binding [?\C-u]) 'universal-argument) (let ((i 1)) (while (eq (aref rest-mac i) ?\C-u) - (incf i)) + (cl-incf i)) (and (not (memq (aref rest-mac i) pkeys)) - (prog1 (loop repeat i concat "C-u ") - (callf edmacro-subseq rest-mac i))))) + (prog1 (cl-loop repeat i concat "C-u ") + (cl-callf edmacro-subseq rest-mac i))))) (and (eq (aref rest-mac 0) ?\C-u) (eq (key-binding [?\C-u]) 'universal-argument) (let ((i 1)) (when (eq (aref rest-mac i) ?-) - (incf i)) + (cl-incf i)) (while (memq (aref rest-mac i) '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)) - (incf i)) + (cl-incf i)) (and (not (memq (aref rest-mac i) pkeys)) (prog1 (vconcat "C-u " (edmacro-subseq rest-mac 1 i) " ") - (callf edmacro-subseq rest-mac i))))))) + (cl-callf edmacro-subseq rest-mac i))))))) (bind-len (apply 'max 1 - (loop for map in maps - for b = (lookup-key map rest-mac) - when b collect b))) + (cl-loop for map in maps + for b = (lookup-key map rest-mac) + when b collect b))) (key (edmacro-subseq rest-mac 0 bind-len)) (fkey nil) tlen tkey - (bind (or (loop for map in maps for b = (lookup-key map key) - thereis (and (not (integerp b)) b)) + (bind (or (cl-loop for map in maps for b = (lookup-key map key) + thereis (and (not (integerp b)) b)) (and (setq fkey (lookup-key local-function-key-map rest-mac)) (setq tlen fkey tkey (edmacro-subseq rest-mac 0 tlen) fkey (lookup-key local-function-key-map tkey)) - (loop for map in maps - for b = (lookup-key map fkey) - when (and (not (integerp b)) b) - do (setq bind-len tlen key tkey) - and return b - finally do (setq fkey nil))))) + (cl-loop for map in maps + for b = (lookup-key map fkey) + when (and (not (integerp b)) b) + do (setq bind-len tlen key tkey) + and return b + finally do (setq fkey nil))))) (first (aref key 0)) - (text (loop for i from bind-len below (length rest-mac) - for ch = (aref rest-mac i) - while (and (integerp ch) - (> ch 32) (< ch maxkey) (/= ch 92) - (eq (key-binding (char-to-string ch)) - 'self-insert-command) - (or (> i (- (length rest-mac) 2)) - (not (eq ch (aref rest-mac (+ i 1)))) - (not (eq ch (aref rest-mac (+ i 2)))))) - finally return i)) + (text + (cl-loop for i from bind-len below (length rest-mac) + for ch = (aref rest-mac i) + while (and (integerp ch) + (> ch 32) (< ch maxkey) (/= ch 92) + (eq (key-binding (char-to-string ch)) + 'self-insert-command) + (or (> i (- (length rest-mac) 2)) + (not (eq ch (aref rest-mac (+ i 1)))) + (not (eq ch (aref rest-mac (+ i 2)))))) + finally return i)) desc) (if (stringp bind) (setq bind nil)) (cond ((and (eq bind 'self-insert-command) (not prefix) @@ -509,7 +510,7 @@ doubt, use whitespace." (setq desc (concat (edmacro-subseq rest-mac 0 text))) (when (string-match "^[ACHMsS]-." desc) (setq text 2) - (callf substring desc 0 2)) + (cl-callf substring desc 0 2)) (not (string-match "^;;\\|^<.*>$\\|^\\\\[0-9]+$\\|^[0-9]+\\*." desc)))) @@ -535,17 +536,17 @@ doubt, use whitespace." (cond ((integerp ch) (concat - (loop for pf across "ACHMsS" - for bit in '(?\A-\^@ ?\C-\^@ ?\H-\^@ - ?\M-\^@ ?\s-\^@ ?\S-\^@) - when (/= (logand ch bit) 0) - concat (format "%c-" pf)) + (cl-loop for pf across "ACHMsS" + for bit in '(?\A-\^@ ?\C-\^@ ?\H-\^@ + ?\M-\^@ ?\s-\^@ ?\S-\^@) + when (/= (logand ch bit) 0) + concat (format "%c-" pf)) (let ((ch2 (logand ch (1- (lsh 1 18))))) (cond ((<= ch2 32) - (case ch2 + (pcase ch2 (0 "NUL") (9 "TAB") (10 "LFD") (13 "RET") (27 "ESC") (32 "SPC") - (t + (_ (format "C-%c" (+ (if (<= ch2 26) 96 64) ch2))))) @@ -563,30 +564,30 @@ doubt, use whitespace." (let ((times 1) (pos bind-len)) (while (not (edmacro-mismatch rest-mac rest-mac 0 bind-len pos (+ bind-len pos))) - (incf times) - (incf pos bind-len)) + (cl-incf times) + (cl-incf pos bind-len)) (when (> times 1) (setq desc (format "%d*%s" times desc)) (setq bind-len (* bind-len times))))) (setq rest-mac (edmacro-subseq rest-mac bind-len)) (if verbose (progn - (unless (equal res "") (callf concat res "\n")) - (callf concat res desc) + (unless (equal res "") (cl-callf concat res "\n")) + (cl-callf concat res desc) (when (and bind (or (stringp bind) (symbolp bind))) - (callf concat res + (cl-callf concat res (make-string (max (- 3 (/ (length desc) 8)) 1) 9) ";; " (if (stringp bind) bind (symbol-name bind)))) (setq len 0)) (if (and (> (+ len (length desc) 2) 72) (not one-line)) (progn - (callf concat res "\n ") + (cl-callf concat res "\n ") (setq len 1)) (unless (equal res "") - (callf concat res " ") - (incf len))) - (callf concat res desc) - (incf len (length desc))))) + (cl-callf concat res " ") + (cl-incf len))) + (cl-callf concat res desc) + (cl-incf len (length desc))))) res)) (defun edmacro-mismatch (cl-seq1 cl-seq2 cl-start1 cl-end1 cl-start2 cl-end2) @@ -638,9 +639,9 @@ If START or END is negative, it counts from the end." The string represents the same events; Meta is indicated by bit 7. This function assumes that the events can be stored in a string." (setq seq (copy-sequence seq)) - (loop for i below (length seq) do - (when (logand (aref seq i) 128) - (setf (aref seq i) (logand (aref seq i) 127)))) + (cl-loop for i below (length seq) do + (when (logand (aref seq i) 128) + (setf (aref seq i) (logand (aref seq i) 127)))) seq) (defun edmacro-fix-menu-commands (macro &optional noerror) @@ -655,7 +656,7 @@ This function assumes that the events can be stored in a string." ((eq (car ev) 'switch-frame)) ((equal ev '(menu-bar)) (push 'menu-bar result)) - ((equal (cadadr ev) '(menu-bar)) + ((equal (cl-cadadr ev) '(menu-bar)) (push (vector 'menu-bar (car ev)) result)) ;; It would be nice to do pop-up menus, too, but not enough ;; info is recorded in macros to make this possible. @@ -715,30 +716,31 @@ This function assumes that the events can be stored in a string." (t (let ((orig-word word) (prefix 0) (bits 0)) (while (string-match "^[ACHMsS]-." word) - (incf bits (cdr (assq (aref word 0) + (cl-incf bits (cdr (assq (aref word 0) '((?A . ?\A-\^@) (?C . ?\C-\^@) (?H . ?\H-\^@) (?M . ?\M-\^@) (?s . ?\s-\^@) (?S . ?\S-\^@))))) - (incf prefix 2) - (callf substring word 2)) + (cl-incf prefix 2) + (cl-callf substring word 2)) (when (string-match "^\\^.$" word) - (incf bits ?\C-\^@) - (incf prefix) - (callf substring word 1)) + (cl-incf bits ?\C-\^@) + (cl-incf prefix) + (cl-callf substring word 1)) (let ((found (assoc word '(("NUL" . "\0") ("RET" . "\r") ("LFD" . "\n") ("TAB" . "\t") ("ESC" . "\e") ("SPC" . " ") ("DEL" . "\177"))))) (when found (setq word (cdr found)))) (when (string-match "^\\\\[0-7]+$" word) - (loop for ch across word - for n = 0 then (+ (* n 8) ch -48) - finally do (setq word (vector n)))) + (cl-loop for ch across word + for n = 0 then (+ (* n 8) ch -48) + finally do (setq word (vector n)))) (cond ((= bits 0) (setq key word)) ((and (= bits ?\M-\^@) (stringp word) (string-match "^-?[0-9]+$" word)) - (setq key (loop for x across word collect (+ x bits)))) + (setq key (cl-loop for x across word + collect (+ x bits)))) ((/= (length word) 1) (error "%s must prefix a single character, not %s" (substring orig-word 0 prefix) word)) @@ -752,7 +754,7 @@ This function assumes that the events can be stored in a string." (t (setq key (list (+ bits (aref word 0))))))))) (when key - (loop repeat times do (callf vconcat res key))))) + (cl-loop repeat times do (cl-callf vconcat res key))))) (when (and (>= (length res) 4) (eq (aref res 0) ?\C-x) (eq (aref res 1) ?\() @@ -760,13 +762,13 @@ This function assumes that the events can be stored in a string." (eq (aref res (- (length res) 1)) ?\))) (setq res (edmacro-subseq res 2 -2))) (if (and (not need-vector) - (loop for ch across res - always (and (characterp ch) - (let ((ch2 (logand ch (lognot ?\M-\^@)))) - (and (>= ch2 0) (<= ch2 127)))))) - (concat (loop for ch across res - collect (if (= (logand ch ?\M-\^@) 0) - ch (+ ch 128)))) + (cl-loop for ch across res + always (and (characterp ch) + (let ((ch2 (logand ch (lognot ?\M-\^@)))) + (and (>= ch2 0) (<= ch2 127)))))) + (concat (cl-loop for ch across res + collect (if (= (logand ch ?\M-\^@) 0) + ch (+ ch 128)))) res))) (provide 'edmacro) diff --git a/lisp/electric.el b/lisp/electric.el index 6a31ba1f1d3..5f1445577e9 100644 --- a/lisp/electric.el +++ b/lisp/electric.el @@ -38,8 +38,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - ;; This loop is the guts for non-standard modes which retain control ;; until some event occurs. It is a `do-forever', the only way out is ;; to throw. It assumes that you have set up the keymap, window, and @@ -394,16 +392,16 @@ arguments that returns one of those symbols.") (not (nth 8 (save-excursion (syntax-ppss pos))))) (let ((end (copy-marker (point) t))) (goto-char pos) - (case (if (functionp rule) (funcall rule) rule) + (pcase (if (functionp rule) (funcall rule) rule) ;; FIXME: we used `newline' down here which called ;; self-insert-command and ran post-self-insert-hook recursively. ;; It happened to make electric-indent-mode work automatically with ;; electric-layout-mode (at the cost of re-indenting lines ;; multiple times), but I'm not sure it's what we want. - (before (goto-char (1- pos)) (skip-chars-backward " \t") + (`before (goto-char (1- pos)) (skip-chars-backward " \t") (unless (bolp) (insert "\n"))) - (after (insert "\n")) ; FIXME: check eolp before inserting \n? - (around (save-excursion + (`after (insert "\n")) ; FIXME: check eolp before inserting \n? + (`around (save-excursion (goto-char (1- pos)) (skip-chars-backward " \t") (unless (bolp) (insert "\n"))) (insert "\n"))) ; FIXME: check eolp before inserting \n? diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index fba8915fd5f..1bdd6d8fc4b 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -155,13 +155,14 @@ expression, in which case we want to handle forms differently." define-overloadable-function)) (let* ((macrop (memq car '(defmacro defmacro*))) (name (nth 1 form)) - (args (cl-case car - ((defun defmacro defun* defmacro* - define-overloadable-function) (nth 2 form)) - ((define-skeleton) '(&optional str arg)) - ((define-generic-mode define-derived-mode - define-compilation-mode) nil) - (t))) + (args (pcase car + ((or `defun `defmacro + `defun* `defmacro* `cl-defun `cl-defmacro + `define-overloadable-function) (nth 2 form)) + (`define-skeleton '(&optional str arg)) + ((or `define-generic-mode `define-derived-mode + `define-compilation-mode) nil) + (_ t))) (body (nthcdr (or (get car 'doc-string-elt) 3) form)) (doc (if (stringp (car body)) (pop body)))) ;; Add the usage form at the end where describe-function-1 diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 8822c03c103..5a3fd7dddb1 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -630,10 +630,10 @@ (while (eq (car-safe form) 'progn) (setq form (car (last (cdr form))))) (cond ((consp form) - (cl-case (car form) - (quote (cadr form)) + (pcase (car form) + (`quote (cadr form)) ;; Can't use recursion in a defsubst. - ;; (progn (byte-compile-trueconstp (car (last (cdr form))))) + ;; (`progn (byte-compile-trueconstp (car (last (cdr form))))) )) ((not (symbolp form))) ((eq form t)) @@ -644,10 +644,10 @@ (while (eq (car-safe form) 'progn) (setq form (car (last (cdr form))))) (cond ((consp form) - (cl-case (car form) - (quote (null (cadr form))) + (pcase (car form) + (`quote (null (cadr form))) ;; Can't use recursion in a defsubst. - ;; (progn (byte-compile-nilconstp (car (last (cdr form))))) + ;; (`progn (byte-compile-nilconstp (car (last (cdr form))))) )) ((not (symbolp form)) nil) ((null form)))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 76b147a4c65..751515beb3e 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1591,10 +1591,11 @@ that already has a `.elc' file." (not (auto-save-file-name-p source)) (not (string-equal dir-locals-file (file-name-nondirectory source)))) - (progn (cl-case (byte-recompile-file source force arg) - (no-byte-compile (setq skip-count (1+ skip-count))) - ((t) (setq file-count (1+ file-count))) - ((nil) (setq fail-count (1+ fail-count)))) + (progn (incf + (pcase (byte-recompile-file source force arg) + (`no-byte-compile skip-count) + (`t file-count) + (_ fail-count))) (or noninteractive (message "Checking %s..." directory)) (if (not (eq last-dir directory)) @@ -2974,12 +2975,12 @@ That command is designed for interactive use only" fn)) ;; Old-style byte-code. (cl-assert (listp fargs)) (while fargs - (cl-case (car fargs) - (&optional (setq fargs (cdr fargs))) - (&rest (setq fmax2 (+ (* 2 (length dynbinds)) 1)) + (pcase (car fargs) + (`&optional (setq fargs (cdr fargs))) + (`&rest (setq fmax2 (+ (* 2 (length dynbinds)) 1)) (push (cadr fargs) dynbinds) (setq fargs nil)) - (t (push (pop fargs) dynbinds)))) + (_ (push (pop fargs) dynbinds)))) (unless fmax2 (setq fmax2 (* 2 (length dynbinds))))) (cond ((<= (+ alen alen) fmax2) @@ -3024,10 +3025,10 @@ That command is designed for interactive use only" fn)) (and od (not (memq var byte-compile-not-obsolete-vars)) (not (memq var byte-compile-global-not-obsolete-vars)) - (or (cl-case (nth 1 od) - (set (not (eq access-type 'reference))) - (get (eq access-type 'reference)) - (t t))))) + (or (pcase (nth 1 od) + (`set (not (eq access-type 'reference))) + (`get (eq access-type 'reference)) + (_ t))))) (byte-compile-warn-obsolete var)))) (defsubst byte-compile-dynamic-variable-op (base-op var) @@ -4351,21 +4352,21 @@ invoked interactively." (if byte-compile-call-tree-sort (setq byte-compile-call-tree (sort byte-compile-call-tree - (cl-case byte-compile-call-tree-sort - (callers + (pcase byte-compile-call-tree-sort + (`callers (lambda (x y) (< (length (nth 1 x)) (length (nth 1 y))))) - (calls + (`calls (lambda (x y) (< (length (nth 2 x)) (length (nth 2 y))))) - (calls+callers + (`calls+callers (lambda (x y) (< (+ (length (nth 1 x)) (length (nth 2 x))) (+ (length (nth 1 y)) (length (nth 2 y)))))) - (name + (`name (lambda (x y) (string< (car x) (car y)))) - (t (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode" + (_ (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode" byte-compile-call-tree-sort)))))) (message "Generating call tree...") (let ((rest byte-compile-call-tree) diff --git a/lisp/emulation/crisp.el b/lisp/emulation/crisp.el index cfb8ed07595..d29736d6860 100644 --- a/lisp/emulation/crisp.el +++ b/lisp/emulation/crisp.el @@ -54,8 +54,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - ;; local variables (defgroup crisp nil @@ -361,7 +359,7 @@ if ARG is omitted or nil." (when crisp-mode ;; Make menu entries show M-u or f14 in preference to C-x u. (put 'undo :advertised-binding - (list* [?\M-u] [f14] (get 'undo :advertised-binding))) + `([?\M-u] [f14] ,@(get 'undo :advertised-binding))) ;; Force transient-mark-mode, so that the marking routines work as ;; expected. If the user turns off transient mark mode, most ;; things will still work fine except the crisp-(copy|kill) diff --git a/lisp/face-remap.el b/lisp/face-remap.el index e2f9e3d2bd2..09503d7c154 100644 --- a/lisp/face-remap.el +++ b/lisp/face-remap.el @@ -315,9 +315,9 @@ a top-level keymap, `text-scale-increase' or (let* ((base (event-basic-type ev)) (step (pcase base - ((or `?+ `?=) inc) - (`?- (- inc)) - (`?0 0) + ((or ?+ ?=) inc) + (?- (- inc)) + (?0 0) (t inc)))) (text-scale-increase step) ;; FIXME: do it after every "iteration of the loop". diff --git a/lisp/filesets.el b/lisp/filesets.el index 86ebe47580b..6c24a4f43d6 100644 --- a/lisp/filesets.el +++ b/lisp/filesets.el @@ -88,9 +88,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) - +(eval-when-compile (require 'cl-lib)) ;;; Some variables @@ -1286,11 +1284,11 @@ on-close-all ... Not used" (or entry (filesets-get-external-viewer filename))))) (filesets-alist-get def - (case event - ((on-open-all) ':ignore-on-open-all) - ((on-grep) ':ignore-on-read-text) - ((on-cmd) nil) - ((on-close-all) nil)) + (pcase event + (`on-open-all ':ignore-on-open-all) + (`on-grep ':ignore-on-read-text) + (`on-cmd nil) + (`on-close-all nil)) nil t))) (defun filesets-filetype-get-prop (property filename &optional entry) @@ -1559,11 +1557,9 @@ SAVE-FUNCTION takes no argument, but works on the current buffer." (defun filesets-get-fileset-from-name (name &optional mode) "Get fileset definition for NAME." - (case mode - ((:ingroup :tree) - name) - (t - (assoc name filesets-data)))) + (pcase mode + ((or `:ingroup `:tree) name) + (_ (assoc name filesets-data)))) ;;; commands @@ -1720,22 +1716,22 @@ Replace <file-name> or <<file-name>> with filename." Assume MODE (see `filesets-entry-mode'), if provided." (let* ((mode (or mode (filesets-entry-mode entry))) - (fl (case mode - ((:files) + (fl (pcase mode + (:files (filesets-entry-get-files entry)) - ((:file) + (:file (list (filesets-entry-get-file entry))) - ((:ingroup) + (:ingroup (let ((entry (expand-file-name (if (stringp entry) entry (filesets-entry-get-master entry))))) (cons entry (filesets-ingroup-cache-get entry)))) - ((:tree) + (:tree (let ((dir (nth 0 entry)) (patt (nth 1 entry))) (filesets-directory-files dir patt ':files t))) - ((:pattern) + (:pattern (let ((dirpatt (filesets-entry-get-pattern entry))) (if dirpatt (let ((dir (filesets-entry-get-pattern--dir dirpatt)) @@ -1904,12 +1900,12 @@ User will be queried, if no fileset name is provided." (let* ((result nil) (factor (ceiling (/ (float bl) filesets-max-submenu-length)))) - (do ((data submenu-body (cdr data)) - (n 1 (+ n 1)) - (count 0 (+ count factor))) + (cl-do ((data submenu-body (cdr data)) + (n 1 (+ n 1)) + (count 0 (+ count factor))) ((or (> count bl) (null data))) -; (let ((sl (subseq submenu-body count + ;; (let ((sl (subseq submenu-body count (let ((sl (filesets-sublist submenu-body count (let ((x (+ count factor))) (if (>= bl x) @@ -1926,7 +1922,7 @@ User will be queried, if no fileset name is provided." `((,(concat (filesets-get-shortcut n) (let ((rv "")) - (do ((x sl (cdr x))) + (cl-do ((x sl (cdr x))) ((null x)) (let ((y (concat (elt (car x) 0) (if (null (cdr x)) @@ -1952,8 +1948,8 @@ User will be queried, if no fileset name is provided." "Get submenu epilog for SOMETHING (usually a fileset). If mode is :tree or :ingroup, SOMETHING is some weird construct and LOOKUP-NAME is used as lookup name for retrieving fileset specific settings." - (case mode - ((:tree) + (pcase mode + (:tree `("---" ["Close all files" (filesets-close ',mode ',something ',lookup-name)] ["Run Command" (filesets-run-cmd nil ',something ',mode)] @@ -1962,14 +1958,14 @@ LOOKUP-NAME is used as lookup name for retrieving fileset specific settings." ,@(when rebuild-flag `(["Rebuild this submenu" (filesets-rebuild-this-submenu ',lookup-name)])))) - ((:ingroup) + (:ingroup `("---" ["Close all files" (filesets-close ',mode ',something ',lookup-name)] ["Run Command" (filesets-run-cmd nil ',something ',mode)] ,@(when rebuild-flag `(["Rebuild this submenu" (filesets-rebuild-this-submenu ',lookup-name)])))) - ((:pattern) + (:pattern `("---" ["Close all files" (filesets-close ',mode ',something)] ["Run Command" (filesets-run-cmd nil ',something ',mode)] @@ -1986,7 +1982,7 @@ LOOKUP-NAME is used as lookup name for retrieving fileset specific settings." ,@(when rebuild-flag `(["Rebuild this submenu" (filesets-rebuild-this-submenu ',lookup-name)])))) - ((:files) + (:files `("---" [,(concat "Close all files") (filesets-close ',mode ',something)] ["Run Command" (filesets-run-cmd nil ',something ',mode)] @@ -1997,7 +1993,7 @@ LOOKUP-NAME is used as lookup name for retrieving fileset specific settings." ,@(when rebuild-flag `(["Rebuild this submenu" (filesets-rebuild-this-submenu ',lookup-name)])))) - (t + (_ (filesets-error 'error "Filesets: malformed definition of " something)))) (defun filesets-ingroup-get-data (master pos &optional fun) @@ -2249,15 +2245,15 @@ Construct a shortcut from COUNT." (filesets-verbosity (filesets-entry-get-verbosity entry)) (this-lookup-name (concat (filesets-get-shortcut count) lookup-name))) - (case mode - ((:file) + (pcase mode + (:file (let* ((file (filesets-entry-get-file entry))) `[,this-lookup-name (filesets-file-open nil ',file ',lookup-name)])) - (t + (_ `(,this-lookup-name - ,@(case mode - ((:pattern) + ,@(pcase mode + (:pattern (let* ((files (filesets-get-filelist entry mode 'on-ls)) (dirpatt (filesets-entry-get-pattern entry)) (pattname (apply 'concat (cons "Pattern: " dirpatt))) @@ -2276,7 +2272,7 @@ Construct a shortcut from COUNT." files)) ,@(filesets-get-menu-epilog lookup-name mode lookup-name t)))) - ((:ingroup) + (:ingroup (let* ((master (filesets-entry-get-master entry))) ;;(filesets-message 3 "Filesets: parsing %S" master) `([,(concat "Inclusion Group: " @@ -2288,12 +2284,12 @@ Construct a shortcut from COUNT." ,@(filesets-wrap-submenu (filesets-build-ingroup-submenu lookup-name master)) ,@(filesets-get-menu-epilog master mode lookup-name t)))) - ((:tree) + (:tree (let* ((dirpatt (filesets-entry-get-tree entry)) (dir (car dirpatt)) (patt (cadr dirpatt))) (filesets-build-dir-submenu entry lookup-name dir patt))) - ((:files) + (:files (let ((files (filesets-get-filelist entry mode 'on-open-all)) (count 0)) `([,(concat "Files: " lookup-name) @@ -2331,9 +2327,9 @@ bottom up, set `filesets-submenus' to nil, first.)" (setq filesets-has-changed-flag nil) (setq filesets-updated-buffers nil) (setq filesets-update-cache-file-flag t) - (do ((data (filesets-conditional-sort filesets-data (function car)) - (cdr data)) - (count 1 (+ count 1))) + (cl-do ((data (filesets-conditional-sort filesets-data (function car)) + (cdr data)) + (count 1 (+ count 1))) ((null data)) (let* ((this (car data)) (name (filesets-data-get-name this)) diff --git a/lisp/font-lock.el b/lisp/font-lock.el index de2e043a56a..f3e313e9c35 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -207,7 +207,7 @@ ;;; Code: (require 'syntax) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;; Define core `font-lock' group. (defgroup font-lock '((jit-lock custom-group)) @@ -614,9 +614,6 @@ Major/minor modes can set this variable if they know which option applies.") (eval-when-compile ;; - ;; We don't do this at the top-level as we only use non-autoloaded macros. - (require 'cl) - ;; ;; Borrowed from lazy-lock.el. ;; We use this to preserve or protect things when modifying text properties. (defmacro save-buffer-state (&rest body) @@ -917,10 +914,10 @@ The value of this variable is used when Font Lock mode is turned on." (declare-function lazy-lock-mode "lazy-lock") (defun font-lock-turn-on-thing-lock () - (case (font-lock-value-in-major-mode font-lock-support-mode) - (fast-lock-mode (fast-lock-mode t)) - (lazy-lock-mode (lazy-lock-mode t)) - (jit-lock-mode + (pcase (font-lock-value-in-major-mode font-lock-support-mode) + (`fast-lock-mode (fast-lock-mode t)) + (`lazy-lock-mode (lazy-lock-mode t)) + (`jit-lock-mode ;; Prepare for jit-lock (remove-hook 'after-change-functions 'font-lock-after-change-function t) @@ -1654,7 +1651,7 @@ LOUDLY, if non-nil, allows progress-meter bar." ;; Fontify each item in `font-lock-keywords' from `start' to `end'. (while keywords (if loudly (message "Fontifying %s... (regexps..%s)" bufname - (make-string (incf count) ?.))) + (make-string (cl-incf count) ?.))) ;; ;; Find an occurrence of `matcher' from `start' to `end'. (setq keyword (car keywords) matcher (car keyword)) diff --git a/lisp/frame.el b/lisp/frame.el index 43704d3f20d..778028390e7 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -25,8 +25,6 @@ ;;; Commentary: ;;; Code: -(eval-when-compile (require 'cl)) - (defvar frame-creation-function-alist (list (cons nil (if (fboundp 'tty-create-frame-with-faces) diff --git a/lisp/hexl.el b/lisp/hexl.el index a754a151fb7..fcdef742cab 100644 --- a/lisp/hexl.el +++ b/lisp/hexl.el @@ -41,7 +41,7 @@ ;;; Code: (require 'eldoc) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) ;For letf (default-value 'major-mode). ;; ;; vars here diff --git a/lisp/image-mode.el b/lisp/image-mode.el index 46ce6aa14d3..fabc12c0219 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -34,7 +34,7 @@ ;;; Code: (require 'image) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;;; Image mode window-info management. @@ -70,12 +70,11 @@ A winprops object has the shape (WINDOW . ALIST)." winprops)) (defun image-mode-window-get (prop &optional winprops) + (declare (gv-setter (lambda (val) + `(image-mode-window-put ,prop ,val ,winprops)))) (unless (consp winprops) (setq winprops (image-mode-winprops winprops))) (cdr (assq prop (cdr winprops)))) -(defsetf image-mode-window-get (prop &optional winprops) (val) - `(image-mode-window-put ,prop ,val ,winprops)) - (defun image-mode-window-put (prop val &optional winprops) (unless (consp winprops) (setq winprops (image-mode-winprops winprops))) (setcdr winprops (cons (cons prop val) @@ -692,20 +691,20 @@ a slightly different angle. Currently this is done for values close to a multiple of 90, see `image-transform-right-angle-fudge'." (cond ((< (abs (- (mod (+ image-transform-rotation 90) 180) 90)) image-transform-right-angle-fudge) - (assert (not (zerop width)) t) + (cl-assert (not (zerop width)) t) (setq image-transform-rotation (float (round image-transform-rotation)) image-transform-scale (/ (float length) width)) (cons length nil)) ((< (abs (- (mod (+ image-transform-rotation 45) 90) 45)) image-transform-right-angle-fudge) - (assert (not (zerop height)) t) + (cl-assert (not (zerop height)) t) (setq image-transform-rotation (float (round image-transform-rotation)) image-transform-scale (/ (float length) height)) (cons nil length)) (t - (assert (not (and (zerop width) (zerop height))) t) + (cl-assert (not (and (zerop width) (zerop height))) t) (setq image-transform-scale (/ (float (1- length)) (image-transform-width width height))) ;; Assume we have a w x h image and an angle A, and let l = @@ -743,12 +742,12 @@ close to a multiple of 90, see `image-transform-right-angle-fudge'." (unless (numberp image-transform-resize) (let ((size (image-display-size (image-get-display-property) t))) (cond ((eq image-transform-resize 'fit-width) - (assert (= (car size) + (cl-assert (= (car size) (- (nth 2 (window-inside-pixel-edges)) (nth 0 (window-inside-pixel-edges)))) t)) ((eq image-transform-resize 'fit-height) - (assert (= (cdr size) + (cl-assert (= (cdr size) (- (nth 3 (window-inside-pixel-edges)) (nth 1 (window-inside-pixel-edges)))) t)))))) diff --git a/lisp/imenu.el b/lisp/imenu.el index 24beb9c89c1..8cef5161a37 100644 --- a/lisp/imenu.el +++ b/lisp/imenu.el @@ -59,7 +59,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -481,7 +481,7 @@ The returned list DOES NOT share structure with LIST." (i 0)) (while remain (push (pop remain) sublist) - (incf i) + (cl-incf i) (and (= i n) ;; We have finished a sublist (progn (push (nreverse sublist) result) @@ -593,17 +593,17 @@ Non-nil arguments are in recursive calls." t)) (defun imenu--create-keymap (title alist &optional cmd) - (list* 'keymap title - (mapcar - (lambda (item) - (list* (car item) (car item) - (cond - ((imenu--subalist-p item) - (imenu--create-keymap (car item) (cdr item) cmd)) - (t - `(lambda () (interactive) - ,(if cmd `(,cmd ',item) (list 'quote item))))))) - alist))) + `(keymap ,title + ,@(mapcar + (lambda (item) + `(,(car item) ,(car item) + ,@(cond + ((imenu--subalist-p item) + (imenu--create-keymap (car item) (cdr item) cmd)) + (t + `(lambda () (interactive) + ,(if cmd `(,cmd ',item) (list 'quote item))))))) + alist))) (defun imenu--in-alist (str alist) "Check whether the string STR is contained in multi-level ALIST." diff --git a/lisp/info-xref.el b/lisp/info-xref.el index 69ec00ce09d..ebe50551a69 100644 --- a/lisp/info-xref.el +++ b/lisp/info-xref.el @@ -45,8 +45,7 @@ ;;; Code: (require 'info) -(eval-when-compile - (require 'cl)) ;; for `incf' +(eval-when-compile (require 'cl-lib)) ;; for `incf' ;;----------------------------------------------------------------------------- ;; vaguely generic @@ -239,11 +238,11 @@ buffer's line and column of point." ;; if the file exists, try the node (cond ((not (cdr (assoc file info-xref-xfile-alist))) - (incf info-xref-unavail)) + (cl-incf info-xref-unavail)) ((info-xref-goto-node-p node) - (incf info-xref-good)) + (cl-incf info-xref-good)) (t - (incf info-xref-bad) + (cl-incf info-xref-bad) (info-xref-output-error "no such node: %s" node))))))) @@ -447,8 +446,8 @@ and can take a long time." (if (eq :tag (cadr link)) (setq link (cddr link))) (if (info-xref-goto-node-p (cadr link)) - (incf info-xref-good) - (incf info-xref-bad) + (cl-incf info-xref-good) + (cl-incf info-xref-bad) ;; symbol-file gives nil for preloaded variables, would need ;; to copy what describe-variable does to show the right place (info-xref-output "Symbol `%s' (file %s): cannot goto node: %s" diff --git a/lisp/info.el b/lisp/info.el index 0afb3f01339..163e0af161a 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -32,8 +32,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (defgroup info nil "Info subsystem." :group 'help diff --git a/lisp/international/iso-ascii.el b/lisp/international/iso-ascii.el index 0566b8ead5c..536cd231753 100644 --- a/lisp/international/iso-ascii.el +++ b/lisp/international/iso-ascii.el @@ -32,7 +32,6 @@ ;;; Code: (require 'disp-table) -(eval-when-compile (require 'cl)) (defgroup iso-ascii nil "Set up char tables for ISO 8859/1 on ASCII terminals." @@ -167,9 +166,14 @@ With a prefix argument ARG, enable the mode if ARG is positive, and disable it otherwise. If called from Lisp, enable the mode if ARG is omitted or nil." - :variable (eq standard-display-table iso-ascii-display-table) - (unless standard-display-table - (setq standard-display-table iso-ascii-standard-display-table))) + :variable ((eq standard-display-table iso-ascii-display-table) + . (lambda (v) + (setq standard-display-table + (cond + (v iso-ascii-display-table) + ((eq standard-display-table iso-ascii-display-table) + iso-ascii-standard-display-table) + (t standard-display-table)))))) (provide 'iso-ascii) diff --git a/lisp/international/quail.el b/lisp/international/quail.el index 4d69e2fdbcb..fecc9427731 100644 --- a/lisp/international/quail.el +++ b/lisp/international/quail.el @@ -53,7 +53,7 @@ ;;; Code: (require 'help-mode) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defgroup quail nil "Quail: multilingual input method." @@ -2395,10 +2395,10 @@ should be made by `quail-build-decode-map' (which see)." (let ((last-col-elt (or (nth (1- (* (1+ col) newrows)) single-list) (car (last single-list))))) - (incf width (+ (max 3 (length (car last-col-elt))) - 1 single-trans-width 1)))) + (cl-incf width (+ (max 3 (length (car last-col-elt))) + 1 single-trans-width 1)))) (< width window-width)) - (incf cols)) + (cl-incf cols)) (setq rows (/ (+ len cols -1) cols)) ;Round up. (let ((key-width (max 3 (length (car (nth (1- rows) single-list)))))) (insert "key") diff --git a/lisp/international/ucs-normalize.el b/lisp/international/ucs-normalize.el index cc75cc21cbe..54566e1d004 100644 --- a/lisp/international/ucs-normalize.el +++ b/lisp/international/ucs-normalize.el @@ -109,7 +109,7 @@ (defconst ucs-normalize-version "1.2") -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (declare-function nfd "ucs-normalize" (char)) @@ -179,7 +179,7 @@ (let ((char 0) ccc decomposition) (mapc (lambda (start-end) - (do ((char (car start-end) (+ char 1))) ((> char (cdr start-end))) + (cl-do ((char (car start-end) (+ char 1))) ((> char (cdr start-end))) (setq ccc (ucs-normalize-ccc char)) (setq decomposition (get-char-code-property char 'decomposition)) @@ -270,7 +270,7 @@ Note that Hangul are excluded.") (let (decomposition alist) (mapc (lambda (start-end) - (do ((char (car start-end) (+ char 1))) ((> char (cdr start-end))) + (cl-do ((char (car start-end) (+ char 1))) ((> char (cdr start-end))) (setq decomposition (funcall decomposition-function char)) (if decomposition (setq alist (cons (cons char @@ -391,7 +391,7 @@ decomposition." (let (entries decomposition composition) (mapc (lambda (start-end) - (do ((i (car start-end) (+ i 1))) ((> i (cdr start-end))) + (cl-do ((i (car start-end) (+ i 1))) ((> i (cdr start-end))) (setq decomposition (string-to-list (with-temp-buffer diff --git a/lisp/jit-lock.el b/lisp/jit-lock.el index ec44b17835c..55e25e4c262 100644 --- a/lisp/jit-lock.el +++ b/lisp/jit-lock.el @@ -29,8 +29,6 @@ (eval-when-compile - (require 'cl) - (defmacro with-buffer-prepared-for-jit-lock (&rest body) "Execute BODY in current buffer, overriding several variables. Preserves the `buffer-modified-p' state of the current buffer." diff --git a/lisp/loadhist.el b/lisp/loadhist.el index d5099340a17..88aa9f53b75 100644 --- a/lisp/loadhist.el +++ b/lisp/loadhist.el @@ -29,8 +29,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (defun feature-symbols (feature) "Return the file and list of definitions associated with FEATURE. The value is actually the element of `load-history' @@ -254,11 +252,11 @@ something strange, such as redefining an Emacs function." (dolist (x unload-function-defs-list) (if (consp x) - (case (car x) + (pcase (car x) ;; Remove any feature names that this file provided. - (provide + (`provide (setq features (delq (cdr x) features))) - ((defun autoload) + ((or `defun `autoload) (let ((fun (cdr x))) (when (fboundp fun) (when (fboundp 'ad-unadvise) @@ -270,9 +268,9 @@ something strange, such as redefining an Emacs function." ;; (t . SYMBOL) comes before (defun . SYMBOL) ;; and says we should restore SYMBOL's autoload ;; when we undefine it. - ((t) (setq restore-autoload (cdr x))) - ((require defface) nil) - (t (message "Unexpected element %s in load-history" x))) + (`t (setq restore-autoload (cdr x))) + ((or `require `defface) nil) + (_ (message "Unexpected element %s in load-history" x))) ;; Kill local values as much as possible. (dolist (buf (buffer-list)) (with-current-buffer buf diff --git a/lisp/lpr.el b/lisp/lpr.el index 65295a7f860..b31d19b624f 100644 --- a/lisp/lpr.el +++ b/lisp/lpr.el @@ -29,8 +29,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - ;;;###autoload (defvar lpr-windows-system (memq system-type '(ms-dos windows-nt)) @@ -281,10 +279,10 @@ for further customization of the printer command." (if (markerp end) (set-marker end nil)) (message "Spooling%s...done%s%s" switch-string - (case (count-lines (point-min) (point-max)) + (pcase (count-lines (point-min) (point-max)) (0 "") (1 ": ") - (t ":\n")) + (_ ":\n")) (buffer-string))))))) ;; This function copies the text between start and end diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index e20106e1098..5c2c14d1fdb 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -81,7 +81,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;;; Completion table manipulation @@ -224,10 +224,10 @@ the form (concat S2 S)." (cond ((eq (car-safe action) 'boundaries) (let ((beg (or (and (eq (car-safe res) 'boundaries) (cadr res)) 0))) - (list* 'boundaries - (max (length s1) - (+ beg (- (length s1) (length s2)))) - (and (eq (car-safe res) 'boundaries) (cddr res))))) + `(boundaries + ,(max (length s1) + (+ beg (- (length s1) (length s2)))) + . ,(and (eq (car-safe res) 'boundaries) (cddr res))))) ((stringp res) (if (eq t (compare-strings res 0 (length s2) s2 nil nil completion-ignore-case)) @@ -267,7 +267,7 @@ the form (concat S2 S)." (if (eq (car-safe action) 'boundaries) (let* ((len (length prefix)) (bound (completion-boundaries string table pred (cdr action)))) - (list* 'boundaries (+ (car bound) len) (cdr bound))) + `(boundaries ,(+ (car bound) len) . ,(cdr bound))) (let ((comp (complete-with-action action table string pred))) (cond ;; In case of try-completion, add the prefix. @@ -300,8 +300,8 @@ instead of a string, a function that takes the completion and returns the (cdr terminator) (regexp-quote terminator))) (max (and terminator-regexp (string-match terminator-regexp suffix)))) - (list* 'boundaries (car bounds) - (min (cdr bounds) (or max (length suffix)))))) + `(boundaries ,(car bounds) + . ,(min (cdr bounds) (or max (length suffix)))))) ((eq action nil) (let ((comp (try-completion string table pred))) (if (consp terminator) (setq terminator (car terminator))) @@ -408,7 +408,7 @@ for use at QPOS." (qsuffix (cdr action)) (ufull (if (zerop (length qsuffix)) ustring (funcall unquote (concat string qsuffix)))) - (_ (assert (string-prefix-p ustring ufull))) + (_ (cl-assert (string-prefix-p ustring ufull))) (usuffix (substring ufull (length ustring))) (boundaries (completion-boundaries ustring table pred usuffix)) (qlboundary (car (funcall requote (car boundaries) string))) @@ -418,7 +418,7 @@ for use at QPOS." (- (car (funcall requote urfullboundary (concat string qsuffix))) (length string)))))) - (list* 'boundaries qlboundary qrboundary))) + `(boundaries ,qlboundary . ,qrboundary))) ;; In "normal" use a c-t-with-quoting completion table should never be ;; called with action in (t nil) because `completion--unquote' should have @@ -466,18 +466,18 @@ for use at QPOS." (let ((ustring (funcall unquote string)) (uprefix (funcall unquote (substring string 0 pred)))) ;; We presume (more or less) that `concat' and `unquote' commute. - (assert (string-prefix-p uprefix ustring)) + (cl-assert (string-prefix-p uprefix ustring)) (list ustring table (length uprefix) (lambda (unquoted-result op) (pcase op - (`1 ;;try + (1 ;;try (if (not (stringp (car-safe unquoted-result))) unquoted-result (completion--twq-try string ustring (car unquoted-result) (cdr unquoted-result) unquote requote))) - (`2 ;;all + (2 ;;all (let* ((last (last unquoted-result)) (base (or (cdr last) 0))) (when last @@ -527,12 +527,12 @@ for use at QPOS." (`(,qfullpos . ,qfun) (funcall requote (+ boundary (length prefix)) string)) (qfullprefix (substring string 0 qfullpos)) - (_ (assert (completion--string-equal-p - (funcall unquote qfullprefix) - (concat (substring ustring 0 boundary) prefix)) - t)) + (_ (cl-assert (completion--string-equal-p + (funcall unquote qfullprefix) + (concat (substring ustring 0 boundary) prefix)) + t)) (qboundary (car (funcall requote boundary string))) - (_ (assert (<= qboundary qfullpos))) + (_ (cl-assert (<= qboundary qfullpos))) ;; FIXME: this split/quote/concat business messes up the carefully ;; placed completions-common-part and completions-first-difference ;; faces. We could try within the mapcar loop to search for the @@ -555,11 +555,11 @@ for use at QPOS." ;; which only get quoted when needed by choose-completion. (nconc (mapcar (lambda (completion) - (assert (string-prefix-p prefix completion 'ignore-case) t) + (cl-assert (string-prefix-p prefix completion 'ignore-case) t) (let* ((new (substring completion (length prefix))) (qnew (funcall qfun new)) (qcompletion (concat qprefix qnew))) - (assert + (cl-assert (completion--string-equal-p (funcall unquote (concat (substring string 0 qboundary) @@ -994,9 +994,9 @@ when the buffer's text is already an exact match." 'exact 'unknown)))) ;; Show the completion table, if requested. ((not exact) - (if (case completion-auto-help - (lazy (eq this-command last-command)) - (t completion-auto-help)) + (if (pcase completion-auto-help + (`lazy (eq this-command last-command)) + (_ completion-auto-help)) (minibuffer-completion-help) (completion--message "Next char not unique"))) ;; If the last exact completion and this one were the same, it @@ -1041,9 +1041,9 @@ scroll the window of possible completions." ((and completion-cycling completion-all-sorted-completions) (minibuffer-force-complete) t) - (t (case (completion--do-completion) + (t (pcase (completion--do-completion) (#b000 nil) - (t t))))) + (_ t))))) (defun completion--cache-all-sorted-completions (comps) (add-hook 'after-change-functions @@ -1203,15 +1203,15 @@ If `minibuffer-completion-confirm' is `confirm-after-completion', (t ;; Call do-completion, but ignore errors. - (case (condition-case nil + (pcase (condition-case nil (completion--do-completion nil 'expect-exact) (error 1)) - ((#b001 #b011) (exit-minibuffer)) + ((or #b001 #b011) (exit-minibuffer)) (#b111 (if (not minibuffer-completion-confirm) (exit-minibuffer) (minibuffer-message "Confirm") nil)) - (t nil)))))) + (_ nil)))))) (defun completion--try-word-completion (string table predicate point md) (let ((comp (completion-try-completion string table predicate point md))) @@ -1306,9 +1306,9 @@ After one word is completed as much as possible, a space or hyphen is added, provided that matches some possible completion. Return nil if there is no valid completion, else t." (interactive) - (case (completion--do-completion 'completion--try-word-completion) + (pcase (completion--do-completion 'completion--try-word-completion) (#b000 nil) - (t t))) + (_ t))) (defface completions-annotations '((t :inherit italic)) "Face to use for annotations in the *Completions* buffer.") @@ -1555,7 +1555,7 @@ variables.") (defun completion--done (string &optional finished message) (let* ((exit-fun (plist-get completion-extra-properties :exit-function)) (pre-msg (and exit-fun (current-message)))) - (assert (memq finished '(exact sole finished unknown))) + (cl-assert (memq finished '(exact sole finished unknown))) ;; FIXME: exit-fun should receive `finished' as a parameter. (when exit-fun (when (eq finished 'unknown) @@ -1727,7 +1727,7 @@ Return nil if there is no valid completion, else t. Point needs to be somewhere between START and END. PREDICATE (a function called with no arguments) says when to exit." - (assert (<= start (point)) (<= (point) end)) + (cl-assert (<= start (point)) (<= (point) end)) (with-wrapper-hook ;; FIXME: Maybe we should use this hook to provide a "display ;; completions" operation as well. @@ -1794,7 +1794,7 @@ the mode if ARG is omitted or nil." (unless (equal "*Completions*" (buffer-name (window-buffer))) (minibuffer-hide-completions)) ;; (add-hook 'pre-command-hook #'completion-in-region--prech) - (assert completion-in-region-mode-predicate) + (cl-assert completion-in-region-mode-predicate) (setq completion-in-region-mode--predicate completion-in-region-mode-predicate) (add-hook 'post-command-hook #'completion-in-region--postch) @@ -1837,10 +1837,10 @@ a completion function or god knows what else.") ;; always return the same kind of data, but this breaks down with functions ;; like comint-completion-at-point or mh-letter-completion-at-point, which ;; could be sometimes safe and sometimes misbehaving (and sometimes neither). - (if (case which - (all t) - (safe (member fun completion--capf-safe-funs)) - (optimist (not (member fun completion--capf-misbehave-funs)))) + (if (pcase which + (`all t) + (`safe (member fun completion--capf-safe-funs)) + (`optimist (not (member fun completion--capf-misbehave-funs)))) (let ((res (funcall fun))) (cond ((and (consp res) (not (functionp res))) @@ -2046,10 +2046,10 @@ same as `substitute-in-file-name'." (if (eq action 'metadata) '(metadata (category . environment-variable)) (let ((suffix (cdr action))) - (list* 'boundaries - (or (match-beginning 2) (match-beginning 1)) - (when (string-match "[^[:alnum:]_]" suffix) - (match-beginning 0))))))) + `(boundaries + ,(or (match-beginning 2) (match-beginning 1)) + . ,(when (string-match "[^[:alnum:]_]" suffix) + (match-beginning 0))))))) (t (if (eq (aref string (1- beg)) ?{) (setq table (apply-partially 'completion-table-with-terminator @@ -2074,14 +2074,14 @@ same as `substitute-in-file-name'." ((eq (car-safe action) 'boundaries) (let ((start (length (file-name-directory string))) (end (string-match-p "/" (cdr action)))) - (list* 'boundaries - ;; if `string' is "C:" in w32, (file-name-directory string) - ;; returns "C:/", so `start' is 3 rather than 2. - ;; Not quite sure what is The Right Fix, but clipping it - ;; back to 2 will work for this particular case. We'll - ;; see if we can come up with a better fix when we bump - ;; into more such problematic cases. - (min start (length string)) end))) + `(boundaries + ;; if `string' is "C:" in w32, (file-name-directory string) + ;; returns "C:/", so `start' is 3 rather than 2. + ;; Not quite sure what is The Right Fix, but clipping it + ;; back to 2 will work for this particular case. We'll + ;; see if we can come up with a better fix when we bump + ;; into more such problematic cases. + ,(min start (length string)) . ,end))) ((eq action 'lambda) (if (zerop (length string)) @@ -2663,7 +2663,7 @@ or a symbol, see `completion-pcm--merge-completions'." (setq p0 (1+ p))) (push 'any pattern) (setq p0 p)) - (incf p)) + (cl-incf p)) ;; An empty string might be erroneously added at the beginning. ;; It should be avoided properly, but it's so easy to remove it here. @@ -2688,7 +2688,7 @@ or a symbol, see `completion-pcm--merge-completions'." (defun completion-pcm--all-completions (prefix pattern table pred) "Find all completions for PATTERN in TABLE obeying PRED. PATTERN is as returned by `completion-pcm--string->pattern'." - ;; (assert (= (car (completion-boundaries prefix table pred "")) + ;; (cl-assert (= (car (completion-boundaries prefix table pred "")) ;; (length prefix))) ;; Find an initial list of possible completions. (if (completion-pcm--pattern-trivial-p pattern) @@ -2762,9 +2762,9 @@ filter out additional entries (because TABLE might not obey PRED)." ;; The prefix has no completions at all, so we should try and fix ;; that first. (let ((substring (substring prefix 0 -1))) - (destructuring-bind (subpat suball subprefix _subsuffix) - (completion-pcm--find-all-completions - substring table pred (length substring) filter) + (pcase-let ((`(,subpat ,suball ,subprefix ,_subsuffix) + (completion-pcm--find-all-completions + substring table pred (length substring) filter))) (let ((sep (aref prefix (1- (length prefix)))) ;; Text that goes between the new submatches and the ;; completion substring. @@ -2828,8 +2828,8 @@ filter out additional entries (because TABLE might not obey PRED)." (list pattern all prefix suffix))))) (defun completion-pcm-all-completions (string table pred point) - (destructuring-bind (pattern all &optional prefix _suffix) - (completion-pcm--find-all-completions string table pred point) + (pcase-let ((`(,pattern ,all ,prefix ,_suffix) + (completion-pcm--find-all-completions string table pred point))) (when all (nconc (completion-pcm--hilit-commonality pattern all) (length prefix))))) @@ -2928,7 +2928,7 @@ the same set of elements." ;; `any' it could lead to a merged completion that ;; doesn't itself match the candidates. (let ((suffix (completion--common-suffix comps))) - (assert (stringp suffix)) + (cl-assert (stringp suffix)) (unless (equal suffix "") (push suffix res))))) (setq fixed ""))))) @@ -2992,11 +2992,11 @@ the same set of elements." (cons (concat prefix merged suffix) (+ newpos (length prefix))))))) (defun completion-pcm-try-completion (string table pred point) - (destructuring-bind (pattern all prefix suffix) - (completion-pcm--find-all-completions - string table pred point - (if minibuffer-completing-file-name - 'completion-pcm--filename-try-filter)) + (pcase-let ((`(,pattern ,all ,prefix ,suffix) + (completion-pcm--find-all-completions + string table pred point + (if minibuffer-completing-file-name + 'completion-pcm--filename-try-filter)))) (completion-pcm--merge-try pattern all prefix suffix))) ;;; Substring completion @@ -3017,15 +3017,17 @@ the same set of elements." (list all pattern prefix suffix (car bounds)))) (defun completion-substring-try-completion (string table pred point) - (destructuring-bind (all pattern prefix suffix _carbounds) - (completion-substring--all-completions string table pred point) + (pcase-let ((`(,all ,pattern ,prefix ,suffix ,_carbounds) + (completion-substring--all-completions + string table pred point))) (if minibuffer-completing-file-name (setq all (completion-pcm--filename-try-filter all))) (completion-pcm--merge-try pattern all prefix suffix))) (defun completion-substring-all-completions (string table pred point) - (destructuring-bind (all pattern prefix _suffix _carbounds) - (completion-substring--all-completions string table pred point) + (pcase-let ((`(,all ,pattern ,prefix ,_suffix ,_carbounds) + (completion-substring--all-completions + string table pred point))) (when all (nconc (completion-pcm--hilit-commonality pattern all) (length prefix))))) diff --git a/lisp/mpc.el b/lisp/mpc.el index a908e4bedac..ff5ce801c63 100644 --- a/lisp/mpc.el +++ b/lisp/mpc.el @@ -92,7 +92,7 @@ ;; UI-commands : mpc- ;; internal : mpc-- -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defgroup mpc () "Client for the Music Player Daemon (mpd)." @@ -292,7 +292,7 @@ and HOST defaults to localhost." (defconst mpc--proc-alist-to-alists-starters '(file directory)) (defun mpc--proc-alist-to-alists (alist) - (assert (or (null alist) + (cl-assert (or (null alist) (memq (caar alist) mpc--proc-alist-to-alists-starters))) (let ((starter (caar alist)) (alists ()) @@ -457,7 +457,7 @@ to call FUN for any change whatsoever.") (let ((old-status mpc-status)) ;; Update the alist. (setq mpc-status (mpc-proc-buf-to-alist)) - (assert mpc-status) + (cl-assert mpc-status) (unless (equal old-status mpc-status) ;; Run the relevant refresher functions. (dolist (pair mpc-status-callbacks) @@ -544,7 +544,7 @@ Any call to `mpc-status-refresh' may cause it to be restarted." ;; (defun mpc--queue-pop () ;; (when mpc-queue ;Can be nil if out of sync. ;; (let ((song (car mpc-queue))) -;; (assert song) +;; (cl-assert song) ;; (push (if (and (consp song) (cddr song)) ;; ;; The queue's first element is itself a list of ;; ;; songs, where the first element isn't itself a song @@ -553,7 +553,7 @@ Any call to `mpc-status-refresh' may cause it to be restarted." ;; (prog1 (if (consp song) (cadr song) song) ;; (setq mpc-queue (cdr mpc-queue)))) ;; mpc-queue-back) -;; (assert (stringp (car mpc-queue-back)))))) +;; (cl-assert (stringp (car mpc-queue-back)))))) ;; (defun mpc--queue-refresh () ;; ;; Maintain the queue. @@ -611,7 +611,7 @@ The songs are returned as alists." (i 0)) (mapcar (lambda (s) (prog1 (cons (cons 'Pos (number-to-string i)) s) - (incf i))) + (cl-incf i))) l))) ((eq tag 'Search) (mpc-proc-buf-to-alists @@ -827,8 +827,8 @@ If PLAYLIST is t or nil or missing, use the main playlist." (list "move" song-pos dest-pos)) (if (< song-pos dest-pos) ;; This move has shifted dest-pos by 1. - (decf dest-pos)) - (incf i))) + (cl-decf dest-pos)) + (cl-incf i))) ;; Sort them from last to first, so the renumbering ;; caused by the earlier deletions affect ;; later ones a bit less. @@ -972,8 +972,8 @@ If PLAYLIST is t or nil or missing, use the main playlist." (right-align (match-end 1)) (text (if (eq info 'self) (symbol-name tag) - (case tag - ((Time Duration) + (pcase tag + ((or `Time `Duration) (let ((time (cdr (or (assq 'time info) (assq 'Time info))))) (setq pred (list nil)) ;Just assume it's never eq. (when time @@ -981,7 +981,7 @@ If PLAYLIST is t or nil or missing, use the main playlist." (string-match ":" time)) (substring time (match-end 0)) time))))) - (Cover + (`Cover (let* ((dir (file-name-directory (cdr (assq 'file info)))) (cover (concat dir "cover.jpg")) (file (condition-case err @@ -1004,7 +1004,7 @@ If PLAYLIST is t or nil or missing, use the main playlist." (mpc-tempfiles-add image tempfile))) (setq size nil) (propertize dir 'display image)))) - (t (let ((val (cdr (assq tag info)))) + (_ (let ((val (cdr (assq tag info)))) ;; For Streaming URLs, there's no other info ;; than the URL in `file'. Pretend it's in `Title'. (when (and (null val) (eq tag 'Title)) @@ -1222,7 +1222,7 @@ If PLAYLIST is t or nil or missing, use the main playlist." (beginning-of-line)) (defun mpc-select-make-overlay () - (assert (not (get-char-property (point) 'mpc-select))) + (cl-assert (not (get-char-property (point) 'mpc-select))) (let ((ol (make-overlay (line-beginning-position) (line-beginning-position 2)))) (overlay-put ol 'mpc-select t) @@ -1258,7 +1258,7 @@ If PLAYLIST is t or nil or missing, use the main playlist." (> (overlay-end ol) (point))) (delete-overlay ol) (push ol ols))) - (assert (= (1+ (length ols)) (length mpc-select))) + (cl-assert (= (1+ (length ols)) (length mpc-select))) (setq mpc-select ols))) ;; We're trying to select *ALL* additionally to others. ((mpc-tagbrowser-all-p) nil) @@ -1286,12 +1286,12 @@ If PLAYLIST is t or nil or missing, use the main playlist." (while (and (zerop (forward-line 1)) (get-char-property (point) 'mpc-select)) (setq end (1+ (point))) - (incf after)) + (cl-incf after)) (goto-char mid) (while (and (zerop (forward-line -1)) (get-char-property (point) 'mpc-select)) (setq start (point)) - (incf before)) + (cl-incf before)) (if (and (= after 0) (= before 0)) ;; Shortening an already minimum-size region: do nothing. nil @@ -1315,13 +1315,13 @@ If PLAYLIST is t or nil or missing, use the main playlist." (start (line-beginning-position))) (while (and (zerop (forward-line 1)) (not (get-char-property (point) 'mpc-select))) - (incf count)) + (cl-incf count)) (unless (get-char-property (point) 'mpc-select) (setq count nil)) (goto-char start) (while (and (zerop (forward-line -1)) (not (get-char-property (point) 'mpc-select))) - (incf before)) + (cl-incf before)) (unless (get-char-property (point) 'mpc-select) (setq before nil)) (when (and before (or (null count) (< before count))) @@ -1430,7 +1430,7 @@ when constructing the set of constraints." (mpc-select-save (widen) (goto-char (point-min)) - (assert (looking-at (regexp-quote mpc-tagbrowser-all-name))) + (cl-assert (looking-at (regexp-quote mpc-tagbrowser-all-name))) (forward-line 1) (let ((inhibit-read-only t)) (delete-region (point) (point-max)) @@ -1916,7 +1916,7 @@ This is used so that they can be compared with `eq', which is needed for (cdr (assq 'file song1)) (cdr (assq 'file song2))))) (and (integerp cmp) (< cmp 0))))))) - (incf totaltime (string-to-number (or (cdr (assq 'Time song)) "0"))) + (cl-incf totaltime (string-to-number (or (cdr (assq 'Time song)) "0"))) (mpc-format mpc-songs-format song) (delete-char (- (skip-chars-backward " "))) ;Remove trailing space. (insert "\n") @@ -2040,7 +2040,7 @@ This is used so that they can be compared with `eq', which is needed for (- (point) (car prev))) next prev) (or next prev))))) - (assert sn) + (cl-assert sn) (mpc-proc-cmd (concat "play " sn)))))))))) (define-derived-mode mpc-songs-mode mpc-mode "MPC-song" @@ -2155,12 +2155,12 @@ This is used so that they can be compared with `eq', which is needed for (dolist (song (car context)) (and (zerop (forward-line -1)) (eq (get-text-property (point) 'mpc-file) song) - (incf count))) + (cl-incf count))) (goto-char pos) (dolist (song (cdr context)) (and (zerop (forward-line 1)) (eq (get-text-property (point) 'mpc-file) song) - (incf count))) + (cl-incf count))) count)) (defun mpc-songpointer-refresh-hairy () @@ -2201,13 +2201,13 @@ This is used so that they can be compared with `eq', which is needed for ((< score context-size) nil) (t ;; Score is equal and increasing context might help: try it. - (incf context-size) + (cl-incf context-size) (let ((new-context (mpc-songpointer-context context-size plbuf))) (if (null new-context) ;; There isn't more context: choose one arbitrarily ;; and keep looking for a better match elsewhere. - (decf context-size) + (cl-decf context-size) (setq context new-context) (setq score (mpc-songpointer-score context pos)) (save-excursion diff --git a/lisp/msb.el b/lisp/msb.el index 760ff61a876..d9fb2c55d87 100644 --- a/lisp/msb.el +++ b/lisp/msb.el @@ -77,13 +77,13 @@ ;; hacked on by Dave Love. ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) -;;; -;;; Some example constants to be used for `msb-menu-cond'. See that -;;; variable for more information. Please note that if the condition -;;; returns `multi', then the buffer can appear in several menus. -;;; +;; +;; Some example constants to be used for `msb-menu-cond'. See that +;; variable for more information. Please note that if the condition +;; returns `multi', then the buffer can appear in several menus. +;; (defconst msb--few-menus '(((and (boundp 'server-buffer-clients) server-buffer-clients @@ -702,18 +702,18 @@ See `msb-menu-cond' for a description of its elements." (multi-flag nil) function-info-list) (setq function-info-list - (loop for fi - across function-info-vector - if (and (setq result - (eval (aref fi 1))) ;Test CONDITION - (not (and (eq result 'no-multi) - multi-flag)) - (progn (when (eq result 'multi) - (setq multi-flag t)) - t)) - collect fi - until (and result - (not (eq result 'multi))))) + (cl-loop for fi + across function-info-vector + if (and (setq result + (eval (aref fi 1))) ;Test CONDITION + (not (and (eq result 'no-multi) + multi-flag)) + (progn (when (eq result 'multi) + (setq multi-flag t)) + t)) + collect fi + until (and result + (not (eq result 'multi))))) (when (and (not function-info-list) (not result)) (error "No catch-all in msb-menu-cond!")) @@ -817,7 +817,7 @@ results in (defun msb--mode-menu-cond () (let ((key msb-modes-key)) (mapcar (lambda (item) - (incf key) + (cl-incf key) (list `( eq major-mode (quote ,(car item))) key (concat (cdr item) " (%d)"))) @@ -841,18 +841,18 @@ It takes the form ((TITLE . BUFFER-LIST)...)." (> msb-display-most-recently-used 0)) (let* ((buffers (cdr (buffer-list))) (most-recently-used - (loop with n = 0 - for buffer in buffers - if (with-current-buffer buffer - (and (not (msb-invisible-buffer-p)) - (not (eq major-mode 'dired-mode)))) - collect (with-current-buffer buffer - (cons (funcall msb-item-handling-function - buffer - max-buffer-name-length) - buffer)) - and do (incf n) - until (>= n msb-display-most-recently-used)))) + (cl-loop with n = 0 + for buffer in buffers + if (with-current-buffer buffer + (and (not (msb-invisible-buffer-p)) + (not (eq major-mode 'dired-mode)))) + collect (with-current-buffer buffer + (cons (funcall msb-item-handling-function + buffer + max-buffer-name-length) + buffer)) + and do (cl-incf n) + until (>= n msb-display-most-recently-used)))) (cons (if (stringp msb-most-recently-used-title) (format msb-most-recently-used-title (length most-recently-used)) @@ -899,29 +899,29 @@ It takes the form ((TITLE . BUFFER-LIST)...)." (when file-buffers (setq file-buffers (mapcar (lambda (buffer-list) - (list* msb-files-by-directory-sort-key - (car buffer-list) - (sort - (mapcar (lambda (buffer) - (cons (with-current-buffer buffer - (funcall - msb-item-handling-function - buffer - max-buffer-name-length)) - buffer)) - (cdr buffer-list)) - (lambda (item1 item2) - (string< (car item1) (car item2)))))) + `(,msb-files-by-directory-sort-key + ,(car buffer-list) + ,@(sort + (mapcar (lambda (buffer) + (cons (with-current-buffer buffer + (funcall + msb-item-handling-function + buffer + max-buffer-name-length)) + buffer)) + (cdr buffer-list)) + (lambda (item1 item2) + (string< (car item1) (car item2)))))) (msb--choose-file-menu file-buffers)))) ;; Now make the menu - a list of (TITLE . BUFFER-LIST) (let* (menu (most-recently-used (msb--most-recently-used-menu max-buffer-name-length)) (others (nconc file-buffers - (loop for elt - across function-info-vector - for value = (msb--create-sort-item elt) - if value collect value)))) + (cl-loop for elt + across function-info-vector + for value = (msb--create-sort-item elt) + if value collect value)))) (setq menu (mapcar 'cdr ;Remove the SORT-KEY ;; Sort the menus - not the items. @@ -1039,7 +1039,7 @@ variable `msb-menu-cond'." (tmp-list nil)) (while (< count msb-max-menu-items) (push (pop list) tmp-list) - (incf count)) + (cl-incf count)) (setq tmp-list (nreverse tmp-list)) (setq sub-name (concat (car (car tmp-list)) "...")) (push (nconc (list mcount sub-name @@ -1076,7 +1076,7 @@ variable `msb-menu-cond'." (cons (buffer-name (cdr item)) (cons (car item) end))) (cdr sub-menu)))) - (nconc (list (incf mcount) (car sub-menu) + (nconc (list (cl-incf mcount) (car sub-menu) 'keymap (car sub-menu)) (msb--split-menus buffers)))))) raw-menu))) diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 7d6dcf37a01..d0200f4cb9d 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -45,8 +45,7 @@ (defvar dbus-registered-objects-table) ;; Pacify byte compiler. -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'xml) @@ -494,20 +493,20 @@ placed in the queue. (dolist (flag flags) (setq arg (+ arg - (case flag + (pcase flag (:allow-replacement 1) (:replace-existing 2) (:do-not-queue 4) - (t (signal 'wrong-type-argument (list flag))))))) + (_ (signal 'wrong-type-argument (list flag))))))) (setq reply (dbus-call-method bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "RequestName" service arg)) - (case reply + (pcase reply (1 :primary-owner) (2 :in-queue) (3 :exists) (4 :already-owner) - (t (signal 'dbus-error (list "Could not register service" service)))))) + (_ (signal 'dbus-error (list "Could not register service" service)))))) (defun dbus-unregister-service (bus service) "Unregister all objects related to SERVICE from D-Bus BUS. @@ -536,11 +535,11 @@ queue of this service." (let ((reply (dbus-call-method bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "ReleaseName" service))) - (case reply + (pcase reply (1 :released) (2 :non-existent) (3 :not-owner) - (t (signal 'dbus-error (list "Could not unregister service" service)))))) + (_ (signal 'dbus-error (list "Could not unregister service" service)))))) (defun dbus-register-signal (bus service path interface signal handler &rest args) @@ -803,7 +802,7 @@ association to the service from D-Bus." ;; Service. (string-equal service (cadr e)) ;; Non-empty object path. - (caddr e) + (cl-caddr e) (throw :found t))))) dbus-registered-objects-table) nil)))) @@ -1383,7 +1382,7 @@ name of the property, and its value. If there are no properties, bus service path dbus-interface-properties "GetAll" :timeout 500 interface) result) - (add-to-list 'result (cons (car dict) (caadr dict)) 'append))))) + (add-to-list 'result (cons (car dict) (cl-caadr dict)) 'append))))) (defun dbus-register-property (bus service path interface property access value @@ -1581,7 +1580,7 @@ and \"org.freedesktop.DBus.Properties.GetAll\", which is slow." (if (cadr entry2) ;; "sv". (dolist (entry3 (cadr entry2)) - (setcdr entry3 (caadr entry3))) + (setcdr entry3 (cl-caadr entry3))) (setcdr entry2 nil))))) ;; Fallback: collect the information. Slooow! diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el index a306384c775..d33480afb28 100644 --- a/lisp/net/gnutls.el +++ b/lisp/net/gnutls.el @@ -35,7 +35,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defgroup gnutls nil "Emacs interface to the GnuTLS library." @@ -120,7 +120,7 @@ trust and key files, and priority string." (declare-function gnutls-boot "gnutls.c" (proc type proplist)) (declare-function gnutls-errorp "gnutls.c" (error)) -(defun* gnutls-negotiate +(cl-defun gnutls-negotiate (&rest spec &key process type hostname priority-string trustfiles crlfiles keylist min-prime-bits diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el index c9961a67f3d..b71bfb202db 100644 --- a/lisp/pcomplete.el +++ b/lisp/pcomplete.el @@ -118,7 +118,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'comint) (defgroup pcomplete nil @@ -875,9 +874,9 @@ component, `default-directory' is used as the basis for completion." ;; The env-var is "out of bounds". (if (eq action t) (complete-with-action action table newstring pred) - (list* 'boundaries - (+ (car bounds) (- orig-length (length newstring))) - (cdr bounds))) + `(boundaries + ,(+ (car bounds) (- orig-length (length newstring))) + . ,(cdr bounds))) ;; The env-var is in the file bounds. (if (eq action t) (let ((comps (complete-with-action @@ -886,9 +885,9 @@ component, `default-directory' is used as the basis for completion." ;; Strip the part of each completion that's actually ;; coming from the env-var. (mapcar (lambda (s) (substring s len)) comps)) - (list* 'boundaries - (+ envpos (- orig-length (length newstring))) - (cdr bounds)))))))))) + `(boundaries + ,(+ envpos (- orig-length (length newstring))) + . ,(cdr bounds)))))))))) (defsubst pcomplete-all-entries (&optional regexp predicate) "Like `pcomplete-entries', but doesn't ignore any entries." diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index a07ecfcb3a4..f42f661d86c 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -198,7 +198,7 @@ (eval-when-compile (require 'skeleton) - (require 'cl) + (require 'cl-lib) (require 'comint)) (require 'executable) @@ -987,31 +987,31 @@ subshells can nest." (while (and state (progn (skip-chars-forward "^'\\\\\"`$()" limit) (< (point) limit))) ;; unescape " inside a $( ... ) construct. - (case (char-after) - (?\' (case state - (double-quote nil) - (t (forward-char 1) (skip-chars-forward "^'" limit)))) + (pcase (char-after) + (?\' (pcase state + (`double-quote nil) + (_ (forward-char 1) (skip-chars-forward "^'" limit)))) (?\\ (forward-char 1)) - (?\" (case state - (double-quote (setq state (pop states))) - (t (push state states) (setq state 'double-quote))) + (?\" (pcase state + (`double-quote (setq state (pop states))) + (_ (push state states) (setq state 'double-quote))) (if state (put-text-property (point) (1+ (point)) 'syntax-table '(1)))) - (?\` (case state - (backquote (setq state (pop states))) - (t (push state states) (setq state 'backquote)))) + (?\` (pcase state + (`backquote (setq state (pop states))) + (_ (push state states) (setq state 'backquote)))) (?\$ (if (not (eq (char-after (1+ (point))) ?\()) nil (forward-char 1) - (case state - (t (push state states) (setq state 'code))))) - (?\( (case state - (double-quote nil) - (t (push state states) (setq state 'code)))) - (?\) (case state - (double-quote nil) - (t (setq state (pop states))))) - (t (error "Internal error in sh-font-lock-quoted-subshell"))) + (pcase state + (_ (push state states) (setq state 'code))))) + (?\( (pcase state + (`double-quote nil) + (_ (push state states) (setq state 'code)))) + (?\) (pcase state + (`double-quote nil) + (_ (setq state (pop states))))) + (_ (error "Internal error in sh-font-lock-quoted-subshell"))) (forward-char 1))))) @@ -1105,7 +1105,6 @@ subshells can nest." (save-excursion (sh-font-lock-quoted-subshell end))))))) (point) end)) - (defun sh-font-lock-syntactic-face-function (state) (let ((q (nth 3 state))) (if q @@ -1649,7 +1648,7 @@ Does not preserve point." (cond ((zerop (length prev)) (if newline - (progn (assert words) (setq res 'word)) + (progn (cl-assert words) (setq res 'word)) (setq words t) (condition-case nil (forward-sexp -1) @@ -1661,7 +1660,7 @@ Does not preserve point." ((assoc prev smie-grammar) (setq res 'word)) (t (if newline - (progn (assert words) (setq res 'word)) + (progn (cl-assert words) (setq res 'word)) (setq words t))))) (eq res 'keyword))) diff --git a/lisp/register.el b/lisp/register.el index 44f15e4a69c..21fcff2d148 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -28,7 +28,7 @@ ;; pieces of buffer state to named variables. The entry points are ;; documented in the Emacs user's manual. -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (declare-function semantic-insert-foreign-tag "semantic/tag" (foreign-tag)) (declare-function semantic-tag-buffer "semantic/tag" (tag)) @@ -52,7 +52,7 @@ ;;; Code: -(defstruct +(cl-defstruct (registerv (:constructor nil) (:constructor registerv--make (&optional data print-func jump-func insert-func)) @@ -64,7 +64,7 @@ (jump-func nil :read-only t) (insert-func nil :read-only t)) -(defun* registerv-make (data &key print-func jump-func insert-func) +(cl-defun registerv-make (data &key print-func jump-func insert-func) "Create a register value object. DATA can be any value. @@ -150,7 +150,7 @@ delete any existing frames that the frame configuration doesn't mention. (let ((val (get-register register))) (cond ((registerv-p val) - (assert (registerv-jump-func val) nil + (cl-assert (registerv-jump-func val) nil "Don't know how to jump to register %s" (single-key-description register)) (funcall (registerv-jump-func val) (registerv-data val))) @@ -325,7 +325,7 @@ Interactively, second arg is non-nil if prefix arg is supplied." (let ((val (get-register register))) (cond ((registerv-p val) - (assert (registerv-insert-func val) nil + (cl-assert (registerv-insert-func val) nil "Don't know how to insert register %s" (single-key-description register)) (funcall (registerv-insert-func val) (registerv-data val))) diff --git a/lisp/scroll-bar.el b/lisp/scroll-bar.el index c6c7d7ddb8d..0d693c52c81 100644 --- a/lisp/scroll-bar.el +++ b/lisp/scroll-bar.el @@ -29,7 +29,7 @@ ;;; Code: (require 'mouse) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;;;; Utilities. @@ -112,8 +112,9 @@ Setting the variable with a customization buffer also takes effect." ;; If it is set again, that is for real. (setq scroll-bar-mode-explicit t) -(defun get-scroll-bar-mode () scroll-bar-mode) -(defsetf get-scroll-bar-mode set-scroll-bar-mode) +(defun get-scroll-bar-mode () + (declare (gv-setter set-scroll-bar-mode)) + scroll-bar-mode) (define-minor-mode scroll-bar-mode "Toggle vertical scroll bars on all frames (Scroll Bar mode). diff --git a/lisp/simple.el b/lisp/simple.el index e6b4a79b9b2..37e0b48d31d 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -28,8 +28,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) ;For define-minor-mode. - (declare-function widget-convert "wid-edit" (type &rest args)) (declare-function shell-mode "shell" ()) diff --git a/lisp/uniquify.el b/lisp/uniquify.el index 520c4b847dd..3619d499419 100644 --- a/lisp/uniquify.el +++ b/lisp/uniquify.el @@ -83,7 +83,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;;; User-visible variables @@ -174,7 +174,7 @@ contains the name of the directory which the buffer is visiting.") ;;; Utilities ;; uniquify-fix-list data structure -(defstruct (uniquify-item +(cl-defstruct (uniquify-item (:constructor nil) (:copier nil) (:constructor uniquify-make-item (base dirname buffer &optional proposed))) @@ -340,7 +340,7 @@ in `uniquify-list-buffers-directory-modes', otherwise returns nil." (defun uniquify-get-proposed-name (base dirname &optional depth) (unless depth (setq depth uniquify-min-dir-content)) - (assert (equal (directory-file-name dirname) dirname)) ;No trailing slash. + (cl-assert (equal (directory-file-name dirname) dirname)) ;No trailing slash. ;; Distinguish directories by adding extra separator. (if (and uniquify-trailing-separator-p diff --git a/lisp/vc/cvs-status.el b/lisp/vc/cvs-status.el index f803cc43441..6c6b18a605d 100644 --- a/lisp/vc/cvs-status.el +++ b/lisp/vc/cvs-status.el @@ -28,7 +28,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'pcvs-util) ;;; @@ -165,7 +165,7 @@ ;; Tagelt, tag element ;; -(defstruct (cvs-tag +(cl-defstruct (cvs-tag (:constructor nil) (:constructor cvs-tag-make (vlist &optional name type)) @@ -235,9 +235,9 @@ The tree will be printed no closer than column COLUMN." (save-excursion (or (= (forward-line 1) 0) (insert "\n")) (cvs-tree-print rest printer column)))) - (assert (>= prefix column)) + (cl-assert (>= prefix column)) (move-to-column prefix t) - (assert (eolp)) + (cl-assert (eolp)) (insert (cvs-car name)) (dolist (br (cvs-cdr rev)) (let* ((column (current-column)) @@ -258,7 +258,7 @@ The tree will be printed no closer than column COLUMN." (defun cvs-tree-merge (tree1 tree2) "Merge tags trees TREE1 and TREE2 into one. BEWARE: because of stability issues, this is not a symmetric operation." - (assert (and (listp tree1) (listp tree2))) + (cl-assert (and (listp tree1) (listp tree2))) (cond ((null tree1) tree2) ((null tree2) tree1) @@ -273,10 +273,10 @@ BEWARE: because of stability issues, this is not a symmetric operation." (l2 (length vl2))) (cond ((= l1 l2) - (case (cvs-tag-compare tag1 tag2) - (more1 (list* rev2 (cvs-tree-merge tree1 (cdr tree2)))) - (more2 (list* rev1 (cvs-tree-merge (cdr tree1) tree2))) - (equal + (pcase (cvs-tag-compare tag1 tag2) + (`more1 (cons rev2 (cvs-tree-merge tree1 (cdr tree2)))) + (`more2 (cons rev1 (cvs-tree-merge (cdr tree1) tree2))) + (`equal (cons (cons (cvs-tag-merge tag1 tag2) (cvs-tree-merge (cvs-cdr rev1) (cvs-cdr rev2))) (cvs-tree-merge (cdr tree1) (cdr tree2)))))) @@ -399,35 +399,35 @@ the list is a three-string list TAG, KIND, REV." Otherwise, default to ASCII chars like +, - and |.") (defconst cvs-tree-char-space - (case cvs-tree-use-charset - (jisx0208 (make-char 'japanese-jisx0208 33 33)) - (unicode " ") - (t " "))) + (pcase cvs-tree-use-charset + (`jisx0208 (make-char 'japanese-jisx0208 33 33)) + (`unicode " ") + (_ " "))) (defconst cvs-tree-char-hbar - (case cvs-tree-use-charset - (jisx0208 (make-char 'japanese-jisx0208 40 44)) - (unicode "━") - (t "--"))) + (pcase cvs-tree-use-charset + (`jisx0208 (make-char 'japanese-jisx0208 40 44)) + (`unicode "━") + (_ "--"))) (defconst cvs-tree-char-vbar - (case cvs-tree-use-charset - (jisx0208 (make-char 'japanese-jisx0208 40 45)) - (unicode "┃") - (t "| "))) + (pcase cvs-tree-use-charset + (`jisx0208 (make-char 'japanese-jisx0208 40 45)) + (`unicode "┃") + (_ "| "))) (defconst cvs-tree-char-branch - (case cvs-tree-use-charset - (jisx0208 (make-char 'japanese-jisx0208 40 50)) - (unicode "┣") - (t "+-"))) + (pcase cvs-tree-use-charset + (`jisx0208 (make-char 'japanese-jisx0208 40 50)) + (`unicode "┣") + (_ "+-"))) (defconst cvs-tree-char-eob ;end of branch - (case cvs-tree-use-charset - (jisx0208 (make-char 'japanese-jisx0208 40 49)) - (unicode "┗") - (t "`-"))) + (pcase cvs-tree-use-charset + (`jisx0208 (make-char 'japanese-jisx0208 40 49)) + (`unicode "┗") + (_ "`-"))) (defconst cvs-tree-char-bob ;beginning of branch - (case cvs-tree-use-charset - (jisx0208 (make-char 'japanese-jisx0208 40 51)) - (unicode "┳") - (t "+-"))) + (pcase cvs-tree-use-charset + (`jisx0208 (make-char 'japanese-jisx0208 40 51)) + (`unicode "┳") + (_ "+-"))) (defun cvs-tag-lessp (tag1 tag2) (eq (cvs-tag-compare tag1 tag2) 'more2)) @@ -485,9 +485,9 @@ Optional prefix ARG chooses between two representations." (pe t) ;"prev equal" (nas nil)) ;"next afters" to be returned (insert " ") - (do* ((vs vlist (cdr vs)) - (ps prev (cdr ps)) - (as after (cdr as))) + (cl-do* ((vs vlist (cdr vs)) + (ps prev (cdr ps)) + (as after (cdr as))) ((and (null as) (null vs) (null ps)) (let ((revname (cvs-status-vl-to-str vlist))) (if (cvs-every 'identity (cvs-map 'equal prev vlist)) diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 9034ffe520f..a9d124700b8 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -53,7 +53,7 @@ ;; - Handle `diff -b' output in context->unified. ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defvar add-log-buffer-file-name-function) @@ -493,14 +493,15 @@ See http://lists.gnu.org/archive/html/emacs-devel/2007-11/msg01990.html") ;; We may have a first evaluation of `end' thanks to the hunk header. (unless end (setq end (and (re-search-forward - (case style - (unified (concat (if diff-valid-unified-empty-line - "^[^-+# \\\n]\\|" "^[^-+# \\]\\|") - ;; A `unified' header is ambiguous. - diff-file-header-re)) - (context "^[^-+#! \\]") - (normal "^[^<>#\\]") - (t "^[^-+#!<> \\]")) + (pcase style + (`unified + (concat (if diff-valid-unified-empty-line + "^[^-+# \\\n]\\|" "^[^-+# \\]\\|") + ;; A `unified' header is ambiguous. + diff-file-header-re)) + (`context "^[^-+#! \\]") + (`normal "^[^<>#\\]") + (_ "^[^-+#!<> \\]")) nil t) (match-beginning 0))) (when diff-valid-unified-empty-line @@ -710,7 +711,7 @@ data such as \"Index: ...\" and such." (save-excursion (let ((n 0)) (goto-char start) - (while (re-search-forward re end t) (incf n)) + (while (re-search-forward re end t) (cl-incf n)) n))) (defun diff-splittable-p () @@ -834,16 +835,16 @@ PREFIX is only used internally: don't use it." ;; use any previously used preference (cdr (assoc fs diff-remembered-files-alist)) ;; try to be clever and use previous choices as an inspiration - (dolist (rf diff-remembered-files-alist) + (cl-dolist (rf diff-remembered-files-alist) (let ((newfile (diff-merge-strings (caar rf) (car fs) (cdr rf)))) - (if (and newfile (file-exists-p newfile)) (return newfile)))) + (if (and newfile (file-exists-p newfile)) (cl-return newfile)))) ;; look for each file in turn. If none found, try again but ;; ignoring the first level of directory, ... - (do* ((files fs (delq nil (mapcar 'diff-filename-drop-dir files))) - (file nil nil)) + (cl-do* ((files fs (delq nil (mapcar 'diff-filename-drop-dir files))) + (file nil nil)) ((or (null files) - (setq file (do* ((files files (cdr files)) - (file (car files) (car files))) + (setq file (cl-do* ((files files (cdr files)) + (file (car files) (car files))) ;; Use file-regular-p to avoid ;; /dev/null, directories, etc. ((or (null file) (file-regular-p file)) @@ -862,7 +863,7 @@ PREFIX is only used internally: don't use it." (diff-find-file-name old noprompt (match-string 1))) ;; if all else fails, ask the user (unless noprompt - (let ((file (expand-file-name (or (first fs) "")))) + (let ((file (expand-file-name (or (car fs) "")))) (setq file (read-file-name (format "Use file %s: " file) (file-name-directory file) file t @@ -940,21 +941,23 @@ else cover the whole buffer." (let ((modif nil) last-pt) (while (progn (setq last-pt (point)) (= (forward-line -1) 0)) - (case (char-after) + (pcase (char-after) (?\s (insert " ") (setq modif nil) (backward-char 1)) (?+ (delete-region (point) last-pt) (setq modif t)) (?- (if (not modif) - (progn (forward-char 1) - (insert " ")) - (delete-char 1) - (insert "! ")) - (backward-char 2)) + (progn (forward-char 1) + (insert " ")) + (delete-char 1) + (insert "! ")) + (backward-char 2)) (?\\ (when (save-excursion (forward-line -1) - (= (char-after) ?+)) - (delete-region (point) last-pt) (setq modif t))) + (= (char-after) ?+)) + (delete-region (point) last-pt) + (setq modif t))) ;; diff-valid-unified-empty-line. - (?\n (insert " ") (setq modif nil) (backward-char 2)) - (t (setq modif nil)))))) + (?\n (insert " ") (setq modif nil) + (backward-char 2)) + (_ (setq modif nil)))))) (goto-char (point-max)) (save-excursion (insert "--- " line2 "," @@ -967,7 +970,8 @@ else cover the whole buffer." (if (not (save-excursion (re-search-forward "^+" nil t))) (delete-region (point) (point-max)) (let ((modif nil) (delete nil)) - (if (save-excursion (re-search-forward "^\\+.*\n-" nil t)) + (if (save-excursion (re-search-forward "^\\+.*\n-" + nil t)) ;; Normally, lines in a substitution come with ;; first the removals and then the additions, and ;; the context->unified function follows this @@ -976,22 +980,22 @@ else cover the whole buffer." ;; context->unified as an undo command. (setq reversible nil)) (while (not (eobp)) - (case (char-after) + (pcase (char-after) (?\s (insert " ") (setq modif nil) (backward-char 1)) (?- (setq delete t) (setq modif t)) (?+ (if (not modif) - (progn (forward-char 1) - (insert " ")) - (delete-char 1) - (insert "! ")) - (backward-char 2)) + (progn (forward-char 1) + (insert " ")) + (delete-char 1) + (insert "! ")) + (backward-char 2)) (?\\ (when (save-excursion (forward-line 1) - (not (eobp))) - (setq delete t) (setq modif t))) + (not (eobp))) + (setq delete t) (setq modif t))) ;; diff-valid-unified-empty-line. (?\n (insert " ") (setq modif nil) (backward-char 2) (setq reversible nil)) - (t (setq modif nil))) + (_ (setq modif nil))) (let ((last-pt (point))) (forward-line 1) (when delete @@ -1051,17 +1055,18 @@ With a prefix argument, convert unified format to context format." (goto-char pt1) (forward-line 1) (while (< (point) pt2) - (case (char-after) + (pcase (char-after) (?! (delete-char 2) (insert "-") (forward-line 1)) (?- (forward-char 1) (delete-char 1) (forward-line 1)) - (?\s ;merge with the other half of the chunk + (?\s ;merge with the other half of the chunk (let* ((endline2 (save-excursion (goto-char pt2) (forward-line 1) (point)))) - (case (char-after pt2) - ((?! ?+) + (pcase (char-after pt2) + ((or ?! ?+) (insert "+" - (prog1 (buffer-substring (+ pt2 2) endline2) + (prog1 + (buffer-substring (+ pt2 2) endline2) (delete-region pt2 endline2)))) (?\s (unless (= (- endline2 pt2) @@ -1075,9 +1080,9 @@ With a prefix argument, convert unified format to context format." (delete-char 1) (forward-line 1)) (?\\ (forward-line 1)) - (t (setq reversible nil) + (_ (setq reversible nil) (delete-char 1) (forward-line 1))))) - (t (setq reversible nil) (forward-line 1)))) + (_ (setq reversible nil) (forward-line 1)))) (while (looking-at "[+! ] ") (if (/= (char-after) ?!) (forward-char 1) (delete-char 1) (insert "+")) @@ -1155,13 +1160,13 @@ else cover the whole buffer." (replace-match "@@ -\\8 +\\7 @@" nil) (forward-line 1) (let ((c (char-after)) first last) - (while (case (setq c (char-after)) + (while (pcase (setq c (char-after)) (?- (setq first (or first (point))) - (delete-char 1) (insert "+") t) + (delete-char 1) (insert "+") t) (?+ (setq last (or last (point))) - (delete-char 1) (insert "-") t) - ((?\\ ?#) t) - (t (when (and first last (< first last)) + (delete-char 1) (insert "-") t) + ((or ?\\ ?#) t) + (_ (when (and first last (< first last)) (insert (delete-and-extract-region first last))) (setq first nil last nil) (memq c (if diff-valid-unified-empty-line @@ -1184,13 +1189,13 @@ else cover the whole buffer." (concat diff-hunk-header-re-unified "\\|[-*][-*][-*] [0-9,]+ [-*][-*][-*][-*]$" "\\|--- .+\n\\+\\+\\+ "))) - (case (char-after) - (?\s (incf space)) - (?+ (incf plus)) - (?- (incf minus)) - (?! (incf bang)) - ((?\\ ?#) nil) - (t (setq space 0 plus 0 minus 0 bang 0))) + (pcase (char-after) + (?\s (cl-incf space)) + (?+ (cl-incf plus)) + (?- (cl-incf minus)) + (?! (cl-incf bang)) + ((or ?\\ ?#) nil) + (_ (setq space 0 plus 0 minus 0 bang 0))) (cond ((looking-at diff-hunk-header-re-unified) (let* ((old1 (match-string 2)) @@ -1432,7 +1437,7 @@ Only works for unified diffs." (cond ((and (memq (char-after) '(?\s ?! ?+ ?-)) (memq (char-after (1+ (point))) '(?\s ?\t))) - (decf count) t) + (cl-decf count) t) ((or (zerop count) (= count lines)) nil) ((memq (char-after) '(?! ?+ ?-)) (if (not (and (eq (char-after (1+ (point))) ?\n) @@ -1483,8 +1488,8 @@ Only works for unified diffs." (after (string-to-number (or (match-string 4) "1")))) (forward-line) (while - (case (char-after) - (?\s (decf before) (decf after) t) + (pcase (char-after) + (?\s (cl-decf before) (cl-decf after) t) (?- (if (and (looking-at diff-file-header-re) (zerop before) (zerop after)) @@ -1494,15 +1499,15 @@ Only works for unified diffs." ;; line so that our code which doesn't count lines ;; will not get confused. (progn (save-excursion (insert "\n")) nil) - (decf before) t)) - (?+ (decf after) t) - (t + (cl-decf before) t)) + (?+ (cl-decf after) t) + (_ (cond ((and diff-valid-unified-empty-line ;; Not just (eolp) so we don't infloop at eob. (eq (char-after) ?\n) (> before 0) (> after 0)) - (decf before) (decf after) t) + (cl-decf before) (cl-decf after) t) ((and (zerop before) (zerop after)) nil) ((or (< before 0) (< after 0)) (error (if (or (zerop before) (zerop after)) @@ -1719,16 +1724,17 @@ the value of this variable when given an appropriate prefix argument). With a prefix argument, REVERSE the hunk." (interactive "P") - (destructuring-bind (buf line-offset pos old new &optional switched) - ;; Sometimes we'd like to have the following behavior: if REVERSE go - ;; to the new file, otherwise go to the old. But that means that by - ;; default we use the old file, which is the opposite of the default - ;; for diff-goto-source, and is thus confusing. Also when you don't - ;; know about it it's pretty surprising. - ;; TODO: make it possible to ask explicitly for this behavior. - ;; - ;; This is duplicated in diff-test-hunk. - (diff-find-source-location nil reverse) + (pcase-let ((`(,buf ,line-offset ,pos ,old ,new ,switched) + ;; Sometimes we'd like to have the following behavior: if + ;; REVERSE go to the new file, otherwise go to the old. + ;; But that means that by default we use the old file, which is + ;; the opposite of the default for diff-goto-source, and is thus + ;; confusing. Also when you don't know about it it's + ;; pretty surprising. + ;; TODO: make it possible to ask explicitly for this behavior. + ;; + ;; This is duplicated in diff-test-hunk. + (diff-find-source-location nil reverse))) (cond ((null line-offset) (error "Can't find the text to patch")) @@ -1771,8 +1777,8 @@ With a prefix argument, REVERSE the hunk." "See whether it's possible to apply the current hunk. With a prefix argument, try to REVERSE the hunk." (interactive "P") - (destructuring-bind (buf line-offset pos src _dst &optional switched) - (diff-find-source-location nil reverse) + (pcase-let ((`(,buf ,line-offset ,pos ,src ,_dst ,switched) + (diff-find-source-location nil reverse))) (set-window-point (display-buffer buf) (+ (car pos) (cdr src))) (diff-hunk-status-msg line-offset (diff-xor reverse switched) t))) @@ -1791,8 +1797,8 @@ then `diff-jump-to-old-file' is also set, for the next invocations." ;; This is a convenient detail when using smerge-diff. (if event (posn-set-point (event-end event))) (let ((rev (not (save-excursion (beginning-of-line) (looking-at "[-<]"))))) - (destructuring-bind (buf line-offset pos src _dst &optional switched) - (diff-find-source-location other-file rev) + (pcase-let ((`(,buf ,line-offset ,pos ,src ,_dst ,switched) + (diff-find-source-location other-file rev))) (pop-to-buffer buf) (goto-char (+ (car pos) (cdr src))) (diff-hunk-status-msg line-offset (diff-xor rev switched) t)))) @@ -1809,10 +1815,11 @@ For use in `add-log-current-defun-function'." (when (looking-at diff-hunk-header-re) (forward-line 1) (re-search-forward "^[^ ]" nil t)) - (destructuring-bind (&optional buf _line-offset pos src dst switched) - ;; Use `noprompt' since this is used in which-func-mode and such. - (ignore-errors ;Signals errors in place of prompting. - (diff-find-source-location nil nil 'noprompt)) + (pcase-let ((`(,buf ,_line-offset ,pos ,src ,dst ,switched) + (ignore-errors ;Signals errors in place of prompting. + ;; Use `noprompt' since this is used in which-func-mode + ;; and such. + (diff-find-source-location nil nil 'noprompt)))) (when buf (beginning-of-line) (or (when (memq (char-after) '(?< ?-)) @@ -1835,7 +1842,7 @@ For use in `add-log-current-defun-function'." "Re-diff the current hunk, ignoring whitespace differences." (interactive) (let* ((char-offset (- (point) (diff-beginning-of-hunk t))) - (opts (case (char-after) (?@ "-bu") (?* "-bc") (t "-b"))) + (opts (pcase (char-after) (?@ "-bu") (?* "-bc") (_ "-b"))) (line-nb (and (or (looking-at "[^0-9]+\\([0-9]+\\)") (error "Can't find line number")) (string-to-number (match-string 1)))) @@ -1857,13 +1864,13 @@ For use in `add-log-current-defun-function'." (let ((status (call-process diff-command nil t nil opts file1 file2))) - (case status - (0 nil) ;Nothing to reformat. + (pcase status + (0 nil) ;Nothing to reformat. (1 (goto-char (point-min)) - ;; Remove the file-header. - (when (re-search-forward diff-hunk-header-re nil t) - (delete-region (point-min) (match-beginning 0)))) - (t (goto-char (point-max)) + ;; Remove the file-header. + (when (re-search-forward diff-hunk-header-re nil t) + (delete-region (point-min) (match-beginning 0)))) + (_ (goto-char (point-max)) (unless (bolp) (insert "\n")) (insert hunk))) (setq hunk (buffer-string)) @@ -1942,14 +1949,14 @@ For use in `add-log-current-defun-function'." (remove-overlays beg end 'diff-mode 'fine) (goto-char beg) - (case style - (unified + (pcase style + (`unified (while (re-search-forward "^\\(?:-.*\n\\)+\\(\\)\\(?:\\+.*\n\\)+" end t) (smerge-refine-subst (match-beginning 0) (match-end 1) (match-end 1) (match-end 0) nil 'diff-refine-preproc props-r props-a))) - (context + (`context (let* ((middle (save-excursion (re-search-forward "^---"))) (other middle)) (while (re-search-forward "^\\(?:!.*\n\\)+" middle t) @@ -1964,7 +1971,7 @@ For use in `add-log-current-defun-function'." 'diff-refine-preproc (unless diff-use-changed-face props-r) (unless diff-use-changed-face props-a))))) - (t ;; Normal diffs. + (_ ;; Normal diffs. (let ((beg1 (1+ (point)))) (when (re-search-forward "^---.*\n" end t) ;; It's a combined add&remove, so there's something to do. diff --git a/lisp/vc/diff.el b/lisp/vc/diff.el index 6cfee52cbb5..b70b6cd919c 100644 --- a/lisp/vc/diff.el +++ b/lisp/vc/diff.el @@ -32,8 +32,6 @@ (declare-function diff-setup-whitespace "diff-mode" ()) -(eval-when-compile (require 'cl)) - (defgroup diff nil "Comparing files with `diff'." :group 'tools) diff --git a/lisp/vc/log-edit.el b/lisp/vc/log-edit.el index 5ecd5c44b2e..5ae311222ba 100644 --- a/lisp/vc/log-edit.el +++ b/lisp/vc/log-edit.el @@ -29,7 +29,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'add-log) ; for all the ChangeLog goodies (require 'pcvs-util) (require 'ring) diff --git a/lisp/vc/log-view.el b/lisp/vc/log-view.el index d345a20a0f5..07526b4fba6 100644 --- a/lisp/vc/log-view.el +++ b/lisp/vc/log-view.el @@ -109,7 +109,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'pcvs-util) (autoload 'vc-find-revision "vc") (autoload 'vc-diff-internal "vc") diff --git a/lisp/vc/pcvs-defs.el b/lisp/vc/pcvs-defs.el index ab45b313bd5..0f71b7b82e7 100644 --- a/lisp/vc/pcvs-defs.el +++ b/lisp/vc/pcvs-defs.el @@ -26,7 +26,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'pcvs-util) ;;;; ------------------------------------------------------- diff --git a/lisp/vc/pcvs-info.el b/lisp/vc/pcvs-info.el index 4f8c114d721..36572640cfc 100644 --- a/lisp/vc/pcvs-info.el +++ b/lisp/vc/pcvs-info.el @@ -31,7 +31,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'pcvs-util) ;;(require 'pcvs-defs) @@ -146,7 +146,7 @@ to confuse some users sometimes." ;; Constructor: -(defstruct (cvs-fileinfo +(cl-defstruct (cvs-fileinfo (:constructor nil) (:copier nil) (:constructor -cvs-create-fileinfo (type dir file full-log @@ -274,10 +274,10 @@ to confuse some users sometimes." (string= file (file-name-nondirectory file))) (setq check 'type) (symbolp type) (setq check 'consistency) - (case type - (DIRCHANGE (and (null subtype) (string= "." file))) - ((NEED-UPDATE ADDED MISSING DEAD MODIFIED MESSAGE UP-TO-DATE - REMOVED NEED-MERGE CONFLICT UNKNOWN MESSAGE) + (pcase type + (`DIRCHANGE (and (null subtype) (string= "." file))) + ((or `NEED-UPDATE `ADDED `MISSING `DEAD `MODIFIED `MESSAGE + `UP-TO-DATE `REMOVED `NEED-MERGE `CONFLICT `UNKNOWN) t))) fi (error "Invalid :%s in cvs-fileinfo %s" check fi)))) @@ -325,9 +325,9 @@ FI-OR-TYPE can either be a symbol (a fileinfo-type) or a fileinfo." (defun cvs-add-face (str face &optional keymap &rest props) (when keymap (when (keymapp keymap) - (setq props (list* 'keymap keymap props))) - (setq props (list* 'mouse-face 'highlight props))) - (add-text-properties 0 (length str) (list* 'font-lock-face face props) str) + (setq props `(keymap ,keymap ,@props))) + (setq props `(mouse-face highlight ,@props))) + (add-text-properties 0 (length str) `(font-lock-face ,face ,@props) str) str) (defun cvs-fileinfo-pp (fileinfo) @@ -337,15 +337,15 @@ For use by the cookie package." (let ((type (cvs-fileinfo->type fileinfo)) (subtype (cvs-fileinfo->subtype fileinfo))) (insert - (case type - (DIRCHANGE (concat "In directory " - (cvs-add-face (cvs-fileinfo->full-name fileinfo) - 'cvs-header t 'cvs-goal-column t) - ":")) - (MESSAGE + (pcase type + (`DIRCHANGE (concat "In directory " + (cvs-add-face (cvs-fileinfo->full-name fileinfo) + 'cvs-header t 'cvs-goal-column t) + ":")) + (`MESSAGE (cvs-add-face (format "Message: %s" (cvs-fileinfo->full-log fileinfo)) 'cvs-msg)) - (t + (_ (let* ((status (if (cvs-fileinfo->marked fileinfo) (cvs-add-face "*" 'cvs-marked) " ")) @@ -354,10 +354,10 @@ For use by the cookie package." (base (or (cvs-fileinfo->base-rev fileinfo) "")) (head (cvs-fileinfo->head-rev fileinfo)) (type - (let ((str (case type + (let ((str (pcase type ;;(MOD-CONFLICT "Not Removed") - (DEAD "") - (t (capitalize (symbol-name type))))) + (`DEAD "") + (_ (capitalize (symbol-name type))))) (face (let ((sym (intern (concat "cvs-fi-" (downcase (symbol-name type)) diff --git a/lisp/vc/pcvs-parse.el b/lisp/vc/pcvs-parse.el index a588c735ce7..dd448b9d480 100644 --- a/lisp/vc/pcvs-parse.el +++ b/lisp/vc/pcvs-parse.el @@ -32,8 +32,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (require 'pcvs-util) (require 'pcvs-info) @@ -117,7 +115,7 @@ If RE matches, advance the point until the line after the match and then assign the variables as specified in MATCHES (via `setq')." (cons 'cvs-do-match (cons re (mapcar (lambda (match) - `(cons ',(first match) ,(second match))) + `(cons ',(car match) ,(cadr match))) matches)))) (defun cvs-do-match (re &rest matches) @@ -150,8 +148,8 @@ Match RE and if successful, execute MATCHES." (cvs-or (funcall parse-spec) - (dolist (re cvs-parse-ignored-messages) - (when (cvs-match re) (return t))) + (cl-dolist (re cvs-parse-ignored-messages) + (when (cvs-match re) (cl-return t))) ;; This is a parse error. Create a message-type fileinfo. (and @@ -221,7 +219,7 @@ The remaining KEYS are passed directly to `cvs-create-fileinfo'." ;; ?: Unknown file. (let ((code (aref c 0))) (cvs-parsed-fileinfo - (case code + (pcase code (?M 'MODIFIED) (?A 'ADDED) (?R 'REMOVED) @@ -238,7 +236,7 @@ The remaining KEYS are passed directly to `cvs-create-fileinfo'." (if (re-search-forward "^<<<<<<< " nil t) 'CONFLICT 'NEED-MERGE)))) (?J 'NEED-MERGE) ;not supported by standard CVS - ((?U ?P) + ((or ?U ?P) (if dont-change-disc 'NEED-UPDATE (cons 'UP-TO-DATE (if (eq code ?U) 'UPDATED 'PATCHED))))) path 'trust))) diff --git a/lisp/vc/pcvs-util.el b/lisp/vc/pcvs-util.el index a3c525cb896..3d54bbd12a3 100644 --- a/lisp/vc/pcvs-util.el +++ b/lisp/vc/pcvs-util.el @@ -26,7 +26,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;;;; ;;;; list processing @@ -63,7 +63,7 @@ (while (and l (> n 1)) (setcdr nl (list (pop l))) (setq nl (cdr nl)) - (decf n)) + (cl-decf n)) ret)))) (defun cvs-partition (p l) @@ -130,10 +130,10 @@ If NOREUSE is non-nil, always return a new buffer." (if noreuse (generate-new-buffer name) (get-buffer-create name))) (unless noreuse - (dolist (buf (buffer-list)) + (cl-dolist (buf (buffer-list)) (with-current-buffer buf (when (equal name list-buffers-directory) - (return buf))))) + (cl-return buf))))) (with-current-buffer (create-file-buffer name) (setq list-buffers-directory name) (current-buffer)))) @@ -195,10 +195,10 @@ arguments. If ARGS is not a list, no argument will be passed." ;;;; (interactive <foo>) support function ;;;; -(defstruct (cvs-qtypedesc - (:constructor nil) (:copier nil) - (:constructor cvs-qtypedesc-create - (str2obj obj2str &optional complete hist-sym require))) +(cl-defstruct (cvs-qtypedesc + (:constructor nil) (:copier nil) + (:constructor cvs-qtypedesc-create + (str2obj obj2str &optional complete hist-sym require))) str2obj obj2str hist-sym @@ -231,10 +231,10 @@ arguments. If ARGS is not a list, no argument will be passed." ;;;; Flags handling ;;;; -(defstruct (cvs-flags - (:constructor nil) - (:constructor -cvs-flags-make - (desc defaults &optional qtypedesc hist-sym))) +(cl-defstruct (cvs-flags + (:constructor nil) + (:constructor -cvs-flags-make + (desc defaults &optional qtypedesc hist-sym))) defaults persist desc qtypedesc hist-sym) (defmacro cvs-flags-define (sym defaults diff --git a/lisp/vc/pcvs.el b/lisp/vc/pcvs.el index 0508f45149a..659151a31e9 100644 --- a/lisp/vc/pcvs.el +++ b/lisp/vc/pcvs.el @@ -118,7 +118,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'ewoc) ;Ewoc was once cookie (require 'pcvs-defs) (require 'pcvs-util) @@ -219,21 +219,21 @@ (autoload 'cvs-status-get-tags "cvs-status") (defun cvs-tags-list () "Return a list of acceptable tags, ready for completions." - (assert (cvs-buffer-p)) + (cl-assert (cvs-buffer-p)) (let ((marked (cvs-get-marked))) - (list* '("BASE") '("HEAD") - (when marked - (with-temp-buffer - (process-file cvs-program - nil ;no input - t ;output to current-buffer - nil ;don't update display while running - "status" - "-v" - (cvs-fileinfo->full-name (car marked))) - (goto-char (point-min)) - (let ((tags (cvs-status-get-tags))) - (when (listp tags) tags))))))) + `(("BASE") ("HEAD") + ,@(when marked + (with-temp-buffer + (process-file cvs-program + nil ;no input + t ;output to current-buffer + nil ;don't update display while running + "status" + "-v" + (cvs-fileinfo->full-name (car marked))) + (goto-char (point-min)) + (let ((tags (cvs-status-get-tags))) + (when (listp tags) tags))))))) (defvar cvs-tag-history nil) (defconst cvs-qtypedesc-tag @@ -426,16 +426,16 @@ If non-nil, NEW means to create a new buffer no matter what." ;; look for another cvs buffer visiting the same directory (save-excursion (unless new - (dolist (buffer (cons (current-buffer) (buffer-list))) + (cl-dolist (buffer (cons (current-buffer) (buffer-list))) (set-buffer buffer) (and (cvs-buffer-p) - (case cvs-reuse-cvs-buffer - (always t) - (subdir + (pcase cvs-reuse-cvs-buffer + (`always t) + (`subdir (or (string-prefix-p default-directory dir) (string-prefix-p dir default-directory))) - (samedir (string= default-directory dir))) - (return buffer))))) + (`samedir (string= default-directory dir))) + (cl-return buffer))))) ;; we really have to create a new buffer: ;; we temporarily bind cwd to "" to prevent ;; create-file-buffer from using directory info @@ -478,7 +478,7 @@ If non-nil, NEW means to create a new buffer no matter what." ;;(set-buffer buf) buffer)))))) -(defun* cvs-cmd-do (cmd dir flags fis new +(cl-defun cvs-cmd-do (cmd dir flags fis new &key cvsargs noexist dont-change-disc noshow) (let* ((dir (file-name-as-directory (abbreviate-file-name (expand-file-name dir)))) @@ -501,7 +501,7 @@ If non-nil, NEW means to create a new buffer no matter what." ;; cvsbuf)))) (defun cvs-run-process (args fis postprocess &optional single-dir) - (assert (cvs-buffer-p cvs-buffer)) + (cl-assert (cvs-buffer-p cvs-buffer)) (save-current-buffer (let ((procbuf (current-buffer)) (cvsbuf cvs-buffer) @@ -521,9 +521,9 @@ If non-nil, NEW means to create a new buffer no matter what." (let ((inhibit-read-only t)) (insert "pcl-cvs: descending directory " dir "\n")) ;; loop to find the same-dir-elems - (do* ((files () (cons (cvs-fileinfo->file fi) files)) - (fis fis (cdr fis)) - (fi (car fis) (car fis))) + (cl-do* ((files () (cons (cvs-fileinfo->file fi) files)) + (fis fis (cdr fis)) + (fi (car fis) (car fis))) ((not (and fis (string= dir (cvs-fileinfo->dir fi)))) (list dir files fis)))))) (dir (nth 0 dir+files+rest)) @@ -813,7 +813,7 @@ TIN specifies an optional starting point." (while (and tin (cvs-fileinfo< fi (ewoc-data tin))) (setq tin (ewoc-prev c tin))) (if (null tin) (ewoc-enter-first c fi) ;empty collection - (assert (not (cvs-fileinfo< fi (ewoc-data tin)))) + (cl-assert (not (cvs-fileinfo< fi (ewoc-data tin)))) (let ((next-tin (ewoc-next c tin))) (while (not (or (null next-tin) (cvs-fileinfo< fi (ewoc-data next-tin)))) @@ -871,15 +871,15 @@ RM-MSGS if non-nil means remove messages." (let* ((type (cvs-fileinfo->type fi)) (subtype (cvs-fileinfo->subtype fi)) (keep - (case type + (pcase type ;; remove temp messages and keep the others - (MESSAGE (not (or rm-msgs (eq subtype 'TEMP)))) + (`MESSAGE (not (or rm-msgs (eq subtype 'TEMP)))) ;; remove entries - (DEAD nil) + (`DEAD nil) ;; handled also? - (UP-TO-DATE (not rm-handled)) + (`UP-TO-DATE (not rm-handled)) ;; keep the rest - (t (not (run-hook-with-args-until-success + (_ (not (run-hook-with-args-until-success 'cvs-cleanup-functions fi)))))) ;; mark dirs for removal @@ -1389,7 +1389,7 @@ an empty list if it doesn't point to a file at all." fis)))) (nreverse fis))) -(defun* cvs-mode-marked (filter &optional cmd +(cl-defun cvs-mode-marked (filter &optional cmd &key read-only one file noquery) "Get the list of marked FIS. CMD is used to determine whether to use the marks or not. @@ -1474,7 +1474,7 @@ The POSTPROC specified there (typically `log-edit') is then called, (let ((msg (buffer-substring-no-properties (point-min) (point-max)))) (cvs-mode!) ;;(pop-to-buffer cvs-buffer) - (cvs-mode-do "commit" (list* "-m" msg flags) 'commit))) + (cvs-mode-do "commit" `("-m" ,msg ,@flags) 'commit))) ;;;; Editing existing commit log messages. @@ -1604,7 +1604,7 @@ With prefix argument, prompt for cvs flags." (or current-prefix-arg (not cvs-add-default-message))) (read-from-minibuffer "Enter description: ") (or cvs-add-default-message ""))) - (flags (list* "-m" msg flags)) + (flags `("-m" ,msg ,@flags)) (postproc ;; setup postprocessing for the directory entries (when dirs @@ -1845,7 +1845,7 @@ Signal an error if there is no backup file." (setq ret t))) ret))) -(defun* cvs-mode-run (cmd flags fis +(cl-defun cvs-mode-run (cmd flags fis &key (buf (cvs-temp-buffer)) dont-change-disc cvsargs postproc) "Generic cvs-mode-<foo> function. @@ -1887,7 +1887,7 @@ POSTPROC is a list of expressions to be evaluated at the very end (after (cvs-run-process args fis postproc single-dir)))) -(defun* cvs-mode-do (cmd flags filter +(cl-defun cvs-mode-do (cmd flags filter &key show dont-change-disc cvsargs postproc) "Generic cvs-mode-<foo> function. Executes `cvs CVSARGS CMD FLAGS' on the selected files. diff --git a/lisp/vc/smerge-mode.el b/lisp/vc/smerge-mode.el index cf1cdabc80f..e6b63030fef 100644 --- a/lisp/vc/smerge-mode.el +++ b/lisp/vc/smerge-mode.el @@ -43,7 +43,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'diff-mode) ;For diff-auto-refine-mode. (require 'newcomment) @@ -716,7 +716,7 @@ major modes. Uses `smerge-resolve-function' to do the actual work." (while (or (not (match-end i)) (< (point) (match-beginning i)) (>= (point) (match-end i))) - (decf i)) + (cl-decf i)) i)) (defun smerge-keep-current () @@ -779,7 +779,7 @@ An error is raised if not inside a conflict." (filename (or (match-string 1) "")) (_ (re-search-forward smerge-end-re)) - (_ (assert (< orig-point (match-end 0)))) + (_ (cl-assert (< orig-point (match-end 0)))) (other-end (match-beginning 0)) (end (match-end 0)) @@ -1073,12 +1073,12 @@ used to replace chars to try and eliminate some spurious differences." (forward-line 1) ;Skip hunk header. (and (re-search-forward "^[0-9]" nil 'move) ;Skip hunk body. (goto-char (match-beginning 0)))) - ;; (assert (or (null last1) (< (overlay-start last1) end1))) - ;; (assert (or (null last2) (< (overlay-start last2) end2))) + ;; (cl-assert (or (null last1) (< (overlay-start last1) end1))) + ;; (cl-assert (or (null last2) (< (overlay-start last2) end2))) (if smerge-refine-weight-hack (progn - ;; (assert (or (null last1) (<= (overlay-end last1) end1))) - ;; (assert (or (null last2) (<= (overlay-end last2) end2))) + ;; (cl-assert (or (null last1) (<= (overlay-end last1) end1))) + ;; (cl-assert (or (null last2) (<= (overlay-end last2) end2))) ) ;; smerge-refine-forward-function when calling in chopup may ;; have stopped because it bumped into EOB whereas in @@ -1290,8 +1290,8 @@ with a \\[universal-argument] prefix, makes up a 3-way conflict." (progn (pop-mark) (mark)) (when current-prefix-arg (pop-mark) (mark)))) ;; Start from the end so as to avoid problems with pos-changes. - (destructuring-bind (pt1 pt2 pt3 &optional pt4) - (sort (list* pt1 pt2 pt3 (if pt4 (list pt4))) '>=) + (pcase-let ((`(,pt1 ,pt2 ,pt3 ,pt4) + (sort `(,pt1 ,pt2 ,pt3 ,@(if pt4 (list pt4))) '>=))) (goto-char pt1) (beginning-of-line) (insert ">>>>>>> OTHER\n") (goto-char pt2) (beginning-of-line) |