mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2026-01-03 02:31:03 -08:00
Code Issues Projects Releases Wiki Activity

Reduce use of (require 'cl).

Browse source 
* 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.
This commit is contained in:
Stefan Monnier 2012-07-10 07:51:54 -04:00
parent dfa96edd13
commit f58e0fd503
62 changed files with 753 additions and 758 deletions
Download patch file Download diff file Expand all files Collapse all files

30
admin/ChangeLog
View file

@ -1,3 +1,7 @@
2012-07-10 Stefan Monnier <monnier@iro.umontreal.ca>
* bzrmerge.el: Use cl-lib.
2012-07-09 Paul Eggert <eggert@cs.ucla.edu>
Rename configure.in to configure.ac (Bug#11603).
@ -50,9 +54,9 @@
2012-06-13 Andreas Schwab <schwab@linux-m68k.org>
* make-emacs: Rename --union-type to --check-lisp-type. Define
CHECK_LISP_OBJECT_TYPE insted of USE_LISP_UNION_TYPE.
* CPP-DEFINES (DEBUG_LISP_OBJECT_TYPE): Renamed from
* make-emacs: Rename --union-type to --check-lisp-type.
Define CHECK_LISP_OBJECT_TYPE insted of USE_LISP_UNION_TYPE.
* CPP-DEFINES (DEBUG_LISP_OBJECT_TYPE): Rename from
USE_LISP_UNION_TYPE.
2012-06-03 Glenn Morris <rgm@gnu.org>
@ -223,11 +227,11 @@
* unidata/makefile.w32-in (all): Remove src/biditype.h and
src/bidimirror.h.
(../../src/biditype.h, ../../src/bidimirror.h): Deleted.
(../../src/biditype.h, ../../src/bidimirror.h): Delete.
* unidata/Makefile.in (all): Remove src/biditype.h and
src/bidimirror.h.
(../../src/biditype.h, ../../src/bidimirror.h): Deleted.
(../../src/biditype.h, ../../src/bidimirror.h): Delete.
2011-07-07 Juanma Barranquero <lekktu@gmail.com>
@ -238,8 +242,8 @@
* unidata/unidata-gen.el (unidata-dir): New variable.
(unidata-setup-list): Expand unidata-text-file in unidata-dir.
(unidata-prop-alist): INDEX element may be a function. New
optional element VAL-LIST (for general-category and bidi-class).
(unidata-prop-alist): INDEX element may be a function.
New optional element VAL-LIST (for general-category and bidi-class).
New entry `mirroring'.
(unidata-prop-default, unidata-prop-val-list): New subst.
(unidata-get-character, unidata-put-character): Delete them.
@ -595,13 +599,13 @@
2009-04-17 Kenichi Handa <handa@m17n.org>
* unidata/unidata-gen.el (unidata-get-decomposition): Adjust
Hangle decomposition rule to Unicode.
* unidata/unidata-gen.el (unidata-get-decomposition):
Adjust Hangle decomposition rule to Unicode.
2009-04-09 Kenichi Handa <handa@m17n.org>
* unidata/unidata-gen.el (unidata-describe-decomposition): Return
a string with a composition property to disable combining
* unidata/unidata-gen.el (unidata-describe-decomposition):
Return a string with a composition property to disable combining
characters being composed.
2009-03-11 Miles Bader <miles@gnu.org>
@ -1096,7 +1100,7 @@
2005-10-17 Bill Wohler <wohler@newt.com>
* FOR-RELEASE (DOCUMENTATION): Removed lisp/toolbar from list
* FOR-RELEASE (DOCUMENTATION): Remove lisp/toolbar from list
since it's gone. Also marked mh-e as done.
2005-10-11 Juanma Barranquero <lekktu@gmail.com>
@ -1143,7 +1147,7 @@
2005-03-30 Marcelo Toledo <marcelo@marcelotoledo.org>
* FOR-RELEASE (Documentation): Added check the Emacs Tutorial.
* FOR-RELEASE (Documentation): Add check the Emacs Tutorial.
The first line of every tutorial must begin with a sentence saying
"Emacs Tutorial" in the respective language. This should be
followed by "See end for copying conditions", likewise in the

9
admin/bzrmerge.el
View file

@ -24,8 +24,7 @@
;;; Code:
(eval-when-compile
(require 'cl)) ; assert
(eval-when-compile (require 'cl-lib))
(defvar bzrmerge-skip-regexp
"back[- ]?port\\|merge\\|sync\\|re-?generate\\|bump version\\|from trunk\\|\
@ -256,17 +255,17 @@ Does not make other difference."
;; Do a "skip" (i.e. merge the meta-data only).
(setq beg (1- (car skip)))
(while (and skip (or (null merge) (< (car skip) (car merge))))
(assert (> (car skip) (or end beg)))
(cl-assert (> (car skip) (or end beg)))
(setq end (pop skip)))
(message "Skipping %s..%s" beg end)
(bzrmerge-add-metadata from end))
(t
;; Do a "normal" merge.
(assert (or (null skip) (< (car merge) (car skip))))
(cl-assert (or (null skip) (< (car merge) (car skip))))
(setq beg (1- (car merge)))
(while (and merge (or (null skip) (< (car merge) (car skip))))
(assert (> (car merge) (or end beg)))
(cl-assert (> (car merge) (or end beg)))
(setq end (pop merge)))
(message "Merging %s..%s" beg end)
(if (with-temp-buffer

6
leim/ChangeLog
View file

@ -1,3 +1,9 @@
2012-07-10 Stefan Monnier <monnier@iro.umontreal.ca>
* quail/ipa.el: Use cl-lib.
* quail/hangul.el: Don't require CL.
2012-06-12 Nguyen Thai Ngoc Duy <pclouds@gmail.com>
* quail/vnvi.el: New file (Bug#4747).

1
leim/quail/hangul.el
View file

@ -30,7 +30,6 @@
;;; Code:
(require 'quail)
(eval-when-compile (require 'cl)) ; for setf
(require 'hanja-util)
;; Hangul double Jamo table.

16
leim/quail/ipa.el
View file

@ -29,7 +29,7 @@
;;; Code:
(require 'quail)
(eval-when-compile (require 'cl))
(eval-when-compile (require 'cl-lib))
(quail-define-package
"ipa" "IPA" "IPA" t
@ -277,13 +277,13 @@ string."
(setq quail-keymap (list (string quail-keymap)))
(if (stringp quail-keymap)
(setq quail-keymap (list quail-keymap))
(assert (vectorp quail-keymap) t)
(cl-assert (vectorp quail-keymap) t)
(setq quail-keymap (append quail-keymap nil))))
(list
(apply 'vector
(mapcar
#'(lambda (entry)
(assert (char-or-string-p entry) t)
(cl-assert (char-or-string-p entry) t)
(format "%s%s" to-prepend
(if (integerp entry) (string entry) entry)))
quail-keymap))))
@ -318,18 +318,18 @@ particular sequence of keys, and the result will be cached by Quail."
(dolist (underscoring underscore-map)
(cond ((null underscoring))
((eq (length underscoring) 2)
(setq underscore-map-entry (second underscoring))
(setq underscore-map-entry (cl-second underscoring))
(setcdr underscoring (ipa-x-sampa-prepend-to-keymap-entry
pre-underscore-map underscore-map-entry)))
((eq (length underscoring) 3)
(setq underscore-map-entry (second (third underscoring)))
(setcdr (third underscoring)
(setq underscore-map-entry (cl-second (cl-third underscoring)))
(setcdr (cl-third underscoring)
(ipa-x-sampa-prepend-to-keymap-entry
pre-underscore-map underscore-map-entry)))
(t
(assert (null t) t
(cl-assert (null t) t
"Can't handle subtrees of this level right now."))))
(append underscore-map (list (list ?< (second x-sampa-submap-entry))))))
(append underscore-map (list (list ?< (cl-second x-sampa-submap-entry))))))
(quail-define-package
"ipa-x-sampa" "IPA" "IPA-X" t

20
lisp/ChangeLog
View file

@ -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.

13
lisp/abbrev.el
View file

@ -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)))

17
lisp/apropos.el
View file

@ -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

3
lisp/autorevert.el
View file

@ -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

30
lisp/avoid.el
View file

@ -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
(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

11
lisp/battery.el
View file

@ -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

10
lisp/bookmark.el
View file

@ -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,7 +2034,7 @@ 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
(cl-loop for i in bookmark-alist
when (string-match regexp (car i)) collect i into new
finally return new)))
(bookmark-bmenu-list)))

10
lisp/bs.el
View file

@ -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)))

2
lisp/calculator.el
View file

@ -43,8 +43,6 @@
;;; History:
;; I hate history.
(eval-when-compile (require 'cl))
;;;=====================================================================
;;; Customization:

1
lisp/comint.el
View file

@ -101,7 +101,6 @@
;;; Code:
(eval-when-compile (require 'cl))
(require 'ring)
(require 'ansi-color)
(require 'regexp-opt) ;For regexp-opt-charset.

2
lisp/composite.el
View file

@ -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)

1
lisp/cus-dep.el
View file

@ -25,7 +25,6 @@
;;; Code:
(eval-when-compile (require 'cl))
(require 'widget)
(require 'cus-face)

2
lisp/dired.el
View file

@ -34,8 +34,6 @@
;;; Code:
(eval-when-compile (require 'cl))
;;; Customizable variables
(defgroup dired nil

30
lisp/doc-view.el
View file

@ -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 ()

96
lisp/edmacro.el
View file

@ -63,8 +63,7 @@
;;; Code:
(eval-when-compile
(require 'cl))
(eval-when-compile (require 'cl-lib))
(require 'kmacro)
@ -319,16 +318,17 @@ or nil, use a compact 80-column format."
mac))))
(if no-keys
(when cmd
(loop for key in (where-is-internal cmd '(keymap)) do
(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
(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)
(kmacro-lambda-form
mac mac-counter mac-format)
mac))))))))))
(kill-buffer buf)
(when (buffer-name 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
(cl-loop for i below (length macro) do
(when (>= (aref rest-mac i) 128)
(incf (aref rest-mac i) (- ?\M-\^@ 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,48 +448,49 @@ 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
(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)
(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
(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)
(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)
@ -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"
(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,7 +639,7 @@ 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
(cl-loop for i below (length seq) do
(when (logand (aref seq i) 128)
(setf (aref seq i) (logand (aref seq i) 127))))
seq)
@ -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
(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,11 +762,11 @@ 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
(cl-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
(concat (cl-loop for ch across res
collect (if (= (logand ch ?\M-\^@) 0)
ch (+ ch 128))))
res)))

10
lisp/electric.el
View file

@ -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?

15
lisp/emacs-lisp/autoload.el
View file

@ -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

12
lisp/emacs-lisp/byte-opt.el
View file

@ -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))))

37
lisp/emacs-lisp/bytecomp.el
View file

@ -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)

4
lisp/emulation/crisp.el
View file

@ -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)

6
lisp/face-remap.el
View file

@ -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".

70
lisp/filesets.el
View file

@ -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))
(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,7 +2327,7 @@ 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))
(cl-do ((data (filesets-conditional-sort filesets-data (function car))
(cdr data))
(count 1 (+ count 1)))
((null data))

15
lisp/font-lock.el
View file

@ -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))
@ -613,9 +613,6 @@ Major/minor modes can set this variable if they know which option applies.")
;; Font Lock mode.
(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.
@ -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))

2
lisp/frame.el
View file

@ -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)

2
lisp/hexl.el
View file

@ -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

17
lisp/image-mode.el
View file

@ -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))))))

12
lisp/imenu.el
View file

@ -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,11 +593,11 @@ Non-nil arguments are in recursive calls."
t))
(defun imenu--create-keymap (title alist &optional cmd)
(list* 'keymap title
(mapcar
`(keymap ,title
,@(mapcar
(lambda (item)
(list* (car item) (car item)
(cond
`(,(car item) ,(car item)
,@(cond
((imenu--subalist-p item)
(imenu--create-keymap (car item) (cdr item) cmd))
(t

13
lisp/info-xref.el
View file

@ -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"

2
lisp/info.el
View file

@ -32,8 +32,6 @@
;;; Code:
(eval-when-compile (require 'cl))
(defgroup info nil
"Info subsystem."
:group 'help

12
lisp/international/iso-ascii.el
View file

@ -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)

6
lisp/international/quail.el
View file

@ -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)))
(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")

8
lisp/international/ucs-normalize.el
View file

@ -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

2
lisp/jit-lock.el
View file

@ -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."

14
lisp/loadhist.el
View file

@ -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

6
lisp/lpr.el
View file

@ -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

104
lisp/minibuffer.el
View file

@ -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)
`(boundaries
,(max (length s1)
(+ beg (- (length s1) (length s2))))
(and (eq (car-safe res) 'boundaries) (cddr res)))))
. ,(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
(_ (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,9 +2046,9 @@ 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)
`(boundaries
,(or (match-beginning 2) (match-beginning 1))
. ,(when (string-match "[^[:alnum:]_]" suffix)
(match-beginning 0)))))))
(t
(if (eq (aref string (1- beg)) ?{)
@ -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
`(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)))
,(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)
(pcase-let ((`(,subpat ,suball ,subprefix ,_subsuffix)
(completion-pcm--find-all-completions
substring table pred (length substring) filter)
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)
(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--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)))))

50
lisp/mpc.el
View file

@ -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

32
lisp/msb.el
View file

@ -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,7 +702,7 @@ See `msb-menu-cond' for a description of its elements."
(multi-flag nil)
function-info-list)
(setq function-info-list
(loop for fi
(cl-loop for fi
across function-info-vector
if (and (setq result
(eval (aref fi 1))) ;Test CONDITION
@ -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,7 +841,7 @@ 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
(cl-loop with n = 0
for buffer in buffers
if (with-current-buffer buffer
(and (not (msb-invisible-buffer-p))
@ -851,7 +851,7 @@ It takes the form ((TITLE . BUFFER-LIST)...)."
buffer
max-buffer-name-length)
buffer))
and do (incf n)
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
@ -899,9 +899,9 @@ 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
`(,msb-files-by-directory-sort-key
,(car buffer-list)
,@(sort
(mapcar (lambda (buffer)
(cons (with-current-buffer buffer
(funcall
@ -918,7 +918,7 @@ It takes the form ((TITLE . BUFFER-LIST)...)."
(most-recently-used
(msb--most-recently-used-menu max-buffer-name-length))
(others (nconc file-buffers
(loop for elt
(cl-loop for elt
across function-info-vector
for value = (msb--create-sort-item elt)
if value collect value))))
@ -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)))

21
lisp/net/dbus.el
View file

@ -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!

4
lisp/net/gnutls.el
View file

@ -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

13
lisp/pcomplete.el
View file

@ -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."

45
lisp/progmodes/sh-script.el
View file

@ -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)))

10
lisp/register.el
View file

@ -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)))

7
lisp/scroll-bar.el
View file

@ -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).

2
lisp/simple.el
View file

@ -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" ())

6
lisp/uniquify.el
View file

@ -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

68
lisp/vc/cvs-status.el
View file

@ -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,7 +485,7 @@ Optional prefix ARG chooses between two representations."
(pe t) ;"prev equal"
(nas nil)) ;"next afters" to be returned
(insert " ")
(do* ((vs vlist (cdr vs))
(cl-do* ((vs vlist (cdr vs))
(ps prev (cdr ps))
(as after (cdr as)))
((and (null as) (null vs) (null ps))

133
lisp/vc/diff-mode.el
View file

@ -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
(pcase style
(`unified
(concat (if diff-valid-unified-empty-line
"^[^-+# \\\n]\\|" "^[^-+# \\]\\|")
;; A `unified' header is ambiguous.
diff-file-header-re))
(context "^[^-+#! \\]")
(normal "^[^<>#\\]")
(t "^[^-+#!<> \\]"))
(`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,15 +835,15 @@ 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)))
(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))
(setq file (cl-do* ((files files (cdr files))
(file (car files) (car files)))
;; Use file-regular-p to avoid
;; /dev/null, directories, etc.
@ -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,7 +941,7 @@ 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)
@ -951,10 +952,12 @@ else cover the whole buffer."
(backward-char 2))
(?\\ (when (save-excursion (forward-line -1)
(= (char-after) ?+))
(delete-region (point) last-pt) (setq modif t)))
(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,7 +980,7 @@ 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)
@ -991,7 +995,7 @@ else cover the whole buffer."
;; 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
(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)
(?+ (setq last (or last (point)))
(delete-char 1) (insert "-") t)
((?\\ ?#) t)
(t (when (and first last (< first last))
((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.
(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)
(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.
(pcase-let ((`(,buf ,_line-offset ,pos ,src ,dst ,switched)
(ignore-errors ;Signals errors in place of prompting.
(diff-find-source-location nil nil 'noprompt))
;; 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
(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))
(_ (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.

2
lisp/vc/diff.el
View file

@ -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)

1
lisp/vc/log-edit.el
View file

@ -29,7 +29,6 @@
;;; Code:
(eval-when-compile (require 'cl))
(require 'add-log) ; for all the ChangeLog goodies
(require 'pcvs-util)
(require 'ring)

1
lisp/vc/log-view.el
View file

@ -109,7 +109,6 @@
;;; Code:
(eval-when-compile (require 'cl))
(require 'pcvs-util)
(autoload 'vc-find-revision "vc")
(autoload 'vc-diff-internal "vc")

1
lisp/vc/pcvs-defs.el
View file

@ -26,7 +26,6 @@
;;; Code:
(eval-when-compile (require 'cl))
(require 'pcvs-util)
;;;; -------------------------------------------------------

32
lisp/vc/pcvs-info.el
View file

@ -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 "
(pcase type
(`DIRCHANGE (concat "In directory "
(cvs-add-face (cvs-fileinfo->full-name fileinfo)
'cvs-header t 'cvs-goal-column t)
":"))
(MESSAGE
(`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))

12
lisp/vc/pcvs-parse.el
View file

@ -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)))

12
lisp/vc/pcvs-util.el
View file

@ -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,7 +195,7 @@ arguments. If ARGS is not a list, no argument will be passed."
;;;; (interactive <foo>) support function
;;;;
(defstruct (cvs-qtypedesc
(cl-defstruct (cvs-qtypedesc
(:constructor nil) (:copier nil)
(:constructor cvs-qtypedesc-create
(str2obj obj2str &optional complete hist-sym require)))
@ -231,7 +231,7 @@ arguments. If ARGS is not a list, no argument will be passed."
;;;; Flags handling
;;;;
(defstruct (cvs-flags
(cl-defstruct (cvs-flags
(:constructor nil)
(:constructor -cvs-flags-make
(desc defaults &optional qtypedesc hist-sym)))

48
lisp/vc/pcvs.el
View file

@ -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,10 +219,10 @@
(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
`(("BASE") ("HEAD")
,@(when marked
(with-temp-buffer
(process-file cvs-program
nil ;no input
@ -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,7 +521,7 @@ 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))
(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))))
@ -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.

18
lisp/vc/smerge-mode.el
View file

@ -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)