diff options
| author | Stefan Monnier <monnier@iro.umontreal.ca> | 2012-07-11 19:13:41 -0400 |
|---|---|---|
| committer | Stefan Monnier <monnier@iro.umontreal.ca> | 2012-07-11 19:13:41 -0400 |
| commit | a464a6c73acf27b0d633d428919a36bc16a9d442 (patch) | |
| tree | bcba70ce0242bfd5987356c750ba4eb6b58820b1 | |
| parent | c214e35e489145bd3a8ab7a353671f947368a7ae (diff) | |
| download | emacs-a464a6c73acf27b0d633d428919a36bc16a9d442.tar.gz | |
More CL cleanups and reduction of use of cl.el.
* woman.el, winner.el, vc/vc-rcs.el, vc/vc-hooks.el, vc/vc-hg.el:
* vc/vc-git.el, vc/vc-dir.el, vc/vc-bzr.el, vc/vc-annotate.el:
* textmodes/tex-mode.el, textmodes/sgml-mode.el, tar-mode.el:
* strokes.el, ses.el, server.el, progmodes/js.el, progmodes/gdb-mi.el:
* progmodes/flymake.el, progmodes/ebrowse.el, progmodes/compile.el:
* play/tetris.el, play/snake.el, play/pong.el, play/landmark.el:
* play/hanoi.el, play/decipher.el, play/5x5.el, nxml/nxml-mode.el:
* net/secrets.el, net/quickurl.el, midnight.el, mail/footnote.el:
* image-dired.el, ibuffer.el, ibuf-macs.el, ibuf-ext.el, hexl.el:
* eshell/eshell.el, eshell/esh-io.el, eshell/esh-ext.el:
* eshell/esh-cmd.el, eshell/em-ls.el, eshell/em-hist.el:
* eshell/em-cmpl.el, eshell/em-banner.el:
* url/url.el, url/url-queue.el, url/url-parse.el, url/url-http.el:
* url/url-future.el, url/url-dav.el, url/url-cookie.el:
* calendar/parse-time.el, test/eshell.el: Use cl-lib.
* wid-browse.el, wdired.el, vc/vc.el, vc/vc-mtn.el, vc/vc-cvs.el:
* vc/vc-arch.el, tree-widget.el, textmodes/texinfo.el:
* textmodes/refill.el, textmodes/css-mode.el, term/tvi970.el:
* term/ns-win.el, term.el, shell.el, ps-samp.el:
* progmodes/perl-mode.el, progmodes/pascal.el, progmodes/gud.el:
* progmodes/glasses.el, progmodes/etags.el, progmodes/cwarn.el:
* play/gamegrid.el, play/bubbles.el, novice.el, notifications.el:
* net/zeroconf.el, net/xesam.el, net/snmp-mode.el, net/mairix.el:
* net/ldap.el, net/eudc.el, net/browse-url.el, man.el:
* mail/mailheader.el, mail/feedmail.el:
* url/url-util.el, url/url-privacy.el, url/url-nfs.el, url/url-misc.el:
* url/url-methods.el, url/url-gw.el, url/url-file.el, url/url-expand.el:
Dont use CL.
* ibuf-ext.el (ibuffer-mark-old-buffers): Use float-time.
* eshell/esh-opt.el (eshell-eval-using-options): Quote code with
`lambda' rather than with `quote'.
(eshell-do-opt): Adjust accordingly.
(eshell-process-option): Simplify.
* eshell/esh-var.el:
* eshell/em-script.el: Require `esh-opt' for eshell-eval-using-options.
* emacs-pcase.el (pcase--dontcare-upats, pcase--let*)
(pcase--expand, pcase--u1): Rename pcase's internal `dontcare' pattern
to `pcase--dontcare'.
* emacs-cl.el (labels): Mark obsolete.
(cl--letf, letf): Move to cl-lib.
(cl--letf*, letf*): Remove.
* emacs-cl-lib.el (cl-nth-value): Use defalias.
* emacs-cl-macs.el (cl-dolist, cl-dotimes): Add indent rule.
(cl-progv): Rewrite.
(cl--letf, cl-letf): Move from cl.el.
(cl-letf*): New macro.
* emacs-cl-extra.el (cl--progv-before, cl--progv-after): Remove.
109 files changed, 2339 insertions, 2391 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 77f9ce29c0f..8a18bfe0196 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,49 @@ +2012-07-11 Stefan Monnier <monnier@iro.umontreal.ca> + + More CL cleanups and reduction of use of cl.el. + * woman.el, winner.el, vc/vc-rcs.el, vc/vc-hooks.el, vc/vc-hg.el: + * vc/vc-git.el, vc/vc-dir.el, vc/vc-bzr.el, vc/vc-annotate.el: + * textmodes/tex-mode.el, textmodes/sgml-mode.el, tar-mode.el: + * strokes.el, ses.el, server.el, progmodes/js.el, progmodes/gdb-mi.el: + * progmodes/flymake.el, progmodes/ebrowse.el, progmodes/compile.el: + * play/tetris.el, play/snake.el, play/pong.el, play/landmark.el: + * play/hanoi.el, play/decipher.el, play/5x5.el, nxml/nxml-mode.el: + * net/secrets.el, net/quickurl.el, midnight.el, mail/footnote.el: + * image-dired.el, ibuffer.el, ibuf-macs.el, ibuf-ext.el, hexl.el: + * eshell/eshell.el, eshell/esh-io.el, eshell/esh-ext.el: + * eshell/esh-cmd.el, eshell/em-ls.el, eshell/em-hist.el: + * eshell/em-cmpl.el, eshell/em-banner.el: + * calendar/parse-time.el: Use cl-lib. + * wid-browse.el, wdired.el, vc/vc.el, vc/vc-mtn.el, vc/vc-cvs.el: + * vc/vc-arch.el, tree-widget.el, textmodes/texinfo.el: + * textmodes/refill.el, textmodes/css-mode.el, term/tvi970.el: + * term/ns-win.el, term.el, shell.el, ps-samp.el: + * progmodes/perl-mode.el, progmodes/pascal.el, progmodes/gud.el: + * progmodes/glasses.el, progmodes/etags.el, progmodes/cwarn.el: + * play/gamegrid.el, play/bubbles.el, novice.el, notifications.el: + * net/zeroconf.el, net/xesam.el, net/snmp-mode.el, net/mairix.el: + * net/ldap.el, net/eudc.el, net/browse-url.el, man.el: + * mail/mailheader.el, mail/feedmail.el: Don't use CL. + * ibuf-ext.el (ibuffer-mark-old-buffers): Use float-time. + * eshell/esh-opt.el (eshell-eval-using-options): Quote code with + `lambda' rather than with `quote'. + (eshell-do-opt): Adjust accordingly. + (eshell-process-option): Simplify. + * eshell/esh-var.el: + * eshell/em-script.el: Require `esh-opt' for eshell-eval-using-options. + * emacs-lisp/pcase.el (pcase--dontcare-upats, pcase--let*) + (pcase--expand, pcase--u1): Rename pcase's internal `dontcare' pattern + to `pcase--dontcare'. + * emacs-lisp/cl.el (labels): Mark obsolete. + (cl--letf, letf): Move to cl-lib. + (cl--letf*, letf*): Remove. + * emacs-lisp/cl-lib.el (cl-nth-value): Use defalias. + * emacs-lisp/cl-macs.el (cl-dolist, cl-dotimes): Add indent rule. + (cl-progv): Rewrite. + (cl--letf, cl-letf): Move from cl.el. + (cl-letf*): New macro. + * emacs-lisp/cl-extra.el (cl--progv-before, cl--progv-after): Remove. + 2012-07-11 Michael Albinus <michael.albinus@gmx.de> * net/ange-ftp.el (ange-ftp-cf1): Update the files cache. diff --git a/lisp/calendar/parse-time.el b/lisp/calendar/parse-time.el index baf92065550..f8f4c7b3fac 100644 --- a/lisp/calendar/parse-time.el +++ b/lisp/calendar/parse-time.el @@ -34,7 +34,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) ;and ah ain't kiddin' 'bout it +(eval-when-compile (require 'cl-lib)) (defvar parse-time-digits (make-vector 256 nil)) @@ -43,8 +43,8 @@ (defvar parse-time-val) (unless (aref parse-time-digits ?0) - (loop for i from ?0 to ?9 - do (aset parse-time-digits i (- i ?0)))) + (cl-loop for i from ?0 to ?9 + do (aset parse-time-digits i (- i ?0)))) (defsubst digit-char-p (char) (aref parse-time-digits char)) @@ -92,11 +92,11 @@ (index 0) (c nil)) (while (< index end) - (while (and (< index end) ;skip invalid characters + (while (and (< index end) ;Skip invalid characters. (not (setq c (parse-time-string-chars (aref string index))))) - (incf index)) + (cl-incf index)) (setq start index all-digits (eq c ?0)) - (while (and (< (incf index) end) ;scan valid characters + (while (and (< (cl-incf index) end) ;Scan valid characters. (setq c (parse-time-string-chars (aref string index)))) (setq all-digits (and all-digits (eq c ?0)))) (if (<= index end) diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index b721ceba2ef..ea5e1cf9beb 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -313,25 +313,6 @@ If so, return the true (non-nil) value returned by PREDICATE. (t (make-frame-visible frame))) val) -;;; Support for `cl-progv'. -(defvar cl--progv-save) -;;;###autoload -(defun cl--progv-before (syms values) - (while syms - (push (if (boundp (car syms)) - (cons (car syms) (symbol-value (car syms))) - (car syms)) cl--progv-save) - (if values - (set (pop syms) (pop values)) - (makunbound (pop syms))))) - -(defun cl--progv-after () - (while cl--progv-save - (if (consp (car cl--progv-save)) - (set (car (car cl--progv-save)) (cdr (car cl--progv-save))) - (makunbound (car cl--progv-save))) - (pop cl--progv-save))) - ;;; Numbers. diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index b9a5d4b2fc9..aa12c709b1a 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -230,12 +230,13 @@ one value." "Apply FUNCTION to ARGUMENTS, taking multiple values into account. This implementation only handles the case where there is only one argument.") -(defsubst cl-nth-value (n expression) +(cl--defalias 'cl-nth-value #'nth "Evaluate EXPRESSION to get multiple values and return the Nth one. This handles multiple values in Common Lisp style, but it does not work right when EXPRESSION calls an ordinary Emacs Lisp function that returns just -one value." - (nth n expression)) +one value. + +\(fn N EXPRESSION)") ;;; Declarations. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 39e230cb32c..31d20f274ed 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -624,7 +624,7 @@ Key values are compared by `eql'. ;;;###autoload (defmacro cl-ecase (expr &rest clauses) - "Like `cl-case', but error if no cl-case fits. + "Like `cl-case', but error if no case fits. `otherwise'-clauses are not allowed. \n(fn EXPR (KEYLIST BODY...)...)" (declare (indent 1) (debug cl-case)) @@ -1482,7 +1482,8 @@ Then evaluate RESULT to get return value, default nil. An implicit nil block is established around the loop. \(fn (VAR LIST [RESULT]) BODY...)" - (declare (debug ((symbolp form &optional form) cl-declarations body))) + (declare (debug ((symbolp form &optional form) cl-declarations body)) + (indent 1)) `(cl-block nil (,(if (eq 'cl-dolist (symbol-function 'dolist)) 'cl--dolist 'dolist) ,spec ,@body))) @@ -1495,7 +1496,7 @@ to COUNT, exclusive. Then evaluate RESULT to get return value, default nil. \(fn (VAR COUNT [RESULT]) BODY...)" - (declare (debug cl-dolist)) + (declare (debug cl-dolist) (indent 1)) `(cl-block nil (,(if (eq 'cl-dotimes (symbol-function 'dotimes)) 'cl--dotimes 'dotimes) ,spec ,@body))) @@ -1546,10 +1547,19 @@ second list (or made unbound if VALUES is shorter than SYMBOLS); then the BODY forms are executed and their result is returned. This is much like a `let' form, except that the list of symbols can be computed at run-time." (declare (indent 2) (debug (form form body))) - `(let ((cl--progv-save nil)) - (unwind-protect - (progn (cl--progv-before ,symbols ,values) ,@body) - (cl--progv-after)))) + (let ((bodyfun (make-symbol "body")) + (binds (make-symbol "binds")) + (syms (make-symbol "syms")) + (vals (make-symbol "vals"))) + `(progn + (defvar ,bodyfun) + (let* ((,syms ,symbols) + (,vals ,values) + (,bodyfun (lambda () ,@body)) + (,binds ())) + (while ,syms + (push (list (pop ,syms) (list 'quote (pop ,vals))) ,binds)) + (eval (list 'let ,binds '(funcall ,bodyfun))))))) (defvar cl--labels-convert-cache nil) @@ -1600,7 +1610,7 @@ Like `cl-labels' but the definitions are not recursive. Like `cl-flet' but the definitions can refer to previous ones. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" - (declare (indent 1) (debug ((&rest (cl-defun)) cl-declarations body))) + (declare (indent 1) (debug cl-flet)) (cond ((null bindings) (macroexp-progn body)) ((null (cdr bindings)) `(cl-flet ,bindings ,@body)) @@ -1609,7 +1619,8 @@ Like `cl-flet' but the definitions can refer to previous ones. ;;;###autoload (defmacro cl-labels (bindings &rest body) "Make temporary function bindings. -The bindings can be recursive. Assumes the use of `lexical-binding'. +The bindings can be recursive and the scoping is lexical, but capturing them +in closures will only work if `lexical-binding' is in use. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" (declare (indent 1) (debug cl-flet)) @@ -1911,6 +1922,86 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'. (macroexp-let* `((,temp ,getter)) `(progn ,(funcall setter form) nil)))))) +;; FIXME: `letf' is unsatisfactory because it does not really "restore" the +;; previous state. If the getter/setter loses information, that info is +;; not recovered. + +(defun cl--letf (bindings simplebinds binds body) + ;; It's not quite clear what the semantics of cl-letf should be. + ;; E.g. in (cl-letf ((PLACE1 VAL1) (PLACE2 VAL2)) BODY), while it's clear + ;; that the actual assignments ("bindings") should only happen after + ;; evaluating VAL1 and VAL2, it's not clear when the sub-expressions of + ;; PLACE1 and PLACE2 should be evaluated. Should we have + ;; PLACE1; VAL1; PLACE2; VAL2; bind1; bind2 + ;; or + ;; VAL1; VAL2; PLACE1; PLACE2; bind1; bind2 + ;; or + ;; VAL1; VAL2; PLACE1; bind1; PLACE2; bind2 + ;; Common-Lisp's `psetf' does the first, so we'll do the same. + (if (null bindings) + (if (and (null binds) (null simplebinds)) (macroexp-progn body) + `(let* (,@(mapcar (lambda (x) + (pcase-let ((`(,vold ,getter ,_setter ,_vnew) x)) + (list vold getter))) + binds) + ,@simplebinds) + (unwind-protect + ,(macroexp-progn + (append + (delq nil + (mapcar (lambda (x) + (pcase x + ;; If there's no vnew, do nothing. + (`(,_vold ,_getter ,setter ,vnew) + (funcall setter vnew)))) + binds)) + body)) + ,@(mapcar (lambda (x) + (pcase-let ((`(,vold ,_getter ,setter ,_vnew) x)) + (funcall setter vold))) + binds)))) + (let ((binding (car bindings))) + (gv-letplace (getter setter) (car binding) + (macroexp-let2 nil vnew (cadr binding) + (if (symbolp (car binding)) + ;; Special-case for simple variables. + (cl--letf (cdr bindings) + (cons `(,getter ,(if (cdr binding) vnew getter)) + simplebinds) + binds body) + (cl--letf (cdr bindings) simplebinds + (cons `(,(make-symbol "old") ,getter ,setter + ,@(if (cdr binding) (list vnew))) + binds) + body))))))) + +;;;###autoload +(defmacro cl-letf (bindings &rest body) + "Temporarily bind to PLACEs. +This is the analogue of `let', but with generalized variables (in the +sense of `setf') for the PLACEs. Each PLACE is set to the corresponding +VALUE, then the BODY forms are executed. On exit, either normally or +because of a `throw' or error, the PLACEs are set back to their original +values. Note that this macro is *not* available in Common Lisp. +As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', +the PLACE is not modified before executing BODY. + +\(fn ((PLACE VALUE) ...) BODY...)" + (declare (indent 1) (debug ((&rest (gate gv-place &optional form)) body))) + (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings))) + `(let ,bindings ,@body) + (cl--letf bindings () () body))) + +;;;###autoload +(defmacro cl-letf* (bindings &rest body) + "Temporarily bind to PLACEs. +Like `cl-letf' but where the bindings are performed one at a time, +rather than all at the end (i.e. like `let*' rather than like `let')." + (declare (indent 1) (debug cl-letf)) + (dolist (binding (reverse bindings)) + (setq body (list `(cl-letf (,binding) ,@body)))) + (macroexp-progn body)) + ;;;###autoload (defmacro cl-callf (func place &rest args) "Set PLACE to (FUNC PLACE ARGS...). diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 04ff194a3bf..e1e40029491 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -222,7 +222,7 @@ callf2 callf letf* - letf + ;; letf rotatef shiftf remf @@ -449,16 +449,6 @@ Common Lisp. (setq body (list `(lexical-let (,(pop bindings)) ,@body)))) (car body))) -(defmacro cl--symbol-function (symbol) - "Like `symbol-function' but return `cl--unbound' if not bound." - ;; (declare (gv-setter (lambda (store) - ;; `(if (eq ,store 'cl--unbound) - ;; (fmakunbound ,symbol) (fset ,symbol ,store))))) - `(if (fboundp ,symbol) (symbol-function ,symbol) 'cl--unbound)) -(gv-define-setter cl--symbol-function (store symbol) - `(if (eq ,store 'cl--unbound) (fmakunbound ,symbol) (fset ,symbol ,store))) - - ;; This should really have some way to shadow 'byte-compile properties, etc. (defmacro flet (bindings &rest body) "Make temporary overriding function definitions. @@ -470,38 +460,36 @@ then the definitions are undone (the FUNCs go back to their previous definitions, or lack thereof). \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" - (declare (indent 1) (debug cl-flet)) - `(letf* ,(mapcar - (lambda (x) - (if (or (and (fboundp (car x)) - (eq (car-safe (symbol-function (car x))) 'macro)) - (cdr (assq (car x) macroexpand-all-environment))) - (error "Use `labels', not `flet', to rebind macro names")) - (let ((func `(cl-function - (lambda ,(cadr x) - (cl-block ,(car x) ,@(cddr x)))))) - (when (cl--compiling-file) - ;; Bug#411. It would be nice to fix this. - (and (get (car x) 'byte-compile) - (error "Byte-compiling a redefinition of `%s' \ + (declare (indent 1) (debug cl-flet) + (obsolete "Use either `cl-flet' or `cl-letf'." "24.2")) + `(letf ,(mapcar + (lambda (x) + (if (or (and (fboundp (car x)) + (eq (car-safe (symbol-function (car x))) 'macro)) + (cdr (assq (car x) macroexpand-all-environment))) + (error "Use `labels', not `flet', to rebind macro names")) + (let ((func `(cl-function + (lambda ,(cadr x) + (cl-block ,(car x) ,@(cddr x)))))) + (when (cl--compiling-file) + ;; Bug#411. It would be nice to fix this. + (and (get (car x) 'byte-compile) + (error "Byte-compiling a redefinition of `%s' \ will not work - use `labels' instead" (symbol-name (car x)))) - ;; FIXME This affects the rest of the file, when it - ;; should be restricted to the flet body. - (and (boundp 'byte-compile-function-environment) - (push (cons (car x) (eval func)) - byte-compile-function-environment))) - (list `(symbol-function ',(car x)) func))) - bindings) + ;; FIXME This affects the rest of the file, when it + ;; should be restricted to the flet body. + (and (boundp 'byte-compile-function-environment) + (push (cons (car x) (eval func)) + byte-compile-function-environment))) + (list `(symbol-function ',(car x)) func))) + bindings) ,@body)) -(make-obsolete 'flet "Use either `cl-flet' or `letf'." "24.2") (defmacro labels (bindings &rest body) "Make temporary function bindings. -This is like `flet', except the bindings are lexical instead of dynamic. -Unlike `flet', this macro is fully compliant with the Common Lisp standard. - -\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" - (declare (indent 1) (debug cl-flet)) +Like `cl-labels' except that the lexical scoping is handled via `lexical-let' +rather than relying on `lexical-binding'." + (declare (indent 1) (debug cl-flet) (obsolete 'cl-labels "24.2")) (let ((vars nil) (sets nil) (newenv macroexpand-all-environment)) (dolist (binding bindings) ;; It's important that (not (eq (symbol-name var1) (symbol-name var2))) @@ -521,93 +509,24 @@ Unlike `flet', this macro is fully compliant with the Common Lisp standard. ;; not 100% compatible: not worth the trouble to add them to cl-lib.el, but we ;; still need to support old users of cl.el. -;; FIXME: `letf' is unsatisfactory because it does not really "restore" the -;; previous state. If the getter/setter loses information, that info is -;; not recovered. - -(defun cl--letf (bindings simplebinds binds body) - ;; It's not quite clear what the semantics of let! should be. - ;; E.g. in (let! ((PLACE1 VAL1) (PLACE2 VAL2)) BODY), while it's clear - ;; that the actual assignments ("bindings") should only happen after - ;; evaluating VAL1 and VAL2, it's not clear when the sub-expressions of - ;; PLACE1 and PLACE2 should be evaluated. Should we have - ;; PLACE1; VAL1; PLACE2; VAL2; bind1; bind2 - ;; or - ;; VAL1; VAL2; PLACE1; PLACE2; bind1; bind2 - ;; or - ;; VAL1; VAL2; PLACE1; bind1; PLACE2; bind2 - ;; Common-Lisp's `psetf' does the first, so we'll do the same. - (if (null bindings) - (if (and (null binds) (null simplebinds)) (macroexp-progn body) - `(let* (,@(mapcar (lambda (x) - (pcase-let ((`(,vold ,getter ,_setter ,_vnew) x)) - (list vold getter))) - binds) - ,@simplebinds) - (unwind-protect - ,(macroexp-progn (append - (mapcar (lambda (x) (pcase x - (`(,_vold ,_getter ,setter ,vnew) - (funcall setter vnew)))) - binds) - body)) - ,@(mapcar (lambda (x) (pcase-let ((`(,vold ,_getter ,setter ,_vnew) x)) - (funcall setter vold))) - binds)))) - (let ((binding (car bindings))) - (if (eq (car-safe (car binding)) 'symbol-function) - (setcar (car binding) 'cl--symbol-function)) - (gv-letplace (getter setter) (car binding) - (macroexp-let2 nil vnew (cadr binding) - (if (symbolp (car binding)) - ;; Special-case for simple variables. - (cl--letf (cdr bindings) - (cons `(,getter ,(if (cdr binding) vnew getter)) - simplebinds) - binds body) - (cl--letf (cdr bindings) simplebinds - (cons `(,(make-symbol "old") ,getter ,setter - ,@(if (cdr binding) (list vnew))) - binds) - body))))))) +(defmacro cl--symbol-function (symbol) + "Like `symbol-function' but return `cl--unbound' if not bound." + ;; (declare (gv-setter (lambda (store) + ;; `(if (eq ,store 'cl--unbound) + ;; (fmakunbound ,symbol) (fset ,symbol ,store))))) + `(if (fboundp ,symbol) (symbol-function ,symbol) 'cl--unbound)) +(gv-define-setter cl--symbol-function (store symbol) + `(if (eq ,store 'cl--unbound) (fmakunbound ,symbol) (fset ,symbol ,store))) (defmacro letf (bindings &rest body) - "Temporarily bind to PLACEs. -This is the analogue of `let', but with generalized variables (in the -sense of `setf') for the PLACEs. Each PLACE is set to the corresponding -VALUE, then the BODY forms are executed. On exit, either normally or -because of a `throw' or error, the PLACEs are set back to their original -values. Note that this macro is *not* available in Common Lisp. -As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', -the PLACE is not modified before executing BODY. - -\(fn ((PLACE VALUE) ...) BODY...)" - (declare (indent 1) (debug ((&rest (gate gv-place &optional form)) body))) - (cl--letf bindings () () body)) - -(defun cl--letf* (bindings body) - (if (null bindings) - (macroexp-progn body) - (let ((binding (car bindings))) - (if (symbolp (car binding)) - ;; Special-case for simple variables. - (macroexp-let* (list (if (cdr binding) binding - (list (car binding) (car binding)))) - (cl--letf* (cdr bindings) body)) - (if (eq (car-safe (car binding)) 'symbol-function) - (setcar (car binding) 'cl--symbol-function)) - (gv-letplace (getter setter) (car binding) - (macroexp-let2 macroexp-copyable-p vnew (cadr binding) - (macroexp-let2 nil vold getter - `(unwind-protect - (progn - ,(if (cdr binding) (funcall setter vnew)) - ,(cl--letf* (cdr bindings) body)) - ,(funcall setter vold))))))))) - -(defmacro letf* (bindings &rest body) - (declare (indent 1) (debug letf)) - (cl--letf* bindings body)) + "Dynamically scoped let-style bindings for places. +Like `cl-letf', but with some extra backward compatibility." + ;; Like cl-letf, but with special handling of symbol-function. + `(cl-letf ,(mapcar (lambda (x) (if (eq (car-safe (car x)) 'symbol-function) + `((cl--symbol-function ,@(cdar x)) ,@(cdr x)) + x)) + bindings) + ,@body)) (defun cl--gv-adapt (cl-gv do) ;; This function is used by all .elc files that use define-setf-expander and diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el index 82e958533e8..55915813877 100644 --- a/lisp/emacs-lisp/elint.el +++ b/lisp/emacs-lisp/elint.el @@ -466,6 +466,9 @@ Return nil if there are no more forms, t otherwise." (add-to-list 'elint-features name) ;; cl loads cl-macs in an opaque manner. ;; Since cl-macs requires cl, we can just process cl-macs. + ;; FIXME: AFAIK, `cl' now behaves properly and does not need any + ;; special treatment any more. Can someone who understands this + ;; code confirm? --Stef (and (eq name 'cl) (not elint-doing-cl) ;; We need cl if elint-form is to be able to expand cl macros. (require 'cl) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 59dccb35952..3f4ce605cb0 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -64,7 +64,7 @@ ;; (defconst pcase--memoize-1 (make-hash-table :test 'eq)) ;; (defconst pcase--memoize-2 (make-hash-table :weakness 'key :test 'equal)) -(defconst pcase--dontcare-upats '(t _ dontcare)) +(defconst pcase--dontcare-upats '(t _ pcase--dontcare)) (def-edebug-spec pcase-UPAT @@ -154,11 +154,12 @@ like `(,a . ,(pred (< a))) or, with more checks: (pcase--expand (cadr binding) `((,(car binding) ,(pcase--let* bindings body)) - ;; We can either signal an error here, or just use `dontcare' which - ;; generates more efficient code. In practice, if we use `dontcare' - ;; we will still often get an error and the few cases where we don't - ;; do not matter that much, so it's a better choice. - (dontcare nil))))))) + ;; We can either signal an error here, or just use `pcase--dontcare' + ;; which generates more efficient code. In practice, if we use + ;; `pcase--dontcare' we will still often get an error and the few + ;; cases where we don't do not matter that much, so + ;; it's a better choice. + (pcase--dontcare nil))))))) ;;;###autoload (defmacro pcase-let* (bindings &rest body) @@ -275,7 +276,7 @@ of the form (UPAT EXP)." vars)))) cases)))) (dolist (case cases) - (unless (or (memq case used-cases) (eq (car case) 'dontcare)) + (unless (or (memq case used-cases) (eq (car case) 'pcase--dontcare)) (message "Redundant pcase pattern: %S" (car case)))) (macroexp-let* defs main)))) @@ -575,7 +576,7 @@ Otherwise, it defers to REST which is a list of branches of the form (upat (cdr cdrpopmatches))) (cond ((memq upat '(t _)) (pcase--u1 matches code vars rest)) - ((eq upat 'dontcare) :pcase--dontcare) + ((eq upat 'pcase--dontcare) :pcase--dontcare) ((memq (car-safe upat) '(guard pred)) (if (eq (car upat) 'pred) (put sym 'pcase-used t)) (let* ((splitrest diff --git a/lisp/eshell/em-banner.el b/lisp/eshell/em-banner.el index 82cb638a791..8fdad66f3f0 100644 --- a/lisp/eshell/em-banner.el +++ b/lisp/eshell/em-banner.el @@ -39,7 +39,7 @@ ;;; Code: (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'esh-mode) (require 'eshell)) @@ -77,10 +77,10 @@ This can be any sexp, and should end with at least two newlines." ;; `insert', because `insert' doesn't know how to interact with the ;; I/O code used by Eshell (unless eshell-non-interactive-p - (assert eshell-mode) - (assert eshell-banner-message) + (cl-assert eshell-mode) + (cl-assert eshell-banner-message) (let ((msg (eval eshell-banner-message))) - (assert msg) + (cl-assert msg) (eshell-interactive-print msg)))) (provide 'em-banner) diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el index 25a70104c02..a67861e83a9 100644 --- a/lisp/eshell/em-cmpl.el +++ b/lisp/eshell/em-cmpl.el @@ -70,7 +70,7 @@ ;;; Code: (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'eshell)) (require 'esh-util) @@ -358,7 +358,7 @@ to writing a completion function." (nconc posns (list pos))) (setq pos (1+ pos)))) (setq posns (cdr posns)) - (assert (= (length args) (length posns))) + (cl-assert (= (length args) (length posns))) (let ((a args) (i 0) l final) @@ -370,7 +370,7 @@ to writing a completion function." (and l (setq args (nthcdr (1+ l) args) posns (nthcdr (1+ l) posns)))) - (assert (= (length args) (length posns))) + (cl-assert (= (length args) (length posns))) (when (and args (eq (char-syntax (char-before end)) ? ) (not (eq (char-before (1- end)) ?\\))) (nconc args (list "")) @@ -383,7 +383,7 @@ to writing a completion function." (let ((result (eshell-do-eval (list 'eshell-commands arg) t))) - (assert (eq (car result) 'quote)) + (cl-assert (eq (car result) 'quote)) (cadr result)) arg))) (if (numberp val) diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el index 62d0bd65e9d..64a7ad94c53 100644 --- a/lisp/eshell/em-hist.el +++ b/lisp/eshell/em-hist.el @@ -54,8 +54,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'ring) (require 'esh-opt) @@ -560,8 +559,8 @@ See also `eshell-read-history'." (forward-char)) (setq posb (cdr posb) pose (cdr pose)) - (assert (= (length posb) (length args))) - (assert (<= (length posb) (length pose)))) + (cl-assert (= (length posb) (length args))) + (cl-assert (<= (length posb) (length pose)))) (setq hist (buffer-substring-no-properties begin end)) (let ((b posb) (e pose)) (while b @@ -571,7 +570,7 @@ See also `eshell-read-history'." (setq b (cdr b) e (cdr e)))) (setq textargs (cdr textargs)) - (assert (= (length textargs) (length args))) + (cl-assert (= (length textargs) (length args))) (list textargs posb pose)))) (defun eshell-expand-history-references (beg end) diff --git a/lisp/eshell/em-ls.el b/lisp/eshell/em-ls.el index 5553207b626..142a5f964ab 100644 --- a/lisp/eshell/em-ls.el +++ b/lisp/eshell/em-ls.el @@ -27,7 +27,7 @@ ;;; Code: (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'eshell)) (require 'esh-util) (require 'esh-opt) @@ -463,7 +463,7 @@ name should be displayed as, etc. Think of it as cooking a FILEINFO." (progn (setcdr fileinfo attr) (setcar fileinfo (eshell-ls-decorated-name fileinfo))) - (assert (eq listing-style 'long-listing)) + (cl-assert (eq listing-style 'long-listing)) (setcar fileinfo (concat (eshell-ls-decorated-name fileinfo) " -> " (eshell-ls-decorated-name @@ -698,7 +698,7 @@ Each member of FILES is either a string or a cons cell of the form (let* ((col-vals (if (eq listing-style 'by-columns) (eshell-ls-find-column-lengths display-files) - (assert (eq listing-style 'by-lines)) + (cl-assert (eq listing-style 'by-lines)) (eshell-ls-find-column-widths display-files))) (col-widths (car col-vals)) (display-files (cdr col-vals)) diff --git a/lisp/eshell/em-script.el b/lisp/eshell/em-script.el index 3b203b4856c..f219a4b6f12 100644 --- a/lisp/eshell/em-script.el +++ b/lisp/eshell/em-script.el @@ -24,6 +24,7 @@ ;;; Code: (require 'eshell) +(require 'esh-opt) ;;;###autoload (progn diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el index 872d1cdd53e..515a23f81d7 100644 --- a/lisp/eshell/esh-cmd.el +++ b/lisp/eshell/esh-cmd.el @@ -108,7 +108,7 @@ (require 'esh-ext) (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'pcomplete)) @@ -604,7 +604,7 @@ For an external command, it means an exit code of 0." (list (if (<= (length pieces) 1) (car pieces) - (assert (not eshell-in-pipeline-p)) + (cl-assert (not eshell-in-pipeline-p)) `(eshell-execute-pipeline (quote ,pieces)))))) (setq bp (cdr bp)))) ;; `results' might be empty; this happens in the case of @@ -615,7 +615,7 @@ For an external command, it means an exit code of 0." results (cdr results) sep-terms (nreverse sep-terms)) (while results - (assert (car sep-terms)) + (cl-assert (car sep-terms)) (setq final (eshell-structure-basic-command 'if (string= (car sep-terms) "&&") "if" `(eshell-protect ,(car results)) @@ -1026,7 +1026,7 @@ be finished later after the completion of an asynchronous subprocess." ;; `eshell-copy-tree' is needed here so that the test argument ;; doesn't get modified and thus always yield the same result. (when (car eshell-command-body) - (assert (not synchronous-p)) + (cl-assert (not synchronous-p)) (eshell-do-eval (car eshell-command-body)) (setcar eshell-command-body nil) (setcar eshell-test-body nil)) @@ -1046,7 +1046,7 @@ be finished later after the completion of an asynchronous subprocess." ;; doesn't get modified and thus always yield the same result. (if (car eshell-command-body) (progn - (assert (not synchronous-p)) + (cl-assert (not synchronous-p)) (eshell-do-eval (car eshell-command-body))) (unless (car eshell-test-body) (setcar eshell-test-body (eshell-copy-tree (car args)))) @@ -1201,7 +1201,7 @@ COMMAND may result in an alias being executed, or a plain command." (setq eshell-last-arguments args eshell-last-command-name (eshell-stringify command)) (run-hook-with-args 'eshell-prepare-command-hook) - (assert (stringp eshell-last-command-name)) + (cl-assert (stringp eshell-last-command-name)) (if eshell-last-command-name (or (run-hook-with-args-until-success 'eshell-named-command-hook eshell-last-command-name diff --git a/lisp/eshell/esh-ext.el b/lisp/eshell/esh-ext.el index a411d3df06e..603da6f2e30 100644 --- a/lisp/eshell/esh-ext.el +++ b/lisp/eshell/esh-ext.el @@ -34,9 +34,10 @@ (provide 'esh-ext) (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'esh-cmd)) (require 'esh-util) +(require 'esh-opt) (defgroup eshell-ext nil "External commands are invoked when operating system executables are @@ -206,10 +207,10 @@ causing the user to wonder if anything's really going on..." (defun eshell-external-command (command args) "Insert output from an external COMMAND, using ARGS." (setq args (eshell-stringify-list (eshell-flatten-list args))) -; (if (file-remote-p default-directory) -; (eshell-remote-command command args)) + ;; (if (file-remote-p default-directory) + ;; (eshell-remote-command command args)) (let ((interp (eshell-find-interpreter command))) - (assert interp) + (cl-assert interp) (if (functionp (car interp)) (apply (car interp) (append (cdr interp) args)) (eshell-gather-process-output diff --git a/lisp/eshell/esh-io.el b/lisp/eshell/esh-io.el index c8230e0baad..9f3cfe0f6d0 100644 --- a/lisp/eshell/esh-io.el +++ b/lisp/eshell/esh-io.el @@ -59,7 +59,7 @@ (provide 'esh-io) (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'eshell)) (defgroup eshell-io nil @@ -298,7 +298,7 @@ completed successfully. RESULT is the quoted value of the last command. If nil, then the meta variables for keeping track of the last execution result should not be changed." (let ((idx 0)) - (assert (or (not result) (eq (car result) 'quote))) + (cl-assert (or (not result) (eq (car result) 'quote))) (setq eshell-last-command-status exit-code eshell-last-command-result (cadr result)) (while (< idx eshell-number-of-handles) diff --git a/lisp/eshell/esh-opt.el b/lisp/eshell/esh-opt.el index edb115b7f4f..fed2d8f1c62 100644 --- a/lisp/eshell/esh-opt.el +++ b/lisp/eshell/esh-opt.el @@ -106,7 +106,9 @@ interned variable `args' (created using a `let' form)." (and (listp opt) (nth 3 opt))) (cadr options))) '(usage-msg last-value ext-command args)) - (eshell-do-opt ,name ,options (quote ,body-forms))))) + ;; FIXME: `options' ends up hiding some variable names under `quote', + ;; which is incompatible with lexical scoping!! + (eshell-do-opt ,name ,options (lambda () ,@body-forms))))) ;;; Internal Functions: @@ -117,7 +119,7 @@ interned variable `args' (created using a `let' form)." ;; Documented part of the interface; see eshell-eval-using-options. (defvar args) -(defun eshell-do-opt (name options body-forms) +(defun eshell-do-opt (name options body-fun) "Helper function for `eshell-eval-using-options'. This code doesn't really need to be macro expanded everywhere." (setq args temp-args) @@ -133,8 +135,7 @@ This code doesn't really need to be macro expanded everywhere." (throw 'eshell-usage (eshell-show-usage name options))) (setq args (eshell-process-args name args options) - last-value (eval (append (list 'progn) - body-forms))) + last-value (funcall body-fun)) nil)) (error "%s" usage-msg)))) (throw 'eshell-external @@ -218,10 +219,8 @@ switch is unrecognized." found) (while opts (if (and (listp (car opts)) - (nth kind (car opts)) - (if (= kind 0) - (eq switch (nth kind (car opts))) - (string= switch (nth kind (car opts))))) + (nth kind (car opts)) + (equal switch (nth kind (car opts)))) (progn (eshell-set-option name ai (car opts) options) (setq found t opts nil)) diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el index 28984c2747d..6a0e159e82e 100644 --- a/lisp/eshell/esh-var.el +++ b/lisp/eshell/esh-var.el @@ -110,8 +110,8 @@ (eval-when-compile (require 'pcomplete) (require 'esh-util) - (require 'esh-opt) (require 'esh-mode)) +(require 'esh-opt) (require 'env) (require 'ring) diff --git a/lisp/eshell/eshell.el b/lisp/eshell/eshell.el index 0a200deee46..a1717756696 100644 --- a/lisp/eshell/eshell.el +++ b/lisp/eshell/eshell.el @@ -222,7 +222,7 @@ ;; things up. (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'esh-util)) (require 'esh-util) (require 'esh-mode) @@ -298,7 +298,7 @@ switches to the session with that number, creating it if necessary. A nonnumeric prefix arg means to create a new session. Returns the buffer selected (or created)." (interactive "P") - (assert eshell-buffer-name) + (cl-assert eshell-buffer-name) (let ((buf (cond ((numberp arg) (get-buffer-create (format "%s<%d>" eshell-buffer-name @@ -312,7 +312,7 @@ buffer selected (or created)." ;; window that that command was invoked from. To achieve this, ;; it's necessary to add `eshell-buffer-name' to the variable ;; `same-window-buffer-names', which is done when Eshell is loaded - (assert (and buf (buffer-live-p buf))) + (cl-assert (and buf (buffer-live-p buf))) (pop-to-buffer buf) (unless (eq major-mode 'eshell-mode) (eshell-mode)) @@ -380,11 +380,11 @@ With prefix ARG, insert output into the current buffer at point." (when intr (if (eshell-interactive-process) (eshell-wait-for-process (eshell-interactive-process))) - (assert (not (eshell-interactive-process))) + (cl-assert (not (eshell-interactive-process))) (goto-char (point-max)) (while (and (bolp) (not (bobp))) (delete-char -1))) - (assert (and buf (buffer-live-p buf))) + (cl-assert (and buf (buffer-live-p buf))) (unless arg (let ((len (if (not intr) 2 (count-lines (point-min) (point-max))))) @@ -424,7 +424,7 @@ corresponding to a successful execution." (list 'eshell-commands (list 'eshell-command-to-value (eshell-parse-command command))) t))) - (assert (eq (car result) 'quote)) + (cl-assert (eq (car result) 'quote)) (if (and status-var (symbolp status-var)) (set status-var eshell-last-command-status)) (cadr result)))))) diff --git a/lisp/hexl.el b/lisp/hexl.el index fcdef742cab..75094cd33b8 100644 --- a/lisp/hexl.el +++ b/lisp/hexl.el @@ -41,7 +41,7 @@ ;;; Code: (require 'eldoc) -(eval-when-compile (require 'cl)) ;For letf (default-value 'major-mode). +(eval-when-compile (require 'cl-lib)) ;; ;; vars here @@ -462,7 +462,7 @@ and edit the file in `hexl-mode'." (let ((completion-ignored-extensions nil)) (read-file-name "Filename: " nil nil 'ret-must-match)))) ;; Ignore the user's setting of default major-mode. - (letf (((default-value 'major-mode) 'fundamental-mode)) + (cl-letf (((default-value 'major-mode) 'fundamental-mode)) (find-file-literally filename)) (if (not (eq major-mode 'hexl-mode)) (hexl-mode))) diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el index 58d38f77b66..97df90a65af 100644 --- a/lisp/ibuf-ext.el +++ b/lisp/ibuf-ext.el @@ -35,7 +35,7 @@ (eval-when-compile (require 'ibuf-macs) - (require 'cl)) + (require 'cl-lib)) ;;; Utility functions (defun ibuffer-delete-alist (key alist) @@ -497,12 +497,12 @@ To evaluate a form without viewing the buffer, see `ibuffer-do-eval'." (defun ibuffer-included-in-filter-p-1 (buf filter) (not (not - (case (car filter) - (or + (pcase (car filter) + (`or (memq t (mapcar #'(lambda (x) (ibuffer-included-in-filter-p buf x)) (cdr filter)))) - (saved + (`saved (let ((data (assoc (cdr filter) ibuffer-saved-filters))) @@ -510,19 +510,13 @@ To evaluate a form without viewing the buffer, see `ibuffer-do-eval'." (ibuffer-filter-disable t) (error "Unknown saved filter %s" (cdr filter))) (ibuffer-included-in-filters-p buf (cadr data)))) - (t - (let ((filterdat (assq (car filter) - ibuffer-filtering-alist))) - ;; filterdat should be like (TYPE DESCRIPTION FUNC) - ;; just a sanity check - (unless filterdat - (ibuffer-filter-disable t) - (error "Undefined filter %s" (car filter))) - (not - (not - (funcall (caddr filterdat) - buf - (cdr filter)))))))))) + (_ + (pcase-let ((`(,_type ,_desc ,func) + (assq (car filter) ibuffer-filtering-alist))) + (unless func + (ibuffer-filter-disable t) + (error "Undefined filter %s" (car filter))) + (funcall func buf (cdr filter)))))))) (defun ibuffer-generate-filter-groups (bmarklist &optional noempty nodefault) (let ((filter-group-alist (if nodefault @@ -536,14 +530,14 @@ To evaluate a form without viewing the buffer, see `ibuffer-do-eval'." (i 0)) (dolist (filtergroup filter-group-alist) (let ((filterset (cdr filtergroup))) - (multiple-value-bind (hip-crowd lamers) - (values-list + (cl-multiple-value-bind (hip-crowd lamers) + (cl-values-list (ibuffer-split-list (lambda (bufmark) (ibuffer-included-in-filters-p (car bufmark) filterset)) bmarklist)) (aset vec i hip-crowd) - (incf i) + (cl-incf i) (setq bmarklist lamers)))) (let (ret) (dotimes (j i ret) @@ -689,7 +683,7 @@ See also `ibuffer-kill-filter-group'." (if (equal (car groups) group) (setq found t groups nil) - (incf res) + (cl-incf res) (setq groups (cdr groups)))) res))) (cond ((not found) @@ -810,12 +804,12 @@ turned into two separate filters [name: foo] and [mode: bar-mode]." (when (null ibuffer-filtering-qualifiers) (error "No filters in effect")) (let ((lim (pop ibuffer-filtering-qualifiers))) - (case (car lim) - (or + (pcase (car lim) + (`or (setq ibuffer-filtering-qualifiers (append (cdr lim) ibuffer-filtering-qualifiers))) - (saved + (`saved (let ((data (assoc (cdr lim) ibuffer-saved-filters))) @@ -825,10 +819,10 @@ turned into two separate filters [name: foo] and [mode: bar-mode]." (setq ibuffer-filtering-qualifiers (append (cadr data) ibuffer-filtering-qualifiers)))) - (not + (`not (push (cdr lim) ibuffer-filtering-qualifiers)) - (t + (_ (error "Filter type %s is not compound" (car lim))))) (ibuffer-update nil t)) @@ -960,13 +954,13 @@ Interactively, prompt for NAME, and use the current filters." (ibuffer-format-qualifier-1 qualifier))) (defun ibuffer-format-qualifier-1 (qualifier) - (case (car qualifier) - (saved + (pcase (car qualifier) + (`saved (concat " [filter: " (cdr qualifier) "]")) - (or + (`or (concat " [OR" (mapconcat #'ibuffer-format-qualifier (cdr qualifier) "") "]")) - (t + (_ (let ((type (assq (car qualifier) ibuffer-filtering-alist))) (unless qualifier (error "Ibuffer: bad qualifier %s" qualifier)) @@ -1414,14 +1408,14 @@ You can then feed the file name(s) to other commands with \\[yank]." (concat ibuffer-copy-filename-as-kill-result (let ((name (buffer-file-name buf))) (if name - (case type - (full + (pcase type + (`full name) - (relative + (`relative (file-relative-name name (or ibuffer-default-directory default-directory))) - (t + (_ (file-name-nondirectory name))) "")) " ")))) @@ -1550,13 +1544,8 @@ You can then feed the file name(s) to other commands with \\[yank]." (with-current-buffer buf ;; hacked from midnight.el (when buffer-display-time - (let* ((tm (current-time)) - (now (+ (* (float (ash 1 16)) (car tm)) - (float (cadr tm)) (* 0.0000001 (caddr tm)))) - (then (+ (* (float (ash 1 16)) - (car buffer-display-time)) - (float (cadr buffer-display-time)) - (* 0.0000001 (caddr buffer-display-time))))) + (let* ((now (float-time)) + (then (float-time buffer-display-time))) (> (- now then) (* 60 60 ibuffer-old-time)))))))) ;;;###autoload diff --git a/lisp/ibuf-macs.el b/lisp/ibuf-macs.el index 659b8e7d78c..ebf34c120e5 100644 --- a/lisp/ibuf-macs.el +++ b/lisp/ibuf-macs.el @@ -27,8 +27,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;; From Paul Graham's "ANSI Common Lisp", adapted for Emacs Lisp here. (defmacro ibuffer-aif (test true-body &rest false-body) @@ -73,7 +72,7 @@ During evaluation of body, bind `it' to the value returned by TEST." (ibuffer-redisplay t)))))) ;;;###autoload -(defmacro* define-ibuffer-column (symbol (&key name inline props summarizer +(cl-defmacro define-ibuffer-column (symbol (&key name inline props summarizer header-mouse-map) &rest body) "Define a column SYMBOL for use with `ibuffer-formats'. @@ -129,7 +128,7 @@ change its definition, you should explicitly call :autoload-end))) ;;;###autoload -(defmacro* define-ibuffer-sorter (name documentation +(cl-defmacro define-ibuffer-sorter (name documentation (&key description) &rest body) @@ -160,7 +159,7 @@ value if and only if `a' is \"less than\" `b'. :autoload-end)) ;;;###autoload -(defmacro* define-ibuffer-op (op args +(cl-defmacro define-ibuffer-op (op args documentation (&key interactive @@ -213,19 +212,19 @@ macro for exactly what it does. ,(if (not (null interactive)) `(interactive ,interactive) '(interactive)) - (assert (derived-mode-p 'ibuffer-mode)) + (cl-assert (derived-mode-p 'ibuffer-mode)) (setq ibuffer-did-modification nil) - (let ((marked-names (,(case mark + (let ((marked-names (,(pcase mark (:deletion 'ibuffer-deletion-marked-buffer-names) - (t + (_ 'ibuffer-marked-buffer-names))))) (when (null marked-names) (setq marked-names (list (buffer-name (ibuffer-current-buffer)))) - (ibuffer-set-mark ,(case mark + (ibuffer-set-mark ,(pcase mark (:deletion 'ibuffer-deletion-char) - (t + (_ 'ibuffer-marked-char)))) ,(let* ((finish (append '(progn) @@ -242,10 +241,10 @@ macro for exactly what it does. ,@body)) t))) (body `(let ((count - (,(case mark + (,(pcase mark (:deletion 'ibuffer-map-deletion-lines) - (t + (_ 'ibuffer-map-marked-lines)) #'(lambda (buf mark) ,(if (eq modifier-p :maybe) @@ -264,7 +263,7 @@ macro for exactly what it does. :autoload-end)) ;;;###autoload -(defmacro* define-ibuffer-filter (name documentation +(cl-defmacro define-ibuffer-filter (name documentation (&key reader description) diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el index adb7a12243a..33fab8c9948 100644 --- a/lisp/ibuffer.el +++ b/lisp/ibuffer.el @@ -31,7 +31,7 @@ ;;; Code: (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'ibuf-macs) (require 'dired)) @@ -1017,7 +1017,7 @@ width and the longest string in LIST." (when (get-text-property (point) 'ibuffer-title) (forward-line 1) (setq arg 1)) - (decf arg))) + (cl-decf arg))) (defun ibuffer-forward-line (&optional arg skip-group-names) "Move forward ARG lines, wrapping around the list if necessary." @@ -1032,7 +1032,7 @@ width and the longest string in LIST." (and skip-group-names (get-text-property (point) 'ibuffer-filter-group-name))) (when (> arg 0) - (decf arg)) + (cl-decf arg)) (ibuffer-skip-properties (append '(ibuffer-title) (when skip-group-names '(ibuffer-filter-group-name))) @@ -1045,7 +1045,7 @@ width and the longest string in LIST." (or (eobp) (get-text-property (point) 'ibuffer-summary))) (goto-char (point-min))) - (decf arg) + (cl-decf arg) (ibuffer-skip-properties (append '(ibuffer-title) (when skip-group-names '(ibuffer-filter-group-name))) @@ -1190,7 +1190,7 @@ a new window in the current frame, splitting vertically." (setq trying nil)) (error ;; Handle a failure - (if (or (> (incf attempts) 4) + (if (or (> (cl-incf attempts) 4) (and (stringp (cadr err)) ;; This definitely falls in the ;; ghetto hack category... @@ -1243,7 +1243,7 @@ a new window in the current frame, splitting vertically." (ibuffer-map-on-mark ibuffer-deletion-char func)) (defsubst ibuffer-assert-ibuffer-mode () - (assert (derived-mode-p 'ibuffer-mode))) + (cl-assert (derived-mode-p 'ibuffer-mode))) (defun ibuffer-buffer-file-name () (or buffer-file-name @@ -1504,11 +1504,11 @@ If point is on a group name, this function operates on that group." `(progn (setq tmp1 ,widthform tmp2 (/ tmp1 2)) - ,(case alignment + ,(pcase alignment (:right `(concat ,left ,right ,strvar)) (:center `(concat ,left ,strvar ,right)) (:left `(concat ,strvar ,left ,right)) - (t (error "Invalid alignment %s" alignment)))))) + (_ (error "Invalid alignment %s" alignment)))))) (defun ibuffer-compile-format (format) (let ((result nil) @@ -1529,7 +1529,7 @@ If point is on a group name, this function operates on that group." (max (nth 2 form)) (align (nth 3 form)) (elide (nth 4 form))) - (let* ((from-end-p (when (minusp min) + (let* ((from-end-p (when (cl-minusp min) (setq min (- min)) t)) (letbindings nil) @@ -1812,10 +1812,10 @@ If point is on a group name, this function operates on that group." (defun ibuffer-format-column (str width alignment) (let ((left (make-string (/ width 2) ?\s)) (right (make-string (- width (/ width 2)) ?\s))) - (case alignment + (pcase alignment (:right (concat left right str)) (:center (concat left str right)) - (t (concat str left right))))) + (_ (concat str left right))))) (defun ibuffer-buffer-name-face (buf mark) (cond ((char-equal mark ibuffer-marked-char) @@ -1913,18 +1913,18 @@ the buffer object itself and the current mark symbol." ;; `nil' if it chose not to affect the buffer ;; `kill' means the remove line from the buffer list ;; `t' otherwise - (incf ibuffer-map-lines-total) + (cl-incf ibuffer-map-lines-total) (cond ((null result) (forward-line 1)) ((eq result 'kill) (delete-region (line-beginning-position) (1+ (line-end-position))) - (incf ibuffer-map-lines-count) + (cl-incf ibuffer-map-lines-count) (when (< ibuffer-map-lines-total orig-target-line) - (decf target-line-offset))) + (cl-decf target-line-offset))) (t - (incf ibuffer-map-lines-count) + (cl-incf ibuffer-map-lines-count) (forward-line 1))))) ibuffer-map-lines-count) (progn @@ -2054,12 +2054,9 @@ the value of point at the beginning of the line for that buffer." (insert (if (stringp element) element - (let ((sym (car element)) - (min (cadr element)) - ;; (max (caddr element)) - (align (cadddr element))) + (pcase-let ((`(,sym ,min ,_max ,align) element)) ;; Ignore a negative min when we're inserting the title - (when (minusp min) + (when (cl-minusp min) (setq min (- min))) (let* ((name (or (get sym 'ibuffer-column-name) (error "Unknown column %s in ibuffer-formats" sym))) @@ -2107,24 +2104,23 @@ the value of point at the beginning of the line for that buffer." (insert (if (stringp element) (make-string (length element) ?\s) - (let ((sym (car element))) - (let ((min (cadr element)) - ;; (max (caddr element)) - (align (cadddr element))) - ;; Ignore a negative min when we're inserting the title - (when (minusp min) - (setq min (- min))) - (let* ((summary (if (get sym 'ibuffer-column-summarizer) - (funcall (get sym 'ibuffer-column-summarizer) - (get sym 'ibuffer-column-summary)) - (make-string (length (get sym 'ibuffer-column-name)) - ?\s))) - (len (length summary))) - (if (< len min) - (ibuffer-format-column summary - (- min len) - align) - summary))))))) + (pcase-let ((`(,sym ,min ,_max ,align) element)) + ;; Ignore a negative min when we're inserting the title. + (when (cl-minusp min) + (setq min (- min))) + (let* ((summary + (if (get sym 'ibuffer-column-summarizer) + (funcall (get sym 'ibuffer-column-summarizer) + (get sym 'ibuffer-column-summary)) + (make-string + (length (get sym 'ibuffer-column-name)) + ?\s))) + (len (length summary))) + (if (< len min) + (ibuffer-format-column summary + (- min len) + align) + summary)))))) (point)) `(ibuffer-summary t))))) @@ -2168,7 +2164,7 @@ If optional arg SILENT is non-nil, do not display progress messages." (eq ibuffer-always-show-last-buffer :nomini) (minibufferp (cadr bufs))) - (caddr bufs) + (cl-caddr bufs) (cadr bufs)) (ibuffer-current-buffers-with-marks bufs) ibuffer-display-maybe-show-predicates))) @@ -2200,7 +2196,7 @@ If optional arg SILENT is non-nil, do not display progress messages." (require 'ibuf-ext)) (let* ((sortdat (assq ibuffer-sorting-mode ibuffer-sorting-functions-alist)) - (func (caddr sortdat))) + (func (cl-caddr sortdat))) (let ((result ;; actually sort the buffers (if (and sortdat func) @@ -2574,11 +2570,11 @@ will be inserted before the group at point." ;; `ibuffer-update' puts this on header-line-format when needed. (setq ibuffer-header-line-format ;; Display the part that won't be in the mode-line. - (list* "" mode-name - (mapcar (lambda (elem) - (if (eq (car-safe elem) 'header-line-format) - (nth 2 elem) elem)) - mode-line-process))) + `("" ,mode-name + ,@(mapcar (lambda (elem) + (if (eq (car-safe elem) 'header-line-format) + (nth 2 elem) elem)) + mode-line-process))) (setq buffer-read-only t) (buffer-disable-undo) @@ -2645,7 +2641,7 @@ will be inserted before the group at point." ;;;;;; ibuffer-backward-filter-group ibuffer-forward-filter-group ;;;;;; ibuffer-toggle-filter-group ibuffer-mouse-toggle-filter-group ;;;;;; ibuffer-interactive-filter-by-mode ibuffer-mouse-filter-by-mode -;;;;;; ibuffer-auto-mode) "ibuf-ext" "ibuf-ext.el" "296999191b08d76d9763a8ebf510d5d8") +;;;;;; ibuffer-auto-mode) "ibuf-ext" "ibuf-ext.el" "c255d1ebe80ccabd8385f40bdd0b5451") ;;; Generated autoloads from ibuf-ext.el (autoload 'ibuffer-auto-mode "ibuf-ext" "\ diff --git a/lisp/image-dired.el b/lisp/image-dired.el index 9fc0a2cb51a..3659894f08d 100644 --- a/lisp/image-dired.el +++ b/lisp/image-dired.el @@ -157,7 +157,7 @@ (require 'widget) (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'wid-edit)) (defgroup image-dired nil @@ -653,21 +653,24 @@ previous -ARG, if ARG<0) files." (image-file (dired-get-filename nil t)) thumb-file overlay) - (when (and image-file (string-match-p (image-file-name-regexp) image-file)) + (when (and image-file + (string-match-p (image-file-name-regexp) image-file)) (setq thumb-file (image-dired-get-thumbnail-image image-file)) ;; If image is not already added, then add it. (let ((cur-ov (overlays-in (point) (1+ (point))))) (if cur-ov (delete-overlay (car cur-ov)) (put-image thumb-file image-pos) - (setq overlay (loop for o in (overlays-in (point) (1+ (point))) - when (overlay-get o 'put-image) collect o into ov - finally return (car ov))) + (setq overlay + (cl-loop for o in (overlays-in (point) (1+ (point))) + when (overlay-get o 'put-image) collect o into ov + finally return (car ov))) (overlay-put overlay 'image-file image-file) (overlay-put overlay 'thumb-file thumb-file))))) arg ; Show or hide image on ARG next files. 'show-progress) ; Update dired display after each image is updated. - (add-hook 'dired-after-readin-hook 'image-dired-dired-after-readin-hook nil t)) + (add-hook 'dired-after-readin-hook + 'image-dired-dired-after-readin-hook nil t)) (defun image-dired-dired-after-readin-hook () "Relocate existing thumbnail overlays in dired buffer after reverting. diff --git a/lisp/mail/feedmail.el b/lisp/mail/feedmail.el index df18abbc532..c6d1d228780 100644 --- a/lisp/mail/feedmail.el +++ b/lisp/mail/feedmail.el @@ -372,8 +372,7 @@ (require 'mail-utils) ; pick up mail-strip-quoted-names (eval-when-compile - (require 'smtpmail) - (require 'cl)) + (require 'smtpmail)) (autoload 'mail-do-fcc "sendmail") @@ -1951,9 +1950,6 @@ bail out with an appropriate answer to the global confirmation prompt." (feedmail-say-debug ">in-> feedmail-run-the-queue-global-prompts") (let ((feedmail-queue-runner-confirm-global t)) (feedmail-run-the-queue arg))) -;; letf fools the byte-compiler. -(defvar file-name-buffer-file-type-alist) - ;;;###autoload (defun feedmail-run-the-queue (&optional arg) "Visit each message in the feedmail queue directory and send it out. @@ -2392,8 +2388,10 @@ mapped to mostly alphanumerics for safety." (defun feedmail-send-it-immediately () "Handle immediate sending, including during a queue run." (feedmail-say-debug ">in-> feedmail-send-it-immediately") - (let ((feedmail-error-buffer (get-buffer-create " *FQM Outgoing Email Errors*")) - (feedmail-prepped-text-buffer (get-buffer-create " *FQM Outgoing Email Text*")) + (let ((feedmail-error-buffer + (get-buffer-create " *FQM Outgoing Email Errors*")) + (feedmail-prepped-text-buffer + (get-buffer-create " *FQM Outgoing Email Text*")) (feedmail-raw-text-buffer (current-buffer)) (feedmail-address-list) (eoh-marker) @@ -2405,7 +2403,7 @@ mapped to mostly alphanumerics for safety." (a-re-dtcb "^\\(To\\|Cc\\|Bcc\\):") (a-re-dtc "^\\(To\\|Cc\\):") (a-re-db "^Bcc:") - ;; to get a temporary changeable copy + ;; To get a temporary changeable copy. (mail-header-separator mail-header-separator) ) (unwind-protect @@ -2413,10 +2411,10 @@ mapped to mostly alphanumerics for safety." (set-buffer feedmail-error-buffer) (erase-buffer) (set-buffer feedmail-prepped-text-buffer) (erase-buffer) - ;; jam contents of user-supplied mail buffer into our scratch buffer + ;; Jam contents of user-supplied mail buffer into our scratch buffer. (insert-buffer-substring feedmail-raw-text-buffer) - ;; require one newline at the end. + ;; Require one newline at the end. (goto-char (point-max)) (or (= (preceding-char) ?\n) (insert ?\n)) @@ -2437,54 +2435,69 @@ mapped to mostly alphanumerics for safety." (and (fboundp 'expand-mail-aliases) mail-aliases)) (expand-mail-aliases (point-min) eoh-marker)) - ;; make it pretty + ;; Make it pretty. (if feedmail-fill-to-cc (feedmail-fill-to-cc-function eoh-marker)) - ;; ignore any blank lines in the header + ;; Ignore any blank lines in the header. (goto-char (point-min)) - (while (and (re-search-forward "\n\n\n*" eoh-marker t) (< (point) eoh-marker)) + (while (and (re-search-forward "\n\n\n*" eoh-marker t) + (< (point) eoh-marker)) (replace-match "\n")) (let ((case-fold-search t) (addr-regexp)) (goto-char (point-min)) - ;; there are some RFC-822 combinations/cases missed here, - ;; but probably good enough and what users expect + ;; There are some RFC-822 combinations/cases missed here, + ;; but probably good enough and what users expect. ;; - ;; use resent-* stuff only if there is at least one non-empty one + ;; Use resent-* stuff only if there is at least one non-empty one. (setq feedmail-is-a-resend (re-search-forward - ;; header name, followed by optional whitespace, followed by - ;; non-whitespace, followed by anything, followed by newline; - ;; the idea is empty Resent-* headers are ignored + ;; Header name, followed by optional whitespace, followed by + ;; non-whitespace, followed by anything, followed by + ;; newline; the idea is empty Resent-* headers are ignored. "^\\(Resent-To:\\|Resent-Cc:\\|Resent-Bcc:\\)\\s-*\\S-+.*$" eoh-marker t)) - ;; if we say so, gather the Bcc stuff before the main course - (if (eq feedmail-deduce-bcc-where 'first) - (progn (if feedmail-is-a-resend (setq addr-regexp a-re-rb) (setq addr-regexp a-re-db)) - (setq feedmail-address-list (feedmail-deduce-address-list feedmail-prepped-text-buffer (point-min) eoh-marker addr-regexp feedmail-address-list)))) - ;; the main course - (if (or (eq feedmail-deduce-bcc-where 'first) (eq feedmail-deduce-bcc-where 'last)) - ;; handled by first or last cases, so don't get Bcc stuff - (progn (if feedmail-is-a-resend (setq addr-regexp a-re-rtc) (setq addr-regexp a-re-dtc)) - (setq feedmail-address-list (feedmail-deduce-address-list feedmail-prepped-text-buffer (point-min) eoh-marker addr-regexp feedmail-address-list))) - ;; not handled by first or last cases, so also get Bcc stuff - (progn (if feedmail-is-a-resend (setq addr-regexp a-re-rtcb) (setq addr-regexp a-re-dtcb)) - (setq feedmail-address-list (feedmail-deduce-address-list feedmail-prepped-text-buffer (point-min) eoh-marker addr-regexp feedmail-address-list)))) - ;; if we say so, gather the Bcc stuff after the main course - (if (eq feedmail-deduce-bcc-where 'last) - (progn (if feedmail-is-a-resend (setq addr-regexp a-re-rb) (setq addr-regexp a-re-db)) - (setq feedmail-address-list (feedmail-deduce-address-list feedmail-prepped-text-buffer (point-min) eoh-marker addr-regexp feedmail-address-list)))) - (if (not feedmail-address-list) (error "FQM: Sending...abandoned, no addressees")) - ;; not needed, but meets user expectations + ;; If we say so, gather the Bcc stuff before the main course. + (when (eq feedmail-deduce-bcc-where 'first) + (setq addr-regexp (if feedmail-is-a-resend a-re-rb a-re-db)) + (setq feedmail-address-list + (feedmail-deduce-address-list + feedmail-prepped-text-buffer (point-min) eoh-marker + addr-regexp feedmail-address-list))) + ;; The main course. + (setq addr-regexp + (if (memq feedmail-deduce-bcc-where '(first last)) + ;; Handled by first or last cases, so don't get + ;; Bcc stuff. + (if feedmail-is-a-resend a-re-rtc a-re-dtc) + ;; Not handled by first or last cases, so also get + ;; Bcc stuff. + (if feedmail-is-a-resend a-re-rtcb a-re-dtcb))) + (setq feedmail-address-list + (feedmail-deduce-address-list + feedmail-prepped-text-buffer (point-min) eoh-marker + addr-regexp feedmail-address-list)) + ;; If we say so, gather the Bcc stuff after the main course. + (when (eq feedmail-deduce-bcc-where 'last) + (setq addr-regexp (if feedmail-is-a-resend a-re-rb a-re-db)) + (setq feedmail-address-list + (feedmail-deduce-address-list + feedmail-prepped-text-buffer (point-min) eoh-marker + addr-regexp feedmail-address-list))) + (if (not feedmail-address-list) + (error "FQM: Sending...abandoned, no addressees")) + ;; Not needed, but meets user expectations. (setq feedmail-address-list (nreverse feedmail-address-list)) ;; Find and handle any Bcc fields. - (setq bcc-holder (feedmail-accume-n-nuke-header eoh-marker "^Bcc:")) - (setq resent-bcc-holder (feedmail-accume-n-nuke-header eoh-marker "^Resent-Bcc:")) - (if (and bcc-holder (not feedmail-nuke-bcc)) - (progn (goto-char (point-min)) - (insert bcc-holder))) - (if (and resent-bcc-holder (not feedmail-nuke-resent-bcc)) - (progn (goto-char (point-min)) - (insert resent-bcc-holder))) + (setq bcc-holder + (feedmail-accume-n-nuke-header eoh-marker "^Bcc:")) + (setq resent-bcc-holder + (feedmail-accume-n-nuke-header eoh-marker "^Resent-Bcc:")) + (when (and bcc-holder (not feedmail-nuke-bcc)) + (goto-char (point-min)) + (insert bcc-holder)) + (when (and resent-bcc-holder (not feedmail-nuke-resent-bcc)) + (goto-char (point-min)) + (insert resent-bcc-holder)) (goto-char (point-min)) ;; fiddle about, fiddle about, fiddle about.... @@ -2492,16 +2505,20 @@ mapped to mostly alphanumerics for safety." (feedmail-fiddle-sender) (feedmail-fiddle-x-mailer) (feedmail-fiddle-message-id - (or feedmail-queue-runner-is-active (buffer-file-name feedmail-raw-text-buffer))) + (or feedmail-queue-runner-is-active + (buffer-file-name feedmail-raw-text-buffer))) (feedmail-fiddle-date - (or feedmail-queue-runner-is-active (buffer-file-name feedmail-raw-text-buffer))) - (feedmail-fiddle-list-of-fiddle-plexes feedmail-fiddle-plex-user-list) + (or feedmail-queue-runner-is-active + (buffer-file-name feedmail-raw-text-buffer))) + (feedmail-fiddle-list-of-fiddle-plexes + feedmail-fiddle-plex-user-list) ;; don't send out a blank headers of various sorts ;; (this loses on continued line with a blank first line) (goto-char (point-min)) (and feedmail-nuke-empty-headers ; hey, who's an empty-header? - (while (re-search-forward "^[A-Za-z0-9-]+:[ \t]*\n" eoh-marker t) + (while (re-search-forward "^[A-Za-z0-9-]+:[ \t]*\n" + eoh-marker t) (replace-match "")))) (feedmail-say-debug "last chance hook: %s" feedmail-last-chance-hook) @@ -2513,79 +2530,90 @@ mapped to mostly alphanumerics for safety." (confirm (cond ((eq feedmail-confirm-outgoing 'immediate) (not feedmail-queue-runner-is-active)) - ((eq feedmail-confirm-outgoing 'queued) feedmail-queue-runner-is-active) + ((eq feedmail-confirm-outgoing 'queued) + feedmail-queue-runner-is-active) (t feedmail-confirm-outgoing))) (fullframe (cond ((eq feedmail-display-full-frame 'immediate) (not feedmail-queue-runner-is-active)) - ((eq feedmail-display-full-frame 'queued) feedmail-queue-runner-is-active) + ((eq feedmail-display-full-frame 'queued) + feedmail-queue-runner-is-active) (t feedmail-display-full-frame)))) (if fullframe (progn (switch-to-buffer feedmail-prepped-text-buffer t) (delete-other-windows))) - (if (or (not confirm) (feedmail-one-last-look feedmail-prepped-text-buffer)) - (let ((user-mail-address (feedmail-envelope-deducer eoh-marker))) + (if (or (not confirm) + (feedmail-one-last-look feedmail-prepped-text-buffer)) + (let ((user-mail-address + (feedmail-envelope-deducer eoh-marker))) (feedmail-say-debug "give it to buffer-eater") (feedmail-give-it-to-buffer-eater) (feedmail-say-debug "gave it to buffer-eater") - (if (and (not feedmail-queue-runner-is-active) (setq also-file (buffer-file-name feedmail-raw-text-buffer))) - (progn ; if a file but not running the queue, offer to delete it + (if (and (not feedmail-queue-runner-is-active) + (setq also-file + (buffer-file-name feedmail-raw-text-buffer))) + (progn + ;; If a file but not running the queue, + ;; offer to delete it (setq also-file (expand-file-name also-file)) (when (or feedmail-queue-auto-file-nuke (y-or-n-p (format "FQM: Delete message file %s? " also-file))) - ;; if we delete the affiliated file, get rid + ;; If we delete the affiliated file, get rid ;; of the file name association and make sure we - ;; don't annoy people with a prompt on exit + ;; don't annoy people with a prompt on exit. (delete-file also-file) (with-current-buffer feedmail-raw-text-buffer (setq buffer-offer-save nil) (setq buffer-file-name nil))))) (goto-char (point-min)) - ;; re-insert and handle any Fcc fields (and, optionally, any Bcc). - (if fcc (letf (((default-value 'buffer-file-type) - feedmail-force-binary-write)) - (insert fcc) - (if (not feedmail-nuke-bcc-in-fcc) - (progn (if bcc-holder (insert bcc-holder)) - (if resent-bcc-holder (insert resent-bcc-holder)))) - - (run-hooks 'feedmail-before-fcc-hook) - - (if feedmail-nuke-body-in-fcc - (progn (goto-char eoh-marker) - (if (natnump feedmail-nuke-body-in-fcc) - (forward-line feedmail-nuke-body-in-fcc)) - (delete-region (point) (point-max)) - )) - (mail-do-fcc eoh-marker) - ))) - ;; user bailed out of one-last-look + ;; Re-insert and handle any Fcc fields (and, optionally, + ;; any Bcc). + (when fcc + (let ((old (default-value 'buffer-file-type))) + (unwind-protect + (progn + (setq-default buffer-file-type + feedmail-force-binary-write) + (insert fcc) + (unless feedmail-nuke-bcc-in-fcc + (if bcc-holder (insert bcc-holder)) + (if resent-bcc-holder + (insert resent-bcc-holder))) + + (run-hooks 'feedmail-before-fcc-hook) + + (when feedmail-nuke-body-in-fcc + (goto-char eoh-marker) + (if (natnump feedmail-nuke-body-in-fcc) + (forward-line feedmail-nuke-body-in-fcc)) + (delete-region (point) (point-max))) + (mail-do-fcc eoh-marker)) + (setq-default buffer-file-type old))))) + ;; User bailed out of one-last-look. (if feedmail-queue-runner-is-active (throw 'skip-me-q 'skip-me-q) (throw 'skip-me-i 'skip-me-i)) )))) ; unwind-protect body (save-excursion) - ;; unwind-protect cleanup forms + ;; unwind-protect cleanup forms. (kill-buffer feedmail-prepped-text-buffer) (set-buffer feedmail-error-buffer) (if (zerop (buffer-size)) (kill-buffer feedmail-error-buffer) - (progn (display-buffer feedmail-error-buffer) - ;; read fast ... the meter is running - (if feedmail-queue-runner-is-active - (progn - (ding t) - (feedmail-say-chatter "Sending...failed"))) - (error "FQM: Sending...failed"))) + (display-buffer feedmail-error-buffer) + ;; Read fast ... the meter is running. + (if feedmail-queue-runner-is-active + (progn + (ding t) + (feedmail-say-chatter "Sending...failed"))) + (error "FQM: Sending...failed")) (set-buffer feedmail-raw-text-buffer)) ) ; let - (if (and feedmail-queue-chatty (not feedmail-queue-runner-is-active)) - (progn - (feedmail-queue-reminder 'after-immediate) - (sit-for feedmail-queue-chatty-sit-for))) - ) + (when (and feedmail-queue-chatty (not feedmail-queue-runner-is-active)) + (feedmail-queue-reminder 'after-immediate) + (sit-for feedmail-queue-chatty-sit-for))) (defun feedmail-fiddle-header (name value &optional action folding) diff --git a/lisp/mail/footnote.el b/lisp/mail/footnote.el index f0c6b21513e..e342e0ae977 100644 --- a/lisp/mail/footnote.el +++ b/lisp/mail/footnote.el @@ -35,9 +35,8 @@ ;;; Code: -(eval-when-compile - (require 'cl) - (defvar filladapt-token-table)) +(eval-when-compile (require 'cl-lib)) +(defvar filladapt-token-table) (defgroup footnote nil "Support for footnotes in mail and news messages." @@ -644,12 +643,12 @@ If the variable `footnote-narrow-to-footnotes-when-editing' is set, the buffer is narrowed to the footnote body. The restriction is removed by using `Footnote-back-to-message'." (interactive "*P") - (let (num) - (if footnote-text-marker-alist - (if (< (point) (cadar (last footnote-pointer-marker-alist))) - (setq num (Footnote-make-hole)) - (setq num (1+ (caar (last footnote-text-marker-alist))))) - (setq num 1)) + (let ((num + (if footnote-text-marker-alist + (if (< (point) (cl-cadar (last footnote-pointer-marker-alist))) + (Footnote-make-hole) + (1+ (caar (last footnote-text-marker-alist)))) + 1))) (message "Adding footnote %d" num) (Footnote-insert-footnote num) (insert-before-markers (make-string footnote-body-tag-spacing ? )) diff --git a/lisp/mail/mailheader.el b/lisp/mail/mailheader.el index 1c917a05dfb..6adcb25904b 100644 --- a/lisp/mail/mailheader.el +++ b/lisp/mail/mailheader.el @@ -45,9 +45,6 @@ ;;; Code: -(eval-when-compile - (require 'cl)) - (defun mail-header-extract () "Extract headers from current buffer after point. Returns a header alist, where each element is a cons cell (name . value), @@ -110,6 +107,8 @@ If the value is a string, it is the original value of the header. If the value is a list, its first element is the original value of the header, with any subsequent elements being the result of parsing the value. If HEADER-ALIST is nil, the dynamically bound variable `headers' is used." + (declare (gv-setter (lambda (value) + `(mail-header-set ,header ,value ,header-alist)))) (cdr (assq header (or header-alist headers)))) (defun mail-header-set (header value &optional header-alist) @@ -123,9 +122,6 @@ See `mail-header' for the semantics of VALUE." (nconc alist (list (cons header value))))) value) -(defsetf mail-header (header &optional header-alist) (value) - `(mail-header-set ,header ,value ,header-alist)) - (defun mail-header-merge (merge-rules headers) "Return a new header alist with MERGE-RULES applied to HEADERS. MERGE-RULES is an alist whose keys are header names (symbols) and whose diff --git a/lisp/man.el b/lisp/man.el index ca7df4cd1a4..6f437c017b3 100644 --- a/lisp/man.el +++ b/lisp/man.el @@ -88,7 +88,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'button) ;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv @@ -989,41 +988,41 @@ Return the buffer in which the manpage will appear." See the variable `Man-notify-method' for the different notification behaviors." (let ((saved-frame (with-current-buffer man-buffer Man-original-frame))) - (case Man-notify-method - (newframe - ;; Since we run asynchronously, perhaps while Emacs is waiting - ;; for input, we must not leave a different buffer current. We - ;; can't rely on the editor command loop to reselect the - ;; selected window's buffer. - (save-excursion - (let ((frame (make-frame Man-frame-parameters))) - (set-window-buffer (frame-selected-window frame) man-buffer) - (set-window-dedicated-p (frame-selected-window frame) t) - (or (display-multi-frame-p frame) - (select-frame frame))))) - (pushy - (switch-to-buffer man-buffer)) - (bully - (and (frame-live-p saved-frame) - (select-frame saved-frame)) - (pop-to-buffer man-buffer) - (delete-other-windows)) - (aggressive - (and (frame-live-p saved-frame) - (select-frame saved-frame)) - (pop-to-buffer man-buffer)) - (friendly - (and (frame-live-p saved-frame) - (select-frame saved-frame)) - (display-buffer man-buffer 'not-this-window)) - (polite - (beep) - (message "Manual buffer %s is ready" (buffer-name man-buffer))) - (quiet - (message "Manual buffer %s is ready" (buffer-name man-buffer))) - (t ;; meek - (message "")) - ))) + (pcase Man-notify-method + (`newframe + ;; Since we run asynchronously, perhaps while Emacs is waiting + ;; for input, we must not leave a different buffer current. We + ;; can't rely on the editor command loop to reselect the + ;; selected window's buffer. + (save-excursion + (let ((frame (make-frame Man-frame-parameters))) + (set-window-buffer (frame-selected-window frame) man-buffer) + (set-window-dedicated-p (frame-selected-window frame) t) + (or (display-multi-frame-p frame) + (select-frame frame))))) + (`pushy + (switch-to-buffer man-buffer)) + (`bully + (and (frame-live-p saved-frame) + (select-frame saved-frame)) + (pop-to-buffer man-buffer) + (delete-other-windows)) + (`aggressive + (and (frame-live-p saved-frame) + (select-frame saved-frame)) + (pop-to-buffer man-buffer)) + (`friendly + (and (frame-live-p saved-frame) + (select-frame saved-frame)) + (display-buffer man-buffer 'not-this-window)) + (`polite + (beep) + (message "Manual buffer %s is ready" (buffer-name man-buffer))) + (`quiet + (message "Manual buffer %s is ready" (buffer-name man-buffer))) + (_ ;; meek + (message "")) + ))) (defun Man-softhyphen-to-minus () ;; \255 is SOFT HYPHEN in Latin-N. Versions of Debian man, at @@ -1061,14 +1060,14 @@ Same for the ANSI bold and normal escape sequences." (setq faces (cond ((match-beginning 2) - (delq (case (char-after (match-beginning 2)) + (delq (pcase (char-after (match-beginning 2)) (?2 Man-overstrike-face) (?4 Man-underline-face) (?7 Man-reverse-face)) faces)) ((eq (char-after (match-beginning 1)) ?0) nil) (t - (cons (case (char-after (match-beginning 1)) + (cons (pcase (char-after (match-beginning 1)) (?1 Man-overstrike-face) (?4 Man-underline-face) (?7 Man-reverse-face)) diff --git a/lisp/midnight.el b/lisp/midnight.el index 3c0923d7e58..40e66b8ce9b 100644 --- a/lisp/midnight.el +++ b/lisp/midnight.el @@ -36,8 +36,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defgroup midnight nil "Run something every day at midnight." @@ -138,9 +137,9 @@ two lists will NOT be killed if it also matches anything in this list." (defun midnight-find (el ls test &optional key) "A stopgap solution to the absence of `find' in ELisp." - (dolist (rr ls) + (cl-dolist (rr ls) (when (funcall test (if key (funcall key rr) rr) el) - (return rr)))) + (cl-return rr)))) (defun clean-buffer-list-delay (name) "Return the delay, in seconds, before killing a buffer named NAME. @@ -196,8 +195,7 @@ The default value is `clean-buffer-list'." (defun midnight-next () "Return the number of seconds till the next midnight." - (multiple-value-bind (sec min hrs) - (values-list (decode-time)) + (pcase-let ((`(,sec ,min ,hrs) (decode-time))) (- (* 24 60 60) (* 60 60 hrs) (* 60 min) sec))) ;;;###autoload @@ -205,8 +203,8 @@ The default value is `clean-buffer-list'." "Modify `midnight-timer' according to `midnight-delay'. Sets the first argument SYMB (which must be symbol `midnight-delay') to its second argument TM." - (assert (eq symb 'midnight-delay) t - "Invalid argument to `midnight-delay-set': `%s'") + (cl-assert (eq symb 'midnight-delay) t + "Invalid argument to `midnight-delay-set': `%s'") (set symb tm) (when (timerp midnight-timer) (cancel-timer midnight-timer)) (setq midnight-timer diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index f4e7e942931..20d71215926 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -205,8 +205,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Variables -(eval-when-compile (require 'cl)) - (defgroup browse-url nil "Use a web browser to look at a URL." :prefix "browse-url-" @@ -1621,22 +1619,21 @@ from `browse-url-elinks-wrapper'." (defun browse-url-elinks-sentinel (process url) "Determines if Elinks is running or a new one has to be started." - (let ((exit-status (process-exit-status process))) - ;; Try to determine if an instance is running or if we have to - ;; create a new one. - (case exit-status - (5 - ;; No instance, start a new one. - (browse-url-elinks-new-window url)) - (0 - ;; Found an instance, open URL in new tab. - (let ((process-environment (browse-url-process-environment))) - (start-process (concat "elinks:" url) nil - "elinks" "-remote" - (concat "openURL(\"" url "\",new-tab)")))) - (otherwise - (error "Unrecognized exit-code %d of process `elinks'" - exit-status))))) + ;; Try to determine if an instance is running or if we have to + ;; create a new one. + (pcase (process-exit-status process) + (5 + ;; No instance, start a new one. + (browse-url-elinks-new-window url)) + (0 + ;; Found an instance, open URL in new tab. + (let ((process-environment (browse-url-process-environment))) + (start-process (concat "elinks:" url) nil + "elinks" "-remote" + (concat "openURL(\"" url "\",new-tab)")))) + (exit-status + (error "Unrecognized exit-code %d of process `elinks'" + exit-status)))) (provide 'browse-url) diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el index 9bd01806d24..0e9707e57f3 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el @@ -48,9 +48,7 @@ (eval-and-compile (if (not (fboundp 'make-overlay)) - (require 'overlay)) - (if (not (fboundp 'unless)) - (require 'cl))) + (require 'overlay))) (unless (fboundp 'custom-menu-create) (autoload 'custom-menu-create "cus-edit")) diff --git a/lisp/net/ldap.el b/lisp/net/ldap.el index 941b6d7787c..eb696798b6f 100644 --- a/lisp/net/ldap.el +++ b/lisp/net/ldap.el @@ -34,7 +34,6 @@ ;;; Code: (require 'custom) -(eval-when-compile (require 'cl)) (autoload 'auth-source-search "auth-source") @@ -465,12 +464,12 @@ Additional search parameters can be specified through (error "No LDAP host specified")) (let ((host-plist (cdr (assoc host ldap-host-parameters-alist))) result) - (setq result (ldap-search-internal (list* 'host host - 'filter filter - 'attributes attributes - 'attrsonly attrsonly - 'withdn withdn - host-plist))) + (setq result (ldap-search-internal `(host ,host + filter ,filter + attributes ,attributes + attrsonly ,attrsonly + withdn ,withdn + ,@host-plist))) (if ldap-ignore-attribute-codings result (mapcar (lambda (record) diff --git a/lisp/net/mairix.el b/lisp/net/mairix.el index a8e969a18c5..f85983e6e9f 100644 --- a/lisp/net/mairix.el +++ b/lisp/net/mairix.el @@ -70,8 +70,6 @@ (require 'widget) (require 'cus-edit) -(eval-when-compile - (require 'cl)) ;;; Keymappings diff --git a/lisp/net/quickurl.el b/lisp/net/quickurl.el index b0bfe5b271c..f3b0e372de4 100644 --- a/lisp/net/quickurl.el +++ b/lisp/net/quickurl.el @@ -81,8 +81,7 @@ ;; Things we need: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'thingatpt) (require 'pp) (require 'browse-url) @@ -206,47 +205,40 @@ in your ~/.emacs (after loading/requiring quickurl).") (list keyword url comment) (cons keyword url))) -(defun quickurl-url-keyword (url) +(defalias 'quickurl-url-keyword #'car "Return the keyword for the URL. - -Note that this function is a setfable place." - (car url)) - -(defsetf quickurl-url-keyword (url) (store) - `(setf (car ,url) ,store)) +\n\(fn URL)") (defun quickurl-url-url (url) "Return the actual URL of the URL. Note that this function is a setfable place." + (declare (gv-setter (lambda (store) + `(setf (if (quickurl-url-commented-p ,url) + (cadr ,url) + (cdr ,url)) + ,store)))) (if (quickurl-url-commented-p url) (cadr url) (cdr url))) -(defsetf quickurl-url-url (url) (store) - ` - (if (quickurl-url-commented-p ,url) - (setf (cadr ,url) ,store) - (setf (cdr ,url) ,store))) - (defun quickurl-url-comment (url) "Get the comment from a URL. If the URL has no comment an empty string is returned. Also note that this function is a setfable place." + (declare + (gv-setter (lambda (store) + `(if (quickurl-url-commented-p ,url) + (if (zerop (length ,store)) + (setf (cdr ,url) (cadr ,url)) + (setf (nth 2 ,url) ,store)) + (unless (zerop (length ,store)) + (setf (cdr ,url) (list (cdr ,url) ,store))))))) (if (quickurl-url-commented-p url) (nth 2 url) "")) -(defsetf quickurl-url-comment (url) (store) - ` - (if (quickurl-url-commented-p ,url) - (if (zerop (length ,store)) - (setf (cdr ,url) (cadr ,url)) - (setf (nth 2 ,url) ,store)) - (unless (zerop (length ,store)) - (setf (cdr ,url) (list (cdr ,url) ,store))))) - (defun quickurl-url-description (url) "Return a description for the URL. @@ -259,14 +251,14 @@ returned." ;; Main code: -(defun* quickurl-read (&optional buffer) +(cl-defun quickurl-read (&optional buffer) "`read' the URL list from BUFFER into `quickurl-urls'. BUFFER, if nil, defaults to current buffer. Note that this function moves point to `point-min' before doing the `read' It also restores point after the `read'." (save-excursion - (setf (point) (point-min)) + (goto-char (point-min)) (setq quickurl-urls (funcall quickurl-sort-function (read (or buffer (current-buffer))))))) @@ -303,7 +295,7 @@ Also display a `message' saying what the URL was unless SILENT is non-nil." (message "Found %s" (quickurl-url-url url)))) ;;;###autoload -(defun* quickurl (&optional lookup) +(cl-defun quickurl (&optional lookup) "Insert a URL based on LOOKUP. If not supplied LOOKUP is taken to be the word at point in the current @@ -464,20 +456,21 @@ The key bindings for `quickurl-list-mode' are: (defun quickurl-list-populate-buffer () "Populate the `quickurl-list' buffer." (with-current-buffer (get-buffer quickurl-list-buffer-name) - (let ((buffer-read-only nil) - (fmt (format "%%-%ds %%s\n" - (apply #'max (or (loop for url in quickurl-urls - collect (length (quickurl-url-description url))) - (list 20)))))) - (setf (buffer-string) "") - (loop for url in quickurl-urls - do (let ((start (point))) - (insert (format fmt (quickurl-url-description url) - (quickurl-url-url url))) - (add-text-properties start (1- (point)) - '(mouse-face highlight - help-echo "mouse-2: insert this URL")))) - (setf (point) (point-min))))) + (let* ((sizes (or (cl-loop for url in quickurl-urls + collect (length (quickurl-url-description url))) + (list 20))) + (fmt (format "%%-%ds %%s\n" (apply #'max sizes))) + (inhibit-read-only t)) + (erase-buffer) + (cl-loop for url in quickurl-urls + do (let ((start (point))) + (insert (format fmt (quickurl-url-description url) + (quickurl-url-url url))) + (add-text-properties + start (1- (point)) + '(mouse-face highlight + help-echo "mouse-2: insert this URL")))) + (goto-char (point-min))))) (defun quickurl-list-add-url (word url comment) "Wrapper for `quickurl-add-url' that doesn't guess the parameters." @@ -494,7 +487,7 @@ The key bindings for `quickurl-list-mode' are: (defun quickurl-list-mouse-select (event) "Select the URL under the mouse click." (interactive "e") - (setf (point) (posn-point (event-end event))) + (goto-char (posn-point (event-end event))) (quickurl-list-insert-url)) (defun quickurl-list-insert (type) @@ -510,16 +503,16 @@ TYPE dictates what will be inserted, options are: (if url (with-current-buffer quickurl-list-last-buffer (insert - (case type - (url (funcall quickurl-format-function url)) - (naked-url (quickurl-url-url url)) - (with-lookup (format "%s <URL:%s>" + (pcase type + (`url (funcall quickurl-format-function url)) + (`naked-url (quickurl-url-url url)) + (`with-lookup (format "%s <URL:%s>" (quickurl-url-keyword url) (quickurl-url-url url))) - (with-desc (format "%S <URL:%s>" + (`with-desc (format "%S <URL:%s>" (quickurl-url-description url) (quickurl-url-url url))) - (lookup (quickurl-url-keyword url))))) + (`lookup (quickurl-url-keyword url))))) (error "No URL details on that line")) url)) diff --git a/lisp/net/secrets.el b/lisp/net/secrets.el index 7833ef679d4..96b74b2f8e2 100644 --- a/lisp/net/secrets.el +++ b/lisp/net/secrets.el @@ -142,8 +142,7 @@ ;; Pacify byte-compiler. D-Bus support in the Emacs core can be ;; disabled with configuration option "--without-dbus". Declare used ;; subroutines and variables of `dbus' therefore. -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defvar dbus-debug) @@ -648,7 +647,7 @@ If there is no such item, return nil." (let ((item-path (secrets-item-path collection item))) (unless (secrets-empty-path item-path) (dbus-byte-array-to-string - (caddr + (cl-caddr (dbus-call-method :session secrets-service item-path secrets-interface-item "GetSecret" :object-path secrets-session-path)))))) diff --git a/lisp/net/snmp-mode.el b/lisp/net/snmp-mode.el index d3e5759d2fb..c155d53b6d0 100644 --- a/lisp/net/snmp-mode.el +++ b/lisp/net/snmp-mode.el @@ -85,7 +85,6 @@ ;;; Code: (eval-when-compile - (require 'cl) (require 'imenu) ; Need this stuff when compiling for imenu macros, etc. (require 'tempo)) diff --git a/lisp/net/xesam.el b/lisp/net/xesam.el index 82922e61084..585e5eed52d 100644 --- a/lisp/net/xesam.el +++ b/lisp/net/xesam.el @@ -129,10 +129,6 @@ (require 'dbus) -;; Pacify byte compiler. -(eval-when-compile - (require 'cl)) - ;; Widgets are used to highlight the search results. (require 'widget) (require 'wid-edit) @@ -409,24 +405,24 @@ If there is no registered search engine at all, the function returns `nil'." ;; That is not the case now, so we set it ourselves. ;; Hopefully, this will change later. (setq hit-fields - (case (intern vendor-id) - (Beagle + (pcase (intern vendor-id) + (`Beagle '("xesam:mimeType" "xesam:url")) - (Strigi + (`Strigi '("xesam:author" "xesam:cc" "xesam:charset" "xesam:contentType" "xesam:fileExtension" "xesam:id" "xesam:lineCount" "xesam:links" "xesam:mimeType" "xesam:name" "xesam:size" "xesam:sourceModified" "xesam:subject" "xesam:to" "xesam:url")) - (TrackerXesamSession + (`TrackerXesamSession '("xesam:relevancyRating" "xesam:url")) - (Debbugs + (`Debbugs '("xesam:keyword" "xesam:owner" "xesam:title" "xesam:url" "xesam:sourceModified" "xesam:mimeType" "debbugs:key")) ;; xesam-tools yahoo service. - (t '("xesam:contentModified" "xesam:mimeType" "xesam:summary" + (_ '("xesam:contentModified" "xesam:mimeType" "xesam:summary" "xesam:title" "xesam:url" "yahoo:displayUrl")))) (xesam-set-property engine "hit.fields" hit-fields) diff --git a/lisp/net/zeroconf.el b/lisp/net/zeroconf.el index d7330665a5a..6a1a009410b 100644 --- a/lisp/net/zeroconf.el +++ b/lisp/net/zeroconf.el @@ -102,9 +102,6 @@ ;; Pacify byte-compiler. D-Bus support in the Emacs core can be ;; disabled with configuration option "--without-dbus". Declare used ;; subroutines and variables of `dbus' therefore. -(eval-when-compile - (require 'cl)) - (defvar dbus-debug) (require 'dbus) @@ -546,7 +543,7 @@ DOMAIN is nil, the local domain is used." ((string-equal (dbus-event-member-name last-input-event) "ItemNew") ;; Parameters: (interface protocol type domain flags) ;; Register a service browser. - (let ((object-path (zeroconf-register-service-browser (nth-value 2 val)))) + (let ((object-path (zeroconf-register-service-browser (nth 2 val)))) ;; Register the signals. (dolist (member '("ItemNew" "ItemRemove" "Failure")) (dbus-register-signal diff --git a/lisp/notifications.el b/lisp/notifications.el index 7a79d5f6754..c762bb104ee 100644 --- a/lisp/notifications.el +++ b/lisp/notifications.el @@ -34,9 +34,6 @@ ;; active D-Bus session bus. ;;; Code: -(eval-when-compile - (require 'cl)) - (require 'dbus) (defconst notifications-specification-version "1.2" @@ -226,10 +223,10 @@ of another `notifications-notify' call." (when urgency (add-to-list 'hints `(:dict-entry "urgency" - (:variant :byte ,(case urgency - (low 0) - (critical 2) - (t 1)))) t)) + (:variant :byte ,(pcase urgency + (`low 0) + (`critical 2) + (_ 1)))) t)) (when category (add-to-list 'hints `(:dict-entry "category" diff --git a/lisp/novice.el b/lisp/novice.el index fa41b2bbc1e..bcc94c86c9d 100644 --- a/lisp/novice.el +++ b/lisp/novice.el @@ -33,8 +33,6 @@ ;; The command is found in this-command ;; and the keys are returned by (this-command-keys). -(eval-when-compile (require 'cl)) - ;;;###autoload (define-obsolete-variable-alias 'disabled-command-hook 'disabled-command-function "22.1") @@ -101,7 +99,7 @@ SPC to try the command just this once, but leave it disabled. (ding) (message "Please type y, n, ! or SPC (the space bar): ")))) (setq char (downcase char)) - (case char + (pcase char (?\C-g (setq quit-flag t)) (?! (setq disabled-command-function nil)) (?y diff --git a/lisp/nxml/nxml-mode.el b/lisp/nxml/nxml-mode.el index 934dabee90d..1e0e692be26 100644 --- a/lisp/nxml/nxml-mode.el +++ b/lisp/nxml/nxml-mode.el @@ -29,7 +29,7 @@ (when (featurep 'mucs) (error "nxml-mode is not compatible with Mule-UCS")) -(eval-when-compile (require 'cl)) ; for assert +(eval-when-compile (require 'cl-lib)) (require 'xmltok) (require 'nxml-enc) @@ -930,16 +930,16 @@ Called with `font-lock-beg' and `font-lock-end' dynamically bound." (nxml-debug-change "nxml-fontify-matcher" (point) bound) (when (< (point) nxml-prolog-end) - ;; prolog needs to be fontified in one go, and + ;; Prolog needs to be fontified in one go, and ;; nxml-extend-region makes sure we start at BOB. - (assert (bobp)) + (cl-assert (bobp)) (nxml-fontify-prolog) (goto-char nxml-prolog-end)) (let (xmltok-dependent-regions xmltok-errors) (while (and (nxml-tokenize-forward) - (<= (point) bound)) ; intervals are open-ended + (<= (point) bound)) ; Intervals are open-ended. (nxml-apply-fontify-rule))) (setq nxml-last-fontify-end (point))) diff --git a/lisp/play/5x5.el b/lisp/play/5x5.el index c0a642941f4..e6df0df8282 100644 --- a/lisp/play/5x5.el +++ b/lisp/play/5x5.el @@ -50,8 +50,7 @@ ;; Things we need. -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;; Customize options. @@ -260,8 +259,8 @@ Quit current game \\[5x5-quit-game]" (defun 5x5-make-new-grid () "Create and return a new `5x5' grid structure." (let ((grid (make-vector 5x5-grid-size nil))) - (loop for y from 0 to (1- 5x5-grid-size) do - (aset grid y (make-vector 5x5-grid-size nil))) + (dotimes (y 5x5-grid-size) + (aset grid y (make-vector 5x5-grid-size nil))) grid)) (defun 5x5-cell (grid y x) @@ -279,9 +278,9 @@ Quit current game \\[5x5-quit-game]" (defun 5x5-copy-grid (grid) "Make a new copy of GRID." (let ((copy (5x5-make-new-grid))) - (loop for y from 0 to (1- 5x5-grid-size) do - (loop for x from 0 to (1- 5x5-grid-size) do - (5x5-set-cell copy y x (5x5-cell grid y x)))) + (dotimes (y 5x5-grid-size) + (dotimes (x 5x5-grid-size) + (5x5-set-cell copy y x (5x5-cell grid y x)))) copy)) (defun 5x5-make-move (grid row col) @@ -299,45 +298,46 @@ Quit current game \\[5x5-quit-game]" (defun 5x5-row-value (row) "Get the \"on-value\" for grid row ROW." - (loop for y from 0 to (1- 5x5-grid-size) sum (if (aref row y) 1 0))) + (cl-loop for y from 0 to (1- 5x5-grid-size) sum (if (aref row y) 1 0))) (defun 5x5-grid-value (grid) "Get the \"on-value\" for grid GRID." - (loop for y from 0 to (1- 5x5-grid-size) sum (5x5-row-value (aref grid y)))) + (cl-loop for y from 0 to (1- 5x5-grid-size) + sum (5x5-row-value (aref grid y)))) (defun 5x5-draw-grid-end () "Draw the top/bottom of the grid." (insert "+") - (loop for x from 0 to (1- 5x5-grid-size) do - (insert "-" (make-string 5x5-x-scale ?-))) + (dotimes (x 5x5-grid-size) + (insert "-" (make-string 5x5-x-scale ?-))) (insert "-+ ")) (defun 5x5-draw-grid (grids) "Draw the grids GRIDS into the current buffer." (let ((inhibit-read-only t) grid-org) (erase-buffer) - (loop for grid in grids do (5x5-draw-grid-end)) + (dolist (grid grids) (5x5-draw-grid-end)) (insert "\n") (setq grid-org (point)) - (loop for y from 0 to (1- 5x5-grid-size) do - (loop for lines from 0 to (1- 5x5-y-scale) do - (loop for grid in grids do - (loop for x from 0 to (1- 5x5-grid-size) do - (insert (if (zerop x) "| " " ") - (make-string 5x5-x-scale - (if (5x5-cell grid y x) ?# ?.)))) - (insert " | ")) - (insert "\n"))) + (dotimes (y 5x5-grid-size) + (dotimes (lines 5x5-y-scale) + (dolist (grid grids) + (dotimes (x 5x5-grid-size) + (insert (if (zerop x) "| " " ") + (make-string 5x5-x-scale + (if (5x5-cell grid y x) ?# ?.)))) + (insert " | ")) + (insert "\n"))) (when 5x5-solver-output (if (= (car 5x5-solver-output) 5x5-moves) (save-excursion (goto-char grid-org) (beginning-of-line (+ 1 (/ 5x5-y-scale 2))) - (let ((solution-grid (cdadr 5x5-solver-output))) - (dotimes (y 5x5-grid-size) + (let ((solution-grid (cl-cdadr 5x5-solver-output))) + (dotimes (y 5x5-grid-size) (save-excursion (forward-char (+ 1 (/ (1+ 5x5-x-scale) 2))) - (dotimes (x 5x5-grid-size) + (dotimes (x 5x5-grid-size) (when (5x5-cell solution-grid y x) (if (= 0 (mod 5x5-x-scale 2)) (progn @@ -350,7 +350,7 @@ Quit current game \\[5x5-quit-game]" (forward-char (1+ 5x5-x-scale)))) (forward-line 5x5-y-scale)))) (setq 5x5-solver-output nil))) - (loop for grid in grids do (5x5-draw-grid-end)) + (dolist (grid grids) (5x5-draw-grid-end)) (insert "\n") (insert (format "On: %d Moves: %d" (5x5-grid-value (car grids)) 5x5-moves)))) @@ -362,16 +362,16 @@ Quit current game \\[5x5-quit-game]" (defun 5x5-made-move () "Keep track of how many moves have been made." - (incf 5x5-moves)) + (cl-incf 5x5-moves)) (defun 5x5-make-random-grid (&optional move) "Make a random grid." (setq move (or move (symbol-function '5x5-flip-cell))) (let ((grid (5x5-make-new-grid))) - (loop for y from 0 to (1- 5x5-grid-size) do - (loop for x from 0 to (1- 5x5-grid-size) do - (if (zerop (random 2)) - (funcall move grid y x)))) + (dotimes (y 5x5-grid-size) + (dotimes (x 5x5-grid-size) + (if (zerop (random 2)) + (funcall move grid y x)))) grid)) ;; Cracker functions. @@ -444,20 +444,20 @@ should return a grid vector array that is the new solution." (defun 5x5-make-xor-with-mutation (current best) "Xor current and best solution then mutate the result." (let ((xored (5x5-make-new-grid))) - (loop for y from 0 to (1- 5x5-grid-size) do - (loop for x from 0 to (1- 5x5-grid-size) do - (5x5-set-cell xored y x - (5x5-xor (5x5-cell current y x) - (5x5-cell best y x))))) + (dotimes (y 5x5-grid-size) + (dotimes (x 5x5-grid-size) + (5x5-set-cell xored y x + (5x5-xor (5x5-cell current y x) + (5x5-cell best y x))))) (5x5-mutate-solution xored))) (defun 5x5-mutate-solution (solution) "Randomly flip bits in the solution." - (loop for y from 0 to (1- 5x5-grid-size) do - (loop for x from 0 to (1- 5x5-grid-size) do - (if (= (random (/ (* 5x5-grid-size 5x5-grid-size) 2)) - (/ (/ (* 5x5-grid-size 5x5-grid-size) 2) 2)) - (5x5-flip-cell solution y x)))) + (dotimes (y 5x5-grid-size) + (dotimes (x 5x5-grid-size) + (if (= (random (/ (* 5x5-grid-size 5x5-grid-size) 2)) + (/ (/ (* 5x5-grid-size 5x5-grid-size) 2) 2)) + (5x5-flip-cell solution y x)))) solution) (defun 5x5-play-solution (solution best) @@ -465,15 +465,15 @@ should return a grid vector array that is the new solution." in progress because it is an animated attempt." (5x5-new-game) (let ((inhibit-quit t)) - (loop for y from 0 to (1- 5x5-grid-size) do - (loop for x from 0 to (1- 5x5-grid-size) do - (setq 5x5-y-pos y - 5x5-x-pos x) - (if (5x5-cell solution y x) - (5x5-flip-current)) - (5x5-draw-grid (list 5x5-grid solution best)) - (5x5-position-cursor) - (sit-for 5x5-animate-delay)))) + (dotimes (y 5x5-grid-size) + (dotimes (x 5x5-grid-size) + (setq 5x5-y-pos y + 5x5-x-pos x) + (if (5x5-cell solution y x) + (5x5-flip-current)) + (5x5-draw-grid (list 5x5-grid solution best)) + (5x5-position-cursor) + (sit-for 5x5-animate-delay)))) 5x5-grid) ;; Arithmetic solver @@ -758,9 +758,9 @@ Solutions are sorted from least to greatest Hamming weight." ;; The Hamming Weight is computed by matrix reduction ;; with an ad-hoc operator. (math-reduce-vec - ;; (cadadr '(vec (mod x 2))) => x - (lambda (r x) (+ (if (integerp r) r (cadadr r)) - (cadadr x))) + ;; (cl-cadadr '(vec (mod x 2))) => x + (lambda (r x) (+ (if (integerp r) r (cl-cadadr r)) + (cl-cadadr x))) solution); car (5x5-vec-to-grid (calcFunc-arrange solution 5x5-grid-size));cdr @@ -878,28 +878,28 @@ lest." "Move up." (interactive) (unless (zerop 5x5-y-pos) - (decf 5x5-y-pos) + (cl-decf 5x5-y-pos) (5x5-position-cursor))) (defun 5x5-down () "Move down." (interactive) (unless (= 5x5-y-pos (1- 5x5-grid-size)) - (incf 5x5-y-pos) + (cl-incf 5x5-y-pos) (5x5-position-cursor))) (defun 5x5-left () "Move left." (interactive) (unless (zerop 5x5-x-pos) - (decf 5x5-x-pos) + (cl-decf 5x5-x-pos) (5x5-position-cursor))) (defun 5x5-right () "Move right." (interactive) (unless (= 5x5-x-pos (1- 5x5-grid-size)) - (incf 5x5-x-pos) + (cl-incf 5x5-x-pos) (5x5-position-cursor))) (defun 5x5-bol () diff --git a/lisp/play/bubbles.el b/lisp/play/bubbles.el index a786f687124..1f04099a6ae 100644 --- a/lisp/play/bubbles.el +++ b/lisp/play/bubbles.el @@ -82,7 +82,6 @@ (defconst bubbles-version "0.5" "Version number of bubbles.el.") (require 'gamegrid) -(eval-when-compile (require 'cl)) ; for 'case ;; User options @@ -718,58 +717,58 @@ static char * dot3d_xpm[] = { (defsubst bubbles--grid-width () "Return the grid width for the current game theme." - (car (case bubbles-game-theme - (easy + (car (pcase bubbles-game-theme + (`easy bubbles--grid-small) - (medium + (`medium bubbles--grid-medium) - (difficult + (`difficult bubbles--grid-large) - (hard + (`hard bubbles--grid-huge) - (user-defined + (`user-defined bubbles-grid-size)))) (defsubst bubbles--grid-height () "Return the grid height for the current game theme." - (cdr (case bubbles-game-theme - (easy + (cdr (pcase bubbles-game-theme + (`easy bubbles--grid-small) - (medium + (`medium bubbles--grid-medium) - (difficult + (`difficult bubbles--grid-large) - (hard + (`hard bubbles--grid-huge) - (user-defined + (`user-defined bubbles-grid-size)))) (defsubst bubbles--colors () "Return the color list for the current game theme." - (case bubbles-game-theme - (easy + (pcase bubbles-game-theme + (`easy bubbles--colors-2) - (medium + (`medium bubbles--colors-3) - (difficult + (`difficult bubbles--colors-4) - (hard + (`hard bubbles--colors-5) - (user-defined + (`user-defined bubbles-colors))) (defsubst bubbles--shift-mode () "Return the shift mode for the current game theme." - (case bubbles-game-theme - (easy + (pcase bubbles-game-theme + (`easy 'default) - (medium + (`medium 'default) - (difficult + (`difficult 'always) - (hard + (`hard 'always) - (user-defined + (`user-defined bubbles-shift-mode))) (defun bubbles-save-settings () @@ -1345,12 +1344,12 @@ Return t if new char is non-empty." "Prepare images for playing `bubbles'." (when (and (display-images-p) (not (eq bubbles-graphics-theme 'ascii))) - (let ((template (case bubbles-graphics-theme - (circles bubbles--image-template-circle) - (balls bubbles--image-template-ball) - (squares bubbles--image-template-square) - (diamonds bubbles--image-template-diamond) - (emacs bubbles--image-template-emacs)))) + (let ((template (pcase bubbles-graphics-theme + (`circles bubbles--image-template-circle) + (`balls bubbles--image-template-ball) + (`squares bubbles--image-template-square) + (`diamonds bubbles--image-template-diamond) + (`emacs bubbles--image-template-emacs)))) (setq bubbles--empty-image (create-image (replace-regexp-in-string "^\"\\(.*\\)\t.*c .*\",$" diff --git a/lisp/play/decipher.el b/lisp/play/decipher.el index 438fae4383d..8d9506a1614 100644 --- a/lisp/play/decipher.el +++ b/lisp/play/decipher.el @@ -88,8 +88,7 @@ ;;; Variables: ;;;=================================================================== -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defgroup decipher nil "Cryptanalyze monoalphabetic substitution ciphers." @@ -170,7 +169,7 @@ in your `.emacs' file.") (let ((key ?a)) (while (<= key ?z) (define-key map (vector key) 'decipher-keypress) - (incf key))) + (cl-incf key))) map) "Keymap for Decipher mode.") @@ -194,7 +193,7 @@ in your `.emacs' file.") (c ?0)) (while (<= c ?9) (modify-syntax-entry c "_" table) ;Digits are not part of words - (incf c)) + (cl-incf c)) (setq decipher-mode-syntax-table table))) (defvar decipher-alphabet nil) @@ -414,7 +413,7 @@ The most useful commands are: (if undo-rec (progn (push undo-rec decipher-undo-list) - (incf decipher-undo-list-size) + (cl-incf decipher-undo-list-size) (if (> decipher-undo-list-size decipher-undo-limit) (let ((new-size (- decipher-undo-limit 100))) ;; Truncate undo list to NEW-SIZE elements: @@ -588,7 +587,7 @@ you have determined the keyword." (progn (while (rassoc cipher-char decipher-alphabet) ;; Find the next unused letter - (incf cipher-char)) + (cl-incf cipher-char)) (push (cons ?\s cipher-char) undo-rec) (decipher-set-map cipher-char (car plain-map) t)))) (decipher-add-undo undo-rec))) @@ -644,7 +643,7 @@ You should use this if you edit the ciphertext." (while (>= plain-char ?a) (backward-char) (push (cons plain-char (following-char)) decipher-alphabet) - (decf plain-char))))) + (cl-decf plain-char))))) ;;;=================================================================== ;;; Analyzing ciphertext: @@ -805,8 +804,8 @@ TOTAL is the total number of letters in the ciphertext." (while temp-list (insert (caar temp-list) (format "%4d%3d%% " - (cadar temp-list) - (/ (* 100 (cadar temp-list)) total))) + (cl-cadar temp-list) + (/ (* 100 (cl-cadar temp-list)) total))) (setq temp-list (nthcdr 4 temp-list))) (insert ?\n) (setq freq-list (cdr freq-list) @@ -838,17 +837,17 @@ TOTAL is the total number of letters in the ciphertext." ;; A vector of 26 integers, counting the number of occurrences ;; of the corresponding characters. (setq decipher--digram (format "%c%c" decipher--prev-char decipher-char)) - (incf (cdr (or (assoc decipher--digram decipher--digram-list) + (cl-incf (cdr (or (assoc decipher--digram decipher--digram-list) (car (push (cons decipher--digram 0) decipher--digram-list))))) (and (>= decipher--prev-char ?A) - (incf (aref (aref decipher--before (- decipher--prev-char ?A)) + (cl-incf (aref (aref decipher--before (- decipher--prev-char ?A)) (if (equal decipher-char ?\s) 26 (- decipher-char ?A))))) (and (>= decipher-char ?A) - (incf (aref decipher--freqs (- decipher-char ?A))) - (incf (aref (aref decipher--after (- decipher-char ?A)) + (cl-incf (aref decipher--freqs (- decipher-char ?A))) + (cl-incf (aref (aref decipher--after (- decipher-char ?A)) (if (equal decipher--prev-char ?\s) 26 (- decipher--prev-char ?A))))) @@ -859,8 +858,8 @@ TOTAL is the total number of letters in the ciphertext." (let ((total 0)) (concat (mapconcat (lambda (x) - (cond ((> x 99) (incf total) "XX") - ((> x 0) (incf total) (format "%2d" x)) + (cond ((> x 99) (cl-incf total) "XX") + ((> x 0) (cl-incf total) (format "%2d" x)) (t " "))) counts "") @@ -873,10 +872,10 @@ TOTAL is the total number of letters in the ciphertext." ;; We do not include spaces (word divisions) in this count. (let ((total 0) (i 26)) - (while (>= (decf i) 0) + (while (>= (cl-decf i) 0) (if (or (> (aref before-count i) 0) (> (aref after-count i) 0)) - (incf total))) + (cl-incf total))) total)) (defun decipher-analyze-buffer () @@ -890,7 +889,7 @@ Creates the statistics buffer if it doesn't exist." decipher--digram decipher--digram-list freq-list) (message "Scanning buffer...") (let ((i 26)) - (while (>= (decf i) 0) + (while (>= (cl-decf i) 0) (aset decipher--before i (make-vector 27 0)) (aset decipher--after i (make-vector 27 0)))) (if decipher-ignore-spaces @@ -898,7 +897,7 @@ Creates the statistics buffer if it doesn't exist." (decipher-loop-no-breaks 'decipher--analyze) ;; The first character of ciphertext was marked as following a space: (let ((i 26)) - (while (>= (decf i) 0) + (while (>= (cl-decf i) 0) (aset (aref decipher--after i) 26 0)))) (decipher-loop-with-breaks 'decipher--analyze)) (message "Processing results...") @@ -913,7 +912,7 @@ Creates the statistics buffer if it doesn't exist." ;; of times it occurs, and DIFFERENT is the number of different ;; letters it appears next to. (let ((i 26)) - (while (>= (decf i) 0) + (while (>= (cl-decf i) 0) (setq freq-list (cons (list (+ i ?A) (aref decipher--freqs i) @@ -933,7 +932,7 @@ Creates the statistics buffer if it doesn't exist." (insert ?\n) ;; Display frequency counts for letters in order of frequency: (setq freq-list (sort freq-list - (lambda (a b) (> (second a) (second b))))) + (lambda (a b) (> (cl-second a) (cl-second b))))) (decipher-insert-frequency-counts freq-list total-chars) ;; Display letters in order of frequency: (insert ?\n (mapconcat (lambda (a) (char-to-string (car a))) @@ -957,11 +956,11 @@ Creates the statistics buffer if it doesn't exist." ;; Display adjacency list for each letter, sorted in descending ;; order of the number of adjacent letters: (setq freq-list (sort freq-list - (lambda (a b) (> (third a) (third b))))) + (lambda (a b) (> (cl-third a) (cl-third b))))) (let ((temp-list freq-list) entry i) (while (setq entry (pop temp-list)) - (if (equal 0 (second entry)) + (if (equal 0 (cl-second entry)) nil ;This letter was not used (setq i (- (car entry) ?A)) (insert ?\n " " @@ -969,8 +968,8 @@ Creates the statistics buffer if it doesn't exist." (car entry) ": A B C D E F G H I J K L M N O P Q R S T U V W X Y Z *" (format "%4d %4d %3d%%\n " - (third entry) (second entry) - (/ (* 100 (second entry)) total-chars)) + (cl-third entry) (cl-second entry) + (/ (* 100 (cl-second entry)) total-chars)) (decipher--digram-counts (aref decipher--after i)) ?\n)))) (setq buffer-read-only t) (set-buffer-modified-p nil) diff --git a/lisp/play/gamegrid.el b/lisp/play/gamegrid.el index 3b2e6c196f6..f3e277e338c 100644 --- a/lisp/play/gamegrid.el +++ b/lisp/play/gamegrid.el @@ -26,9 +26,6 @@ ;;; Code: -(eval-when-compile - (require 'cl)) - ;; ;;;;;;;;;;;;; buffer-local variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar gamegrid-use-glyphs t @@ -212,20 +209,20 @@ static unsigned char gamegrid_bits[] = { (defun gamegrid-make-face (data-spec-list color-spec-list) (let ((data (gamegrid-match-spec-list data-spec-list)) (color (gamegrid-match-spec-list color-spec-list))) - (case data - (color-x + (pcase data + (`color-x (gamegrid-make-color-x-face color)) - (grid-x + (`grid-x (unless gamegrid-grid-x-face (setq gamegrid-grid-x-face (gamegrid-make-grid-x-face))) gamegrid-grid-x-face) - (mono-x + (`mono-x (unless gamegrid-mono-x-face (setq gamegrid-mono-x-face (gamegrid-make-mono-x-face))) gamegrid-mono-x-face) - (color-tty + (`color-tty (gamegrid-make-color-tty-face color)) - (mono-tty + (`mono-tty (unless gamegrid-mono-tty-face (setq gamegrid-mono-tty-face (gamegrid-make-mono-tty-face))) gamegrid-mono-tty-face)))) @@ -311,13 +308,13 @@ static unsigned char gamegrid_bits[] = { (intern (concat "gamegrid-face-" (buffer-name))))) (when (eq gamegrid-display-mode 'glyph) (let ((max-height nil)) - (loop for c from 0 to 255 do - (let ((glyph (aref gamegrid-display-table c))) - (when (and (listp glyph) (eq (car glyph) 'image)) - (let ((height (cdr (image-size glyph)))) - (if (or (null max-height) - (< max-height height)) - (setq max-height height)))))) + (dotimes (c 256) + (let ((glyph (aref gamegrid-display-table c))) + (when (and (listp glyph) (eq (car glyph) 'image)) + (let ((height (cdr (image-size glyph)))) + (if (or (null max-height) + (< max-height height)) + (setq max-height height)))))) (when (and max-height (< max-height 1)) (let ((default-font-height (face-attribute 'default :height)) (resy (/ (display-pixel-height) (/ (display-mm-height) 25.4))) @@ -332,10 +329,10 @@ static unsigned char gamegrid_bits[] = { (setq gamegrid-display-mode (gamegrid-display-type)) (setq gamegrid-display-table (make-display-table)) (setq gamegrid-face-table (make-vector 256 nil)) - (loop for c from 0 to 255 do + (dotimes (c 256) (let* ((spec (aref gamegrid-display-options c)) - (glyph (gamegrid-make-glyph (car spec) (caddr spec))) - (face (gamegrid-make-face (cadr spec) (caddr spec)))) + (glyph (gamegrid-make-glyph (car spec) (nth 2 spec))) + (face (gamegrid-make-face (cadr spec) (nth 2 spec)))) (aset gamegrid-face-table c face) (aset gamegrid-display-table c glyph))) (gamegrid-setup-default-font) @@ -451,10 +448,10 @@ group. You probably need special user privileges to do this. On non-POSIX systems Emacs searches for FILE in the directory specified by the variable `temporary-file-directory'. If necessary, FILE is created there." - (case system-type - ((ms-dos windows-nt) + (pcase system-type + ((or `ms-dos `windows-nt) (gamegrid-add-score-insecure file score)) - (t + (_ (gamegrid-add-score-with-update-game-score file score)))) diff --git a/lisp/play/hanoi.el b/lisp/play/hanoi.el index 31a6d6f425b..9e8b6ff97eb 100644 --- a/lisp/play/hanoi.el +++ b/lisp/play/hanoi.el @@ -56,15 +56,14 @@ ;;; Code: -(eval-when-compile - (require 'cl) - ;; dynamic bondage: - (defvar baseward-step) - (defvar fly-step) - (defvar fly-row-start) - (defvar pole-width) - (defvar pole-char) - (defvar line-offset)) +(eval-when-compile (require 'cl-lib)) +;; dynamic bondage: +(defvar baseward-step) +(defvar fly-step) +(defvar fly-row-start) +(defvar pole-width) +(defvar pole-char) +(defvar line-offset) (defgroup hanoi nil "The Towers of Hanoi." @@ -124,9 +123,9 @@ second since 1970-01-01 00:00:00 GMT. Repent before ring 31 moves." (interactive) (let* ((start (ftruncate (float-time))) - (bits (loop repeat 32 - for x = (/ start (expt 2.0 31)) then (* x 2.0) - collect (truncate (mod x 2.0)))) + (bits (cl-loop repeat 32 + for x = (/ start (expt 2.0 31)) then (* x 2.0) + collect (truncate (mod x 2.0)))) (hanoi-move-period 1.0)) (hanoi-internal 32 bits start))) @@ -138,9 +137,9 @@ current-time interface is made s2G-compliant, hanoi.el will need to be updated." (interactive) (let* ((start (ftruncate (float-time))) - (bits (loop repeat 64 - for x = (/ start (expt 2.0 63)) then (* x 2.0) - collect (truncate (mod x 2.0)))) + (bits (cl-loop repeat 64 + for x = (/ start (expt 2.0 63)) then (* x 2.0) + collect (truncate (mod x 2.0)))) (hanoi-move-period 1.0)) (hanoi-internal 64 bits start))) @@ -197,22 +196,22 @@ BITS must be of length nrings. Start at START-TIME." (setq fly-row-start (1- line-offset)) (setq fly-step line-offset) (setq baseward-step -1) - (loop repeat base-len do - (unless (zerop base-lines) - (insert-char ?\ (1- base-lines)) - (insert base-char) - (hanoi-put-face (1- (point)) (point) hanoi-base-face)) - (insert-char ?\ (+ 2 nrings)) - (insert ?\n)) + (cl-loop repeat base-len do + (unless (zerop base-lines) + (insert-char ?\ (1- base-lines)) + (insert base-char) + (hanoi-put-face (1- (point)) (point) hanoi-base-face)) + (insert-char ?\ (+ 2 nrings)) + (insert ?\n)) (delete-char -1) - (loop for coord in pole-coords do - (loop for row from (- coord (/ pole-width 2)) - for start = (+ (* row line-offset) base-lines 1) - repeat pole-width do - (subst-char-in-region start (+ start nrings 1) - ?\ pole-char) - (hanoi-put-face start (+ start nrings 1) - hanoi-pole-face)))) + (dolist (coord pole-coords) + (cl-loop for row from (- coord (/ pole-width 2)) + for start = (+ (* row line-offset) base-lines 1) + repeat pole-width do + (subst-char-in-region start (+ start nrings 1) + ?\ pole-char) + (hanoi-put-face start (+ start nrings 1) + hanoi-pole-face)))) ;; vertical (setq line-offset (1+ base-len)) (setq fly-step 1) @@ -222,17 +221,17 @@ BITS must be of length nrings. Start at START-TIME." (setq fly-row-start (point)) (insert-char ?\ base-len) (insert ?\n) - (loop repeat (1+ nrings) - with pole-line = - (loop with line = (make-string base-len ?\ ) - for coord in pole-coords - for start = (- coord (/ pole-width 2)) - for end = (+ start pole-width) do - (hanoi-put-face start end hanoi-pole-face line) - (loop for i from start below end do - (aset line i pole-char)) - finally return line) - do (insert pole-line ?\n)) + (cl-loop repeat (1+ nrings) + with pole-line = + (cl-loop with line = (make-string base-len ?\ ) + for coord in pole-coords + for start = (- coord (/ pole-width 2)) + for end = (+ start pole-width) do + (hanoi-put-face start end hanoi-pole-face line) + (cl-loop for i from start below end do + (aset line i pole-char)) + finally return line) + do (insert pole-line ?\n)) (insert-char base-char base-len) (hanoi-put-face (- (point) base-len) (point) hanoi-base-face) (set-window-start (selected-window) @@ -244,40 +243,41 @@ BITS must be of length nrings. Start at START-TIME." ;; the car is the position of the top ring currently on the pole, ;; (or the base of the pole if it is empty). ;; the cdr is in the fly-row just above the pole. - (poles (loop for coord in pole-coords - for fly-pos = (+ fly-row-start (* fly-step coord)) - for base = (+ fly-pos (* baseward-step (+ 2 nrings))) - collect (cons base fly-pos))) + (poles + (cl-loop for coord in pole-coords + for fly-pos = (+ fly-row-start (* fly-step coord)) + for base = (+ fly-pos (* baseward-step (+ 2 nrings))) + collect (cons base fly-pos))) ;; compute the string for each ring and make the list of ;; ring pairs. Each ring pair is initially (str . diameter). ;; Once placed in buffer it is changed to (center-pos . diameter). (rings - (loop - ;; radii are measured from the edge of the pole out. - ;; So diameter = 2 * radius + pole-width. When - ;; there's room, we make each ring's radius = - ;; pole-number + 1. If there isn't room, we step - ;; evenly from the max radius down to 1. - with max-radius = (min nrings - (/ (- max-ring-diameter pole-width) 2)) - for n from (1- nrings) downto 0 - for radius = (1+ (/ (* n max-radius) nrings)) - for diameter = (+ pole-width (* 2 radius)) - with format-str = (format "%%0%dd" pole-width) - for str = (concat (if vert "<" "^") - (make-string (1- radius) (if vert ?\- ?\|)) - (format format-str n) - (make-string (1- radius) (if vert ?\- ?\|)) - (if vert ">" "v")) - for face = - (if (eq (logand n 1) 1) ; oddp would require cl at runtime - hanoi-odd-ring-face hanoi-even-ring-face) - do (hanoi-put-face 0 (length str) face str) - collect (cons str diameter))) + (cl-loop + ;; radii are measured from the edge of the pole out. + ;; So diameter = 2 * radius + pole-width. When + ;; there's room, we make each ring's radius = + ;; pole-number + 1. If there isn't room, we step + ;; evenly from the max radius down to 1. + with max-radius = (min nrings + (/ (- max-ring-diameter pole-width) 2)) + for n from (1- nrings) downto 0 + for radius = (1+ (/ (* n max-radius) nrings)) + for diameter = (+ pole-width (* 2 radius)) + with format-str = (format "%%0%dd" pole-width) + for str = (concat (if vert "<" "^") + (make-string (1- radius) (if vert ?\- ?\|)) + (format format-str n) + (make-string (1- radius) (if vert ?\- ?\|)) + (if vert ">" "v")) + for face = + (if (eq (logand n 1) 1) ; oddp would require cl at runtime + hanoi-odd-ring-face hanoi-even-ring-face) + do (hanoi-put-face 0 (length str) face str) + collect (cons str diameter))) ;; Disable display of line and column numbers, for speed. (line-number-mode nil) (column-number-mode nil)) ;; do it! - (hanoi-n bits rings (car poles) (cadr poles) (caddr poles) + (hanoi-n bits rings (car poles) (cadr poles) (cl-caddr poles) start-time)) (message "Done")) (setq buffer-read-only t) @@ -322,14 +322,14 @@ BITS must be of length nrings. Start at START-TIME." ;; put never-before-placed RING on POLE and update their cars. (defun hanoi-insert-ring (ring pole) - (decf (car pole) baseward-step) + (cl-decf (car pole) baseward-step) (let ((str (car ring)) (start (- (car pole) (* (/ (cdr ring) 2) fly-step)))) (setcar ring (car pole)) - (loop for pos upfrom start by fly-step - for i below (cdr ring) do - (subst-char-in-region pos (1+ pos) (char-after pos) (aref str i)) - (set-text-properties pos (1+ pos) (text-properties-at i str))) + (cl-loop for pos upfrom start by fly-step + for i below (cdr ring) do + (subst-char-in-region pos (1+ pos) (char-after pos) (aref str i)) + (set-text-properties pos (1+ pos) (text-properties-at i str))) (hanoi-goto-char (car pole)))) ;; like goto-char, but if position is outside the window, then move to @@ -341,8 +341,8 @@ BITS must be of length nrings. Start at START-TIME." ;; do one pole-to-pole move and update the ring and pole pairs. (defun hanoi-move-ring (ring from to start-time) - (incf (car from) baseward-step) - (decf (car to) baseward-step) + (cl-incf (car from) baseward-step) + (cl-decf (car to) baseward-step) (let* ;; We move flywards-steps steps up the pole to the fly row, ;; then fly fly-steps steps across the fly row, then go ;; baseward-steps steps down the new pole. @@ -378,15 +378,15 @@ BITS must be of length nrings. Start at START-TIME." (/ (- tick flyward-ticks fly-ticks) ticks-per-pole-step)))))))) (if hanoi-move-period - (loop for elapsed = (- (float-time) start-time) - while (< elapsed hanoi-move-period) - with tick-period = (/ (float hanoi-move-period) total-ticks) - for tick = (ceiling (/ elapsed tick-period)) do - (hanoi-ring-to-pos ring (funcall tick-to-pos tick)) - (hanoi-sit-for (- (* tick tick-period) elapsed))) - (loop for tick from 1 to total-ticks by 2 do - (hanoi-ring-to-pos ring (funcall tick-to-pos tick)) - (hanoi-sit-for 0))) + (cl-loop for elapsed = (- (float-time) start-time) + while (< elapsed hanoi-move-period) + with tick-period = (/ (float hanoi-move-period) total-ticks) + for tick = (ceiling (/ elapsed tick-period)) do + (hanoi-ring-to-pos ring (funcall tick-to-pos tick)) + (hanoi-sit-for (- (* tick tick-period) elapsed))) + (cl-loop for tick from 1 to total-ticks by 2 do + (hanoi-ring-to-pos ring (funcall tick-to-pos tick)) + (hanoi-sit-for 0))) ;; Always make last move to keep pole and ring data consistent (hanoi-ring-to-pos ring (car to)) (if hanoi-move-period (+ start-time hanoi-move-period)))) @@ -403,11 +403,12 @@ BITS must be of length nrings. Start at START-TIME." (let* ((start (- (car ring) (* (/ (cdr ring) 2) fly-step))) (new-start (- pos (- (car ring) start)))) (if hanoi-horizontal-flag - (loop for i below (cdr ring) - for j = (if (< new-start start) i (- (cdr ring) i 1)) - for old-pos = (+ start (* j fly-step)) - for new-pos = (+ new-start (* j fly-step)) do - (transpose-regions old-pos (1+ old-pos) new-pos (1+ new-pos))) + (cl-loop for i below (cdr ring) + for j = (if (< new-start start) i (- (cdr ring) i 1)) + for old-pos = (+ start (* j fly-step)) + for new-pos = (+ new-start (* j fly-step)) do + (transpose-regions old-pos (1+ old-pos) + new-pos (1+ new-pos))) (let ((end (+ start (cdr ring))) (new-end (+ new-start (cdr ring)))) (if (< (abs (- new-start start)) (- end start)) @@ -425,9 +426,9 @@ BITS must be of length nrings. Start at START-TIME." (curr-char (if on-pole ?\ pole-char)) (face (if on-pole hanoi-pole-face nil))) (if hanoi-horizontal-flag - (loop for pos from pole-start below pole-end by line-offset do - (subst-char-in-region pos (1+ pos) curr-char new-char) - (hanoi-put-face pos (1+ pos) face)) + (cl-loop for pos from pole-start below pole-end by line-offset do + (subst-char-in-region pos (1+ pos) curr-char new-char) + (hanoi-put-face pos (1+ pos) face)) (subst-char-in-region pole-start pole-end curr-char new-char) (hanoi-put-face pole-start pole-end face)))) (setcar ring pos)) diff --git a/lisp/play/landmark.el b/lisp/play/landmark.el index 9ffc308928a..e9f555093db 100644 --- a/lisp/play/landmark.el +++ b/lisp/play/landmark.el @@ -56,7 +56,7 @@ ;; concise problem description. ;;;_* Require -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;;;_* From Gomoku @@ -1417,7 +1417,7 @@ After this limit is reached, landmark-random-move is called to push him out of i (put 'z 't-1 (get 'z 't)) (put 'z 't (calc-smell-internal 'landmark-tree)) (if (= (- (get 'z 't) (get 'z 't-1)) 0.0) - (incf landmark-no-payoff) + (cl-incf landmark-no-payoff) (setf landmark-no-payoff 0))) (defun landmark-store-old-y_t () @@ -1464,7 +1464,7 @@ After this limit is reached, landmark-random-move is called to push him out of i (landmark-e forward-char) (landmark-w backward-char))) (landmark-plot-square (landmark-point-square) 1) - (incf landmark-number-of-moves) + (cl-incf landmark-number-of-moves) (if landmark-output-moves (message "Moves made: %d" landmark-number-of-moves))) @@ -1591,11 +1591,11 @@ If the game is finished, this command requests for another game." ; this a worka! ; (eval (cons '+ list)) ;;;_ - landmark-set-landmark-signal-strengths () -;;; on a screen higher than wide, I noticed that the robot would amble -;;; left and right and not move forward. examining *landmark-blackbox* -;;; revealed that there was no scent from the north and south -;;; landmarks, hence, they need less factoring down of the effect of -;;; distance on scent. +;; on a screen higher than wide, I noticed that the robot would amble +;; left and right and not move forward. examining *landmark-blackbox* +;; revealed that there was no scent from the north and south +;; landmarks, hence, they need less factoring down of the effect of +;; distance on scent. (defun landmark-set-landmark-signal-strengths () (setq landmark-tree-r (* (sqrt (+ (square landmark-cx) (square landmark-cy))) 1.5)) diff --git a/lisp/play/pong.el b/lisp/play/pong.el index 5742a5c7849..cb165cdf31e 100644 --- a/lisp/play/pong.el +++ b/lisp/play/pong.el @@ -26,7 +26,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gamegrid) @@ -214,18 +214,18 @@ (defun pong-display-options () "Computes display options (required by gamegrid for colors)." (let ((options (make-vector 256 nil))) - (loop for c from 0 to 255 do + (dotimes (c 256) (aset options c - (cond ((= c pong-blank) - pong-blank-options) + (cond ((= c pong-blank) + pong-blank-options) ((= c pong-bat) - pong-bat-options) + pong-bat-options) ((= c pong-ball) - pong-ball-options) + pong-ball-options) ((= c pong-border) - pong-border-options) + pong-border-options) (t - '(nil nil nil))))) + '(nil nil nil))))) options)) @@ -246,18 +246,19 @@ ?\s) (let ((buffer-read-only nil)) - (loop for y from 0 to (1- pong-height) do - (loop for x from 0 to (1- pong-width) do - (gamegrid-set-cell x y pong-border))) - (loop for y from 1 to (- pong-height 2) do - (loop for x from 1 to (- pong-width 2) do - (gamegrid-set-cell x y pong-blank)))) - - (loop for y from pong-bat-player1 to (1- (+ pong-bat-player1 pong-bat-width)) do - (gamegrid-set-cell 2 y pong-bat)) - (loop for y from pong-bat-player2 to (1- (+ pong-bat-player2 pong-bat-width)) do - (gamegrid-set-cell (- pong-width 3) y pong-bat))) + (dotimes (y pong-height) + (dotimes (x pong-width) + (gamegrid-set-cell x y pong-border))) + (cl-loop for y from 1 to (- pong-height 2) do + (cl-loop for x from 1 to (- pong-width 2) do + (gamegrid-set-cell x y pong-blank)))) + (cl-loop for y from pong-bat-player1 + to (1- (+ pong-bat-player1 pong-bat-width)) + do (gamegrid-set-cell 2 y pong-bat)) + (cl-loop for y from pong-bat-player2 + to (1- (+ pong-bat-player2 pong-bat-width)) + do (gamegrid-set-cell (- pong-width 3) y pong-bat))) (defun pong-move-left () @@ -401,13 +402,12 @@ detection and checks if a player scores." (defun pong-update-score () "Update score and print it on bottom of the game grid." - (let* ((string (format "Score: %d / %d" pong-score-player1 pong-score-player2)) + (let* ((string (format "Score: %d / %d" + pong-score-player1 pong-score-player2)) (len (length string))) - (loop for x from 0 to (1- len) do - (if (string-equal (buffer-name (current-buffer)) pong-buffer-name) - (gamegrid-set-cell x - pong-height - (aref string x)))))) + (dotimes (x len) + (if (string-equal (buffer-name (current-buffer)) pong-buffer-name) + (gamegrid-set-cell x pong-height (aref string x)))))) diff --git a/lisp/play/snake.el b/lisp/play/snake.el index db54039c237..a3480d0b0fa 100644 --- a/lisp/play/snake.el +++ b/lisp/play/snake.el @@ -25,8 +25,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gamegrid) @@ -195,7 +194,7 @@ and then start moving it leftwards.") (defun snake-display-options () (let ((options (make-vector 256 nil))) - (loop for c from 0 to 255 do + (dotimes (c 256) (aset options c (cond ((= c snake-blank) snake-blank-options) @@ -214,7 +213,7 @@ and then start moving it leftwards.") (defun snake-update-score () (let* ((string (format "Score: %05d" snake-score)) (len (length string))) - (loop for x from 0 to (1- len) do + (dotimes (x len) (gamegrid-set-cell (+ snake-score-x x) snake-score-y (aref string x))))) @@ -224,12 +223,12 @@ and then start moving it leftwards.") snake-buffer-height snake-space) (let ((buffer-read-only nil)) - (loop for y from 0 to (1- snake-height) do - (loop for x from 0 to (1- snake-width) do - (gamegrid-set-cell x y snake-border))) - (loop for y from 1 to (- snake-height 2) do - (loop for x from 1 to (- snake-width 2) do - (gamegrid-set-cell x y snake-blank))))) + (dotimes (y snake-height) + (dotimes (x snake-width) + (gamegrid-set-cell x y snake-border))) + (cl-loop for y from 1 to (- snake-height 2) do + (cl-loop for x from 1 to (- snake-width 2) do + (gamegrid-set-cell x y snake-blank))))) (defun snake-reset-game () (gamegrid-kill-timer) @@ -248,8 +247,8 @@ and then start moving it leftwards.") (dotimes (i snake-length) (gamegrid-set-cell x y snake-snake) (setq snake-positions (cons (vector x y) snake-positions)) - (incf x snake-velocity-x) - (incf y snake-velocity-y))) + (cl-incf x snake-velocity-x) + (cl-incf y snake-velocity-y))) (snake-update-score)) (defun snake-update-game (snake-buffer) @@ -267,8 +266,8 @@ Argument SNAKE-BUFFER is the name of the buffer." (= c snake-snake)) (snake-end-game) (cond ((= c snake-dot) - (incf snake-length) - (incf snake-score) + (cl-incf snake-length) + (cl-incf snake-score) (snake-update-score)) (t (let* ((last-cons (nthcdr (- snake-length 2) @@ -280,7 +279,7 @@ Argument SNAKE-BUFFER is the name of the buffer." (if (= (% snake-cycle 5) 0) snake-dot snake-blank)) - (incf snake-cycle) + (cl-incf snake-cycle) (setcdr last-cons nil)))) (gamegrid-set-cell x y snake-snake) (setq snake-positions diff --git a/lisp/play/tetris.el b/lisp/play/tetris.el index 24d1c3f2417..b811a21605b 100644 --- a/lisp/play/tetris.el +++ b/lisp/play/tetris.el @@ -26,8 +26,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gamegrid) @@ -285,20 +284,20 @@ each one of its four blocks.") (defun tetris-display-options () (let ((options (make-vector 256 nil))) - (loop for c from 0 to 255 do + (dotimes (c 256) (aset options c (cond ((= c tetris-blank) - tetris-blank-options) + tetris-blank-options) ((and (>= c 0) (<= c 6)) (append tetris-cell-options `((((glyph color-x) ,(aref tetris-x-colors c)) (color-tty ,(aref tetris-tty-colors c)) (t nil))))) - ((= c tetris-border) - tetris-border-options) - ((= c tetris-space) - tetris-space-options) + ((= c tetris-border) + tetris-border-options) + ((= c tetris-space) + tetris-space-options) (t '(nil nil nil))))) options)) @@ -325,13 +324,13 @@ each one of its four blocks.") (let ((strings (vector (format "Shapes: %05d" tetris-n-shapes) (format "Rows: %05d" tetris-n-rows) (format "Score: %05d" tetris-score)))) - (loop for y from 0 to 2 do - (let* ((string (aref strings y)) - (len (length string))) - (loop for x from 0 to (1- len) do - (gamegrid-set-cell (+ tetris-score-x x) - (+ tetris-score-y y) - (aref string x))))))) + (dotimes (y 3) + (let* ((string (aref strings y)) + (len (length string))) + (dotimes (x len) + (gamegrid-set-cell (+ tetris-score-x x) + (+ tetris-score-y y) + (aref string x))))))) (defun tetris-update-score () (tetris-draw-score) @@ -351,88 +350,88 @@ each one of its four blocks.") (tetris-update-score))) (defun tetris-draw-next-shape () - (loop for x from 0 to 3 do - (loop for y from 0 to 3 do - (gamegrid-set-cell (+ tetris-next-x x) - (+ tetris-next-y y) - tetris-blank))) - (loop for i from 0 to 3 do - (let ((tetris-shape tetris-next-shape) - (tetris-rot 0)) - (gamegrid-set-cell (+ tetris-next-x - (aref (tetris-get-shape-cell i) 0)) - (+ tetris-next-y - (aref (tetris-get-shape-cell i) 1)) - tetris-shape)))) + (dotimes (x 4) + (dotimes (y 4) + (gamegrid-set-cell (+ tetris-next-x x) + (+ tetris-next-y y) + tetris-blank))) + (dotimes (i 4) + (let ((tetris-shape tetris-next-shape) + (tetris-rot 0)) + (gamegrid-set-cell (+ tetris-next-x + (aref (tetris-get-shape-cell i) 0)) + (+ tetris-next-y + (aref (tetris-get-shape-cell i) 1)) + tetris-shape)))) (defun tetris-draw-shape () - (loop for i from 0 to 3 do - (let ((c (tetris-get-shape-cell i))) - (gamegrid-set-cell (+ tetris-top-left-x - tetris-pos-x - (aref c 0)) - (+ tetris-top-left-y - tetris-pos-y - (aref c 1)) - tetris-shape)))) + (dotimes (i 4) + (let ((c (tetris-get-shape-cell i))) + (gamegrid-set-cell (+ tetris-top-left-x + tetris-pos-x + (aref c 0)) + (+ tetris-top-left-y + tetris-pos-y + (aref c 1)) + tetris-shape)))) (defun tetris-erase-shape () - (loop for i from 0 to 3 do - (let ((c (tetris-get-shape-cell i))) - (gamegrid-set-cell (+ tetris-top-left-x - tetris-pos-x - (aref c 0)) - (+ tetris-top-left-y - tetris-pos-y - (aref c 1)) - tetris-blank)))) + (dotimes (i 4) + (let ((c (tetris-get-shape-cell i))) + (gamegrid-set-cell (+ tetris-top-left-x + tetris-pos-x + (aref c 0)) + (+ tetris-top-left-y + tetris-pos-y + (aref c 1)) + tetris-blank)))) (defun tetris-test-shape () (let ((hit nil)) - (loop for i from 0 to 3 do - (unless hit - (setq hit - (let* ((c (tetris-get-shape-cell i)) - (xx (+ tetris-pos-x - (aref c 0))) - (yy (+ tetris-pos-y - (aref c 1)))) - (or (>= xx tetris-width) - (>= yy tetris-height) - (/= (gamegrid-get-cell - (+ xx tetris-top-left-x) - (+ yy tetris-top-left-y)) - tetris-blank)))))) + (dotimes (i 4) + (unless hit + (setq hit + (let* ((c (tetris-get-shape-cell i)) + (xx (+ tetris-pos-x + (aref c 0))) + (yy (+ tetris-pos-y + (aref c 1)))) + (or (>= xx tetris-width) + (>= yy tetris-height) + (/= (gamegrid-get-cell + (+ xx tetris-top-left-x) + (+ yy tetris-top-left-y)) + tetris-blank)))))) hit)) (defun tetris-full-row (y) (let ((full t)) - (loop for x from 0 to (1- tetris-width) do - (if (= (gamegrid-get-cell (+ tetris-top-left-x x) - (+ tetris-top-left-y y)) - tetris-blank) - (setq full nil))) + (dotimes (x tetris-width) + (if (= (gamegrid-get-cell (+ tetris-top-left-x x) + (+ tetris-top-left-y y)) + tetris-blank) + (setq full nil))) full)) (defun tetris-shift-row (y) (if (= y 0) - (loop for x from 0 to (1- tetris-width) do + (dotimes (x tetris-width) (gamegrid-set-cell (+ tetris-top-left-x x) (+ tetris-top-left-y y) tetris-blank)) - (loop for x from 0 to (1- tetris-width) do - (let ((c (gamegrid-get-cell (+ tetris-top-left-x x) - (+ tetris-top-left-y y -1)))) - (gamegrid-set-cell (+ tetris-top-left-x x) - (+ tetris-top-left-y y) + (dotimes (x tetris-width) + (let ((c (gamegrid-get-cell (+ tetris-top-left-x x) + (+ tetris-top-left-y y -1)))) + (gamegrid-set-cell (+ tetris-top-left-x x) + (+ tetris-top-left-y y) c))))) (defun tetris-shift-down () - (loop for y0 from 0 to (1- tetris-height) do - (if (tetris-full-row y0) - (progn (setq tetris-n-rows (1+ tetris-n-rows)) - (loop for y from y0 downto 0 do - (tetris-shift-row y)))))) + (dotimes (y0 tetris-height) + (when (tetris-full-row y0) + (setq tetris-n-rows (1+ tetris-n-rows)) + (cl-loop for y from y0 downto 0 do + (tetris-shift-row y))))) (defun tetris-draw-border-p () (or (not (eq gamegrid-display-mode 'glyph)) @@ -444,22 +443,22 @@ each one of its four blocks.") tetris-space) (let ((buffer-read-only nil)) (if (tetris-draw-border-p) - (loop for y from -1 to tetris-height do - (loop for x from -1 to tetris-width do - (gamegrid-set-cell (+ tetris-top-left-x x) - (+ tetris-top-left-y y) - tetris-border)))) - (loop for y from 0 to (1- tetris-height) do - (loop for x from 0 to (1- tetris-width) do - (gamegrid-set-cell (+ tetris-top-left-x x) - (+ tetris-top-left-y y) - tetris-blank))) + (cl-loop for y from -1 to tetris-height do + (cl-loop for x from -1 to tetris-width do + (gamegrid-set-cell (+ tetris-top-left-x x) + (+ tetris-top-left-y y) + tetris-border)))) + (dotimes (y tetris-height) + (dotimes (x tetris-width) + (gamegrid-set-cell (+ tetris-top-left-x x) + (+ tetris-top-left-y y) + tetris-blank))) (if (tetris-draw-border-p) - (loop for y from -1 to 4 do - (loop for x from -1 to 4 do - (gamegrid-set-cell (+ tetris-next-x x) - (+ tetris-next-y y) - tetris-border)))))) + (cl-loop for y from -1 to 4 do + (cl-loop for x from -1 to 4 do + (gamegrid-set-cell (+ tetris-next-x x) + (+ tetris-next-y y) + tetris-border)))))) (defun tetris-reset-game () (gamegrid-kill-timer) diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 61dc371c087..c008e1c4da3 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -30,7 +30,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'tool-bar) (require 'comint) @@ -791,7 +791,7 @@ info, are considered errors." 3))) (setq compilation-skip-threshold level) (message "Skipping %s" - (case compilation-skip-threshold + (pcase compilation-skip-threshold (0 "Nothing") (1 "Info messages") (2 "Warnings and info")))) @@ -826,7 +826,7 @@ from a different message." ;; modified using the same *compilation* buffer. this necessitates ;; re-parsing markers. -;; (defstruct (compilation--loc +;; (cl-defstruct (compilation--loc ;; (:constructor nil) ;; (:copier nil) ;; (:constructor compilation--make-loc @@ -875,7 +875,7 @@ from a different message." ;; These are the value of the `compilation-message' text-properties in the ;; compilation buffer. -(defstruct (compilation--message +(cl-defstruct (compilation--message (:constructor nil) (:copier nil) ;; (:type list) ;Old representation. @@ -1212,7 +1212,7 @@ FMTS is a list of format specs for transforming the file name. (goto-char end) (unless (bolp) ;; We generally don't like to parse partial lines. - (assert (eobp)) + (cl-assert (eobp)) (when (let ((proc (get-buffer-process (current-buffer)))) (and proc (memq (process-status proc) '(run open)))) (setq end (line-beginning-position)))) @@ -2415,7 +2415,7 @@ region and the first line of the next region." (push fs compilation-gcpro) (let ((loc (compilation-assq (or line 1) (cdr fs)))) (setq loc (compilation-assq col loc)) - (assert (null (cdr loc))) + (cl-assert (null (cdr loc))) (setcdr loc (compilation--make-cdrloc line fs marker)) loc))) @@ -2685,8 +2685,8 @@ The file-structure looks like this: (defun compilation--flush-file-structure (file) (or (consp file) (setq file (list file))) (let ((fs (compilation-get-file-structure file))) - (assert (eq fs (gethash file compilation-locs))) - (assert (eq fs (gethash (cons (caar fs) (cadr (car fs))) + (cl-assert (eq fs (gethash file compilation-locs))) + (cl-assert (eq fs (gethash (cons (caar fs) (cadr (car fs))) compilation-locs))) (maphash (lambda (k v) (if (eq v fs) (remhash k compilation-locs))) diff --git a/lisp/progmodes/cwarn.el b/lisp/progmodes/cwarn.el index 09c7e908806..9ea71ad36f5 100644 --- a/lisp/progmodes/cwarn.el +++ b/lisp/progmodes/cwarn.el @@ -105,8 +105,6 @@ ;;{{{ Dependencies -(eval-when-compile (require 'cl)) - (require 'custom) (require 'font-lock) (require 'cc-mode) diff --git a/lisp/progmodes/ebrowse.el b/lisp/progmodes/ebrowse.el index ce190d25157..1d29011762e 100644 --- a/lisp/progmodes/ebrowse.el +++ b/lisp/progmodes/ebrowse.el @@ -38,7 +38,7 @@ (require 'ebuff-menu) (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'helper)) @@ -249,6 +249,7 @@ This is a destructive operation." (defmacro ebrowse-output (&rest body) "Eval BODY with a writable current buffer. Preserve buffer's modified state." + (declare (indent 0) (debug t)) (let ((modified (make-symbol "--ebrowse-output--"))) `(let (buffer-read-only (,modified (buffer-modified-p))) (unwind-protect @@ -258,35 +259,30 @@ Preserve buffer's modified state." (defmacro ebrowse-ignoring-completion-case (&rest body) "Eval BODY with `completion-ignore-case' bound to t." + (declare (indent 0) (debug t)) `(let ((completion-ignore-case t)) ,@body)) - (defmacro ebrowse-save-selective (&rest body) "Eval BODY with `selective-display' restored at the end." - (let ((var (make-symbol "var"))) - `(let ((,var selective-display)) - (unwind-protect - (progn ,@body) - (setq selective-display ,var))))) - + (declare (indent 0) (debug t)) + ;; FIXME: Don't use selective-display. + `(let ((selective-display selective-display)) + ,@body)) (defmacro ebrowse-for-all-trees (spec &rest body) "For all trees in SPEC, eval BODY." + (declare (indent 1) (debug ((sexp form) body))) (let ((var (make-symbol "var")) (spec-var (car spec)) (array (cadr spec))) - `(loop for ,var being the symbols of ,array - as ,spec-var = (get ,var 'ebrowse-root) do - (when (vectorp ,spec-var) - ,@body)))) + `(cl-loop for ,var being the symbols of ,array + as ,spec-var = (get ,var 'ebrowse-root) do + (when (vectorp ,spec-var) + ,@body)))) ;;; Set indentation for macros above. -(put 'ebrowse-output 'lisp-indent-hook 0) -(put 'ebrowse-ignoring-completion-case 'lisp-indent-hook 0) -(put 'ebrowse-save-selective 'lisp-indent-hook 0) -(put 'ebrowse-for-all-trees 'lisp-indent-hook 1) (defsubst ebrowse-set-face (start end face) @@ -307,17 +303,6 @@ is STRING, but point is placed POSITION characters into the string." (ebrowse-ignoring-completion-case (completing-read prompt table nil t initial-input))) - -(defun ebrowse-value-in-buffer (sym buffer) - "Return the value of SYM in BUFFER." - (let ((old-buffer (current-buffer))) - (unwind-protect - (progn - (set-buffer buffer) - (symbol-value sym)) - (set-buffer old-buffer)))) - - (defun ebrowse-rename-buffer (new-name) "Rename current buffer to NEW-NAME. If a buffer with name NEW-NAME already exists, delete it first." @@ -333,9 +318,9 @@ If a buffer with name NEW-NAME already exists, delete it first." Replace sequences of newlines with a single space." (when (string-match "^[ \t\n\r]+" string) (setq string (substring string (match-end 0)))) - (loop while (string-match "[\n]+" string) - finally return string do - (setq string (replace-match " " nil t string)))) + (cl-loop while (string-match "[\n]+" string) + finally return string do + (setq string (replace-match " " nil t string)))) (defun ebrowse-width-of-drawable-area () @@ -350,7 +335,7 @@ otherwise use the current frame's width." ;;; Structure definitions -(defstruct (ebrowse-hs (:type vector) :named) +(cl-defstruct (ebrowse-hs (:type vector) :named) "Header structure found at the head of BROWSE files." ;; A version string that is compared against the version number of ;; the Lisp package when the file is loaded. This is done to @@ -367,7 +352,7 @@ otherwise use the current frame's width." member-table) -(defstruct (ebrowse-ts (:type vector) :named) +(cl-defstruct (ebrowse-ts (:type vector) :named) "Tree structure. Following the header structure, a BROWSE file contains a number of `ebrowse-ts' structures, each one describing one root class of @@ -387,7 +372,7 @@ the class hierarchy with all its subclasses." mark) -(defstruct (ebrowse-bs (:type vector) :named) +(cl-defstruct (ebrowse-bs (:type vector) :named) "Common sub-structure. A common structure defining an occurrence of some name in the source files." @@ -414,14 +399,14 @@ source files." point) -(defstruct (ebrowse-cs (:include ebrowse-bs) (:type vector) :named) +(cl-defstruct (ebrowse-cs (:include ebrowse-bs) (:type vector) :named) "Class structure. This is the structure stored in the CLASS slot of a `ebrowse-ts' structure. It describes the location of the class declaration." source-file) -(defstruct (ebrowse-ms (:include ebrowse-bs) (:type vector) :named) +(cl-defstruct (ebrowse-ms (:include ebrowse-bs) (:type vector) :named) "Member structure. This is the structure describing a single member. The `ebrowse-ts' structure contains various lists for the different types of @@ -691,7 +676,7 @@ MARKED-ONLY non-nil means include marked classes only." (ebrowse-for-all-trees (tree ebrowse--tree-obarray) (when (or (not marked-only) (ebrowse-ts-mark tree)) (let ((class (ebrowse-ts-class tree))) - (when (zerop (% (incf i) 20)) + (when (zerop (% (cl-incf i) 20)) (ebrowse-show-progress "Preparing file list" (zerop i))) ;; Add files mentioned in class description (let ((source-file (ebrowse-cs-source-file class)) @@ -701,14 +686,14 @@ MARKED-ONLY non-nil means include marked classes only." (when file (puthash file file files)) ;; For all member lists in this class - (loop for accessor in ebrowse-member-list-accessors do - (loop for m in (funcall accessor tree) - for file = (ebrowse-ms-file m) - for def-file = (ebrowse-ms-definition-file m) do - (when file - (puthash file file files)) - (when def-file - (puthash def-file def-file files)))))))) + (dolist (accessor ebrowse-member-list-accessors) + (cl-loop for m in (funcall accessor tree) + for file = (ebrowse-ms-file m) + for def-file = (ebrowse-ms-definition-file m) do + (when file + (puthash file file files)) + (when def-file + (puthash def-file def-file files)))))))) files)) @@ -721,11 +706,11 @@ MARKED-ONLY non-nil means include marked classes only." list)) -(defun* ebrowse-marked-classes-p () +(cl-defun ebrowse-marked-classes-p () "Value is non-nil if any class in the current class tree is marked." (ebrowse-for-all-trees (tree ebrowse--tree-obarray) (when (ebrowse-ts-mark tree) - (return-from ebrowse-marked-classes-p tree)))) + (cl-return-from ebrowse-marked-classes-p tree)))) (defsubst ebrowse-globals-tree-p (tree) @@ -752,12 +737,13 @@ The class tree is found in the buffer-local variable `ebrowse--tree-obarray'." (if qualified-names-p (ebrowse-for-all-trees (tree ebrowse--tree-obarray) (setq alist - (acons (ebrowse-qualified-class-name (ebrowse-ts-class tree)) - tree alist))) + (cl-acons (ebrowse-qualified-class-name + (ebrowse-ts-class tree)) + tree alist))) (ebrowse-for-all-trees (tree ebrowse--tree-obarray) (setq alist - (acons (ebrowse-cs-name (ebrowse-ts-class tree)) - tree alist)))) + (cl-acons (ebrowse-cs-name (ebrowse-ts-class tree)) + tree alist)))) alist)) @@ -792,15 +778,15 @@ This function must be used instead of the struct slot computes this information lazily." (or (ebrowse-ts-base-classes tree) (setf (ebrowse-ts-base-classes tree) - (loop with to-search = (list tree) - with result = nil - as search = (pop to-search) - while search finally return result - do (ebrowse-for-all-trees (ti ebrowse--tree-obarray) - (when (memq search (ebrowse-ts-subclasses ti)) - (unless (memq ti result) - (setq result (nconc result (list ti)))) - (push ti to-search))))))) + (cl-loop with to-search = (list tree) + with result = nil + as search = (pop to-search) + while search finally return result + do (ebrowse-for-all-trees (ti ebrowse--tree-obarray) + (when (memq search (ebrowse-ts-subclasses ti)) + (unless (memq ti result) + (setq result (nconc result (list ti)))) + (push ti to-search))))))) (defun ebrowse-direct-base-classes (tree) @@ -820,8 +806,8 @@ computes this information lazily." ACCESSOR is the accessor function for the member list. Elements of the result have the form (NAME . ACCESSOR), where NAME is the member name." - (loop for member in (funcall accessor tree) - collect (cons (ebrowse-ms-name member) accessor))) + (cl-loop for member in (funcall accessor tree) + collect (cons (ebrowse-ms-name member) accessor))) (defun ebrowse-name/accessor-alist-for-visible-members () @@ -834,10 +820,10 @@ structure. The list includes inherited members if these are visible." ebrowse--accessor))) (if ebrowse--show-inherited-flag (nconc list - (loop for tree in (ebrowse-base-classes - ebrowse--displayed-class) - nconc (ebrowse-name/accessor-alist - tree ebrowse--accessor))) + (cl-loop for tree in (ebrowse-base-classes + ebrowse--displayed-class) + nconc (ebrowse-name/accessor-alist + tree ebrowse--accessor))) list))) @@ -908,8 +894,7 @@ and TREE is a list of `ebrowse-ts' structures forming the class tree." See that variable's documentation for the meaning of IGNORE-AUTO-SAVE and NOCONFIRM." (when (or noconfirm (yes-or-no-p "Revert tree from disk? ")) - (loop for member-buffer in (ebrowse-same-tree-member-buffer-list) - do (kill-buffer member-buffer)) + (mapc #'kill-buffer (ebrowse-same-tree-member-buffer-list)) (erase-buffer) (with-no-warnings (insert-file (or buffer-file-name ebrowse--tags-file-name))) @@ -934,9 +919,9 @@ Return the buffer created." ebrowse--frozen-flag nil) (ebrowse-redraw-tree) (set-buffer-modified-p nil) - (case pop - (switch (switch-to-buffer name)) - (pop (pop-to-buffer name))) + (pcase pop + (`switch (switch-to-buffer name)) + (`pop (pop-to-buffer name))) (current-buffer))) @@ -962,14 +947,14 @@ type `ebrowse-hs' is set to the resulting obarray." (garbage-collect) ;; For all classes... (ebrowse-for-all-trees (c ebrowse--tree-obarray) - (when (zerop (% (incf i) 10)) + (when (zerop (% (cl-incf i) 10)) (ebrowse-show-progress "Preparing member lookup" (zerop i))) - (loop for f in ebrowse-member-list-accessors do - (loop for m in (funcall f c) do - (let* ((member-name (ebrowse-ms-name m)) - (value (gethash member-name members))) - (push (list c f m) value) - (puthash member-name value members))))) + (dolist (f ebrowse-member-list-accessors) + (dolist (m (funcall f c)) + (let* ((member-name (ebrowse-ms-name m)) + (value (gethash member-name members))) + (push (list c f m) value) + (puthash member-name value members))))) (setf (ebrowse-hs-member-table ebrowse--header) members))) @@ -977,11 +962,11 @@ type `ebrowse-hs' is set to the resulting obarray." "Return the member obarray. Build it if it hasn't been set up yet. HEADER is the tree header structure of the class tree." (when (null (ebrowse-hs-member-table header)) - (loop for buffer in (ebrowse-browser-buffer-list) - until (eq header (ebrowse-value-in-buffer 'ebrowse--header buffer)) - finally do - (with-current-buffer buffer - (ebrowse-fill-member-table)))) + (cl-loop for buffer in (ebrowse-browser-buffer-list) + until (eq header (buffer-local-value 'ebrowse--header buffer)) + finally do + (with-current-buffer buffer + (ebrowse-fill-member-table)))) (ebrowse-hs-member-table header)) @@ -993,11 +978,12 @@ HEADER is the tree header structure of the class tree." Build obarray of all classes in TREE." (let ((classes (make-vector 127 0))) ;; Add root classes... - (loop for root in tree - as sym = - (intern (ebrowse-qualified-class-name (ebrowse-ts-class root)) classes) - do (unless (get sym 'ebrowse-root) - (setf (get sym 'ebrowse-root) root))) + (cl-loop for root in tree + as sym = + (intern (ebrowse-qualified-class-name (ebrowse-ts-class root)) + classes) + do (unless (get sym 'ebrowse-root) + (setf (get sym 'ebrowse-root) root))) ;; Process subclasses (ebrowse-insert-supers tree classes) classes)) @@ -1015,29 +1001,30 @@ beginning of the base-class list. We have to be cautious here not to end up in an infinite recursion if for some reason a circle is in the inheritance graph." - (loop for class in tree - as subclasses = (ebrowse-ts-subclasses class) do - ;; Make sure every class is represented by a unique object - (loop for subclass on subclasses - as sym = (intern - (ebrowse-qualified-class-name (ebrowse-ts-class (car subclass))) - classes) - as next = nil - do - ;; Replace the subclass tree with the one found in - ;; CLASSES if there is already an entry for that class - ;; in it. Otherwise make a new entry. - ;; - ;; CAVEAT: If by some means (e.g., use of the - ;; preprocessor in class declarations, a name is marked - ;; as a subclass of itself on some path, we would end up - ;; in an endless loop. We have to omit subclasses from - ;; the recursion that already have been processed. - (if (get sym 'ebrowse-root) - (setf (car subclass) (get sym 'ebrowse-root)) - (setf (get sym 'ebrowse-root) (car subclass)))) - ;; Process subclasses - (ebrowse-insert-supers subclasses classes))) + (cl-loop for class in tree + as subclasses = (ebrowse-ts-subclasses class) do + ;; Make sure every class is represented by a unique object + (cl-loop for subclass on subclasses + as sym = (intern + (ebrowse-qualified-class-name + (ebrowse-ts-class (car subclass))) + classes) + as next = nil + do + ;; Replace the subclass tree with the one found in + ;; CLASSES if there is already an entry for that class + ;; in it. Otherwise make a new entry. + ;; + ;; CAVEAT: If by some means (e.g., use of the + ;; preprocessor in class declarations, a name is marked + ;; as a subclass of itself on some path, we would end up + ;; in an endless loop. We have to omit subclasses from + ;; the recursion that already have been processed. + (if (get sym 'ebrowse-root) + (setf (car subclass) (get sym 'ebrowse-root)) + (setf (get sym 'ebrowse-root) (car subclass)))) + ;; Process subclasses + (ebrowse-insert-supers subclasses classes))) ;;; Tree buffers @@ -1111,7 +1098,7 @@ Tree mode key bindings: (unless (zerop (buffer-size)) (goto-char (point-min)) - (multiple-value-setq (header tree) (values-list (ebrowse-read))) + (cl-multiple-value-setq (header tree) (cl-values-list (ebrowse-read))) (message "Sorting. Please be patient...") (setq tree (ebrowse-sort-tree-list tree)) (erase-buffer) @@ -1199,32 +1186,32 @@ If given a numeric N-TIMES argument, mark that many classes." ;; Get the classes whose mark must be toggled. Note that ;; ebrowse-tree-at-point might issue an error. (ignore-errors - (loop repeat (or n-times 1) - as tree = (ebrowse-tree-at-point) - do (progn - (setf (ebrowse-ts-mark tree) (not (ebrowse-ts-mark tree))) - (forward-line 1) - (push tree to-change)))) + (cl-loop repeat (or n-times 1) + as tree = (ebrowse-tree-at-point) + do (progn + (setf (ebrowse-ts-mark tree) (not (ebrowse-ts-mark tree))) + (forward-line 1) + (push tree to-change)))) (save-excursion ;; For all these classes, reverse the mark char in the display ;; by a regexp replace over the whole buffer. The reason for this ;; is that classes might have multiple base classes. If this is ;; the case, they are displayed more than once in the tree. (ebrowse-output - (loop for tree in to-change - as regexp = (concat "^.*\\b" - (regexp-quote - (ebrowse-cs-name (ebrowse-ts-class tree))) - "\\b") - do - (goto-char (point-min)) - (loop while (re-search-forward regexp nil t) - do (progn - (goto-char (match-beginning 0)) - (delete-char 1) - (insert-char (if (ebrowse-ts-mark tree) ?> ? ) 1) - (ebrowse-set-mark-props (1- (point)) (point) tree) - (goto-char (match-end 0))))))))) + (cl-loop + for tree in to-change + as regexp = (concat "^.*\\b" + (regexp-quote + (ebrowse-cs-name (ebrowse-ts-class tree))) + "\\b") + do + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (goto-char (match-beginning 0)) + (delete-char 1) + (insert-char (if (ebrowse-ts-mark tree) ?> ? ) 1) + (ebrowse-set-mark-props (1- (point)) (point) tree) + (goto-char (match-end 0)))))))) (defun ebrowse-mark-all-classes (prefix) @@ -1345,7 +1332,7 @@ one buffer. Prefer tree buffers over member buffers." (set (make-hash-table)) result) (dolist (buffer buffers) - (let ((tree (ebrowse-value-in-buffer 'ebrowse--tree buffer))) + (let ((tree (buffer-local-value 'ebrowse--tree buffer))) (unless (gethash tree set) (push buffer result)) (puthash tree t set))) @@ -1356,7 +1343,7 @@ one buffer. Prefer tree buffers over member buffers." "Return a list of members buffers with same tree as current buffer." (ebrowse-delete-if-not (lambda (buffer) - (eq (ebrowse-value-in-buffer 'ebrowse--tree buffer) + (eq (buffer-local-value 'ebrowse--tree buffer) ebrowse--tree)) (ebrowse-member-buffer-list))) @@ -1367,7 +1354,7 @@ one buffer. Prefer tree buffers over member buffers." Switch to buffer if prefix ARG. If no member buffer exists, make one." (interactive "P") - (let ((buf (or (first (ebrowse-same-tree-member-buffer-list)) + (let ((buf (or (cl-first (ebrowse-same-tree-member-buffer-list)) (get-buffer ebrowse-member-buffer-name) (ebrowse-tree-command:show-member-functions)))) (when buf @@ -1391,9 +1378,9 @@ If no member buffer exists, make one." (defun ebrowse-kill-member-buffers-displaying (tree) "Kill all member buffers displaying TREE." - (loop for buffer in (ebrowse-member-buffer-list) - as class = (ebrowse-value-in-buffer 'ebrowse--displayed-class buffer) - when (eq class tree) do (kill-buffer buffer))) + (cl-loop for buffer in (ebrowse-member-buffer-list) + as class = (buffer-local-value 'ebrowse--displayed-class buffer) + when (eq class tree) do (kill-buffer buffer))) (defun ebrowse-frozen-tree-buffer-name (tags-file) @@ -1429,7 +1416,7 @@ Pop to member buffer if no prefix ARG, to tree buffer otherwise." (int-to-string ebrowse--indentation) "): ") nil nil ebrowse--indentation)))) - (when (plusp width) + (when (cl-plusp width) (set (make-local-variable 'ebrowse--indentation) width) (ebrowse-redraw-tree)))) @@ -1504,7 +1491,7 @@ Read a class name from the minibuffer if CLASS is nil." (error "Not on a class"))) -(defun* ebrowse-view/find-class-declaration (&key view where) +(cl-defun ebrowse-view/find-class-declaration (&key view where) "View or find the declarator of the class point is on. VIEW non-nil means view it. WHERE is additional position info." (let* ((class (ebrowse-ts-class (ebrowse-tree-at-point))) @@ -1583,9 +1570,9 @@ and possibly kill the viewed buffer." exit-action ebrowse--view-exit-action)) ;; Delete the frame in which we viewed. (mapc 'delete-frame - (loop for frame in (frame-list) - when (not (assq frame original-frame-configuration)) - collect frame)) + (cl-loop for frame in (frame-list) + when (not (assq frame original-frame-configuration)) + collect frame)) (when exit-action (funcall exit-action buffer)))) @@ -1639,15 +1626,15 @@ specifies where to find/view the result." (unless (boundp 'view-mode-hook) (setq view-mode-hook nil)) (push 'ebrowse-find-pattern view-mode-hook) - (case where - (other-window (view-file-other-window file)) - (other-frame (ebrowse-view-file-other-frame file)) - (t (view-file file)))) + (pcase where + (`other-window (view-file-other-window file)) + (`other-frame (ebrowse-view-file-other-frame file)) + (_ (view-file file)))) (t - (case where - (other-window (find-file-other-window file)) - (other-frame (find-file-other-frame file)) - (t (find-file file))) + (pcase where + (`other-window (find-file-other-window file)) + (`other-frame (find-file-other-frame file)) + (_ (find-file file))) (ebrowse-find-pattern struc info)))) @@ -1657,14 +1644,14 @@ This is `regexp-quote' for most symbols, except for operator names which may contain whitespace. For these symbols, replace white space in the symbol name (generated by BROWSE) with a regular expression matching any number of whitespace characters." - (loop with regexp = (regexp-quote name) - with start = 0 - finally return regexp - while (string-match "[ \t]+" regexp start) - do (setq regexp (concat (substring regexp 0 (match-beginning 0)) - "[ \t]*" - (substring regexp (match-end 0))) - start (+ (match-beginning 0) 5)))) + (cl-loop with regexp = (regexp-quote name) + with start = 0 + finally return regexp + while (string-match "[ \t]+" regexp start) + do (setq regexp (concat (substring regexp 0 (match-beginning 0)) + "[ \t]*" + (substring regexp (match-end 0))) + start (+ (match-beginning 0) 5)))) (defun ebrowse-class-declaration-regexp (name) @@ -1692,7 +1679,7 @@ expression matching any number of whitespace characters." (concat "^[ \t]*#[ \t]*define[ \t]+" (regexp-quote name))) -(defun* ebrowse-find-pattern (&optional position info &aux viewing) +(cl-defun ebrowse-find-pattern (&optional position info &aux viewing) "Find a pattern. This is a kluge: Ebrowse allows you to find or view a file containing @@ -1711,25 +1698,26 @@ INFO is a list (TREE-HEADER TREE-OR-MEMBER MEMBER-LIST)." (start (ebrowse-bs-point position)) (offset 100) found) - (destructuring-bind (header class-or-member member-list) info + (pcase-let ((`(,header ,class-or-member ,member-list) info)) ;; If no pattern is specified, construct one from the member name. (when (stringp pattern) (setq pattern (concat "^.*" (regexp-quote pattern)))) ;; Construct a regular expression if none given. (unless pattern - (typecase class-or-member + (cl-typecase class-or-member (ebrowse-ms - (case member-list - ((ebrowse-ts-member-variables - ebrowse-ts-static-variables - ebrowse-ts-types) - (setf pattern (ebrowse-variable-declaration-regexp - (ebrowse-bs-name position)))) - (otherwise - (if (ebrowse-define-p class-or-member) - (setf pattern (ebrowse-pp-define-regexp (ebrowse-bs-name position))) - (setf pattern (ebrowse-function-declaration/definition-regexp - (ebrowse-bs-name position))))))) + (setf pattern + (pcase member-list + ((or `ebrowse-ts-member-variables + `ebrowse-ts-static-variables + `ebrowse-ts-types) + (ebrowse-variable-declaration-regexp + (ebrowse-bs-name position))) + (_ + (if (ebrowse-define-p class-or-member) + (ebrowse-pp-define-regexp (ebrowse-bs-name position)) + (ebrowse-function-declaration/definition-regexp + (ebrowse-bs-name position))))))) (ebrowse-cs (setf pattern (ebrowse-class-declaration-regexp (ebrowse-bs-name position)))))) @@ -1743,10 +1731,11 @@ INFO is a list (TREE-HEADER TREE-OR-MEMBER MEMBER-LIST)." (y-or-n-p (format "start = %d? " start)) (y-or-n-p pattern)) (setf found - (loop do (goto-char (max (point-min) (- start offset))) - when (re-search-forward pattern (+ start offset) t) return t - never (bobp) - do (incf offset offset))) + (cl-loop do (goto-char (max (point-min) (- start offset))) + when (re-search-forward pattern (+ start offset) t) + return t + never (bobp) + do (cl-incf offset offset))) (cond (found (beginning-of-line) (run-hooks 'ebrowse-view/find-hook)) @@ -1790,57 +1779,57 @@ TREE denotes the class shown." (ebrowse-set-face start end 'ebrowse-tree-mark)) -(defun* ebrowse-draw-tree-fn (&aux stack1 stack2 start) +(cl-defun ebrowse-draw-tree-fn (&aux stack1 stack2 start) "Display a single class and recursively its subclasses. This function may look weird, but this is faster than recursion." (setq stack1 (make-list (length ebrowse--tree) 0) stack2 (copy-sequence ebrowse--tree)) - (loop while stack2 - as level = (pop stack1) - as tree = (pop stack2) - as class = (ebrowse-ts-class tree) do - (let ((start-of-line (point)) - start-of-class-name end-of-class-name) - ;; Insert mark - (insert (if (ebrowse-ts-mark tree) ">" " ")) - - ;; Indent and insert class name - (indent-to (+ (* level ebrowse--indentation) - ebrowse-tree-left-margin)) - (setq start (point)) - (insert (ebrowse-qualified-class-name class)) - - ;; If template class, add <> - (when (ebrowse-template-p class) - (insert "<>")) - (ebrowse-set-face start (point) (if (zerop level) - 'ebrowse-root-class - 'ebrowse-default)) - (setf start-of-class-name start - end-of-class-name (point)) - ;; If filenames are to be displayed... - (when ebrowse--show-file-names-flag - (indent-to ebrowse-source-file-column) - (setq start (point)) - (insert "(" - (or (ebrowse-cs-file class) - "unknown") - ")") - (ebrowse-set-face start (point) 'ebrowse-file-name)) - (ebrowse-set-mark-props start-of-line (1+ start-of-line) tree) - (add-text-properties - start-of-class-name end-of-class-name - `(mouse-face highlight ebrowse-what class-name - ebrowse-tree ,tree - help-echo "double-mouse-1: (un)expand tree; mouse-2: member functions, mouse-3: menu")) - (insert "\n")) - ;; Push subclasses, if any. - (when (ebrowse-ts-subclasses tree) - (setq stack2 - (nconc (copy-sequence (ebrowse-ts-subclasses tree)) stack2) - stack1 - (nconc (make-list (length (ebrowse-ts-subclasses tree)) - (1+ level)) stack1))))) + (cl-loop while stack2 + as level = (pop stack1) + as tree = (pop stack2) + as class = (ebrowse-ts-class tree) do + (let ((start-of-line (point)) + start-of-class-name end-of-class-name) + ;; Insert mark + (insert (if (ebrowse-ts-mark tree) ">" " ")) + + ;; Indent and insert class name + (indent-to (+ (* level ebrowse--indentation) + ebrowse-tree-left-margin)) + (setq start (point)) + (insert (ebrowse-qualified-class-name class)) + + ;; If template class, add <> + (when (ebrowse-template-p class) + (insert "<>")) + (ebrowse-set-face start (point) (if (zerop level) + 'ebrowse-root-class + 'ebrowse-default)) + (setf start-of-class-name start + end-of-class-name (point)) + ;; If filenames are to be displayed... + (when ebrowse--show-file-names-flag + (indent-to ebrowse-source-file-column) + (setq start (point)) + (insert "(" + (or (ebrowse-cs-file class) + "unknown") + ")") + (ebrowse-set-face start (point) 'ebrowse-file-name)) + (ebrowse-set-mark-props start-of-line (1+ start-of-line) tree) + (add-text-properties + start-of-class-name end-of-class-name + `(mouse-face highlight ebrowse-what class-name + ebrowse-tree ,tree + help-echo "double-mouse-1: (un)expand tree; mouse-2: member functions, mouse-3: menu")) + (insert "\n")) + ;; Push subclasses, if any. + (when (ebrowse-ts-subclasses tree) + (setq stack2 + (nconc (copy-sequence (ebrowse-ts-subclasses tree)) stack2) + stack1 + (nconc (make-list (length (ebrowse-ts-subclasses tree)) + (1+ level)) stack1))))) @@ -2096,8 +2085,8 @@ See 'Electric-command-loop' for a description of STATE and CONDITION." "Read a browser buffer name from the minibuffer and return that buffer." (let* ((buffers (ebrowse-known-class-trees-buffer-list))) (if buffers - (if (not (second buffers)) - (first buffers) + (if (not (cl-second buffers)) + (cl-first buffers) (or (ebrowse-electric-choose-tree) (error "No tree buffer"))) (let* ((insert-default-directory t) (file (read-file-name "Find tree: " nil nil t))) @@ -2283,7 +2272,7 @@ The new width is read from the minibuffer." ebrowse--decl-column ebrowse--column-width)) "): "))))) - (when (plusp width) + (when (cl-plusp width) (if ebrowse--long-display-flag (setq ebrowse--decl-column width) (setq ebrowse--column-width width)) @@ -2323,15 +2312,15 @@ make one." (let ((index (ebrowse-position ebrowse--accessor ebrowse-member-list-accessors))) (setf ebrowse--accessor - (cond ((plusp incr) + (cond ((cl-plusp incr) (or (nth (1+ index) ebrowse-member-list-accessors) - (first ebrowse-member-list-accessors))) - ((minusp incr) - (or (and (>= (decf index) 0) + (cl-first ebrowse-member-list-accessors))) + ((cl-minusp incr) + (or (and (>= (cl-decf index) 0) (nth index ebrowse-member-list-accessors)) - (first (last ebrowse-member-list-accessors)))))) + (cl-first (last ebrowse-member-list-accessors)))))) (ebrowse-display-member-list-for-accessor ebrowse--accessor))) @@ -2516,7 +2505,7 @@ find file in another frame." (ebrowse-view/find-member-declaration/definition prefix t)) -(defun* ebrowse-view/find-member-declaration/definition +(cl-defun ebrowse-view/find-member-declaration/definition (prefix view &optional definition info header tags-file) "Find or view a member declaration or definition. With PREFIX 4. find file in another window, with prefix 5 @@ -2536,15 +2525,15 @@ TAGS-FILE is the file name of the BROWSE file." ;; If not given as parameters, get the necessary information ;; out of the member buffer. (if info - (setq tree (first info) - accessor (second info) - member (third info)) - (multiple-value-setq (tree member on-class) - (values-list (ebrowse-member-info-from-point))) + (setq tree (cl-first info) + accessor (cl-second info) + member (cl-third info)) + (cl-multiple-value-setq (tree member on-class) + (cl-values-list (ebrowse-member-info-from-point))) (setq accessor ebrowse--accessor)) ;; View/find class if on a line containing a class name. (when on-class - (return-from ebrowse-view/find-member-declaration/definition + (cl-return-from ebrowse-view/find-member-declaration/definition (ebrowse-view/find-file-and-search-pattern (ebrowse-ts-class tree) (list ebrowse--header (ebrowse-ts-class tree) nil) @@ -2802,11 +2791,11 @@ TREE is the class tree in which the members are found." mouse-face highlight ebrowse-tree ,tree help-echo "mouse-2: view definition; mouse-3: menu")) - (incf i) + (cl-incf i) (when (>= i ebrowse--n-columns) (setf i 0) (insert "\n"))))) - (when (plusp i) + (when (cl-plusp i) (insert "\n")) (goto-char (point-min)))) @@ -2884,7 +2873,7 @@ REPEAT, if specified, says repeat the search REPEAT times." (error "Not found")))) -(defun* ebrowse-move-point-to-member (name &optional count &aux member) +(cl-defun ebrowse-move-point-to-member (name &optional count &aux member) "Set point on member NAME in the member buffer COUNT, if specified, says search the COUNT'th member with the same name." (goto-char (point-min)) @@ -2905,8 +2894,8 @@ COUNT, if specified, says search the COUNT'th member with the same name." "Switch member buffer to a class read from the minibuffer. Use TITLE as minibuffer prompt. COMPL-LIST is a completion list to use." - (let* ((initial (unless (second compl-list) - (first (first compl-list)))) + (let* ((initial (unless (cl-second compl-list) + (cl-first (cl-first compl-list)))) (class (or (ebrowse-completing-read-value title compl-list initial) (error "Not found")))) (setf ebrowse--displayed-class class @@ -2926,14 +2915,14 @@ COMPL-LIST is a completion list to use." (interactive "P") (let ((supers (or (ebrowse-direct-base-classes ebrowse--displayed-class) (error "No base classes")))) - (if (and arg (second supers)) - (let ((alist (loop for s in supers - collect (cons (ebrowse-qualified-class-name - (ebrowse-ts-class s)) - s)))) + (if (and arg (cl-second supers)) + (let ((alist (cl-loop for s in supers + collect (cons (ebrowse-qualified-class-name + (ebrowse-ts-class s)) + s)))) (ebrowse-switch-member-buffer-to-other-class "Goto base class: " alist)) - (setq ebrowse--displayed-class (first supers) + (setq ebrowse--displayed-class (cl-first supers) ebrowse--member-list (funcall ebrowse--accessor ebrowse--displayed-class)) (ebrowse-redisplay-member-buffer)))) @@ -2958,20 +2947,21 @@ Prefix arg INC specifies which one." index cls (supers (ebrowse-direct-base-classes ebrowse--displayed-class))) (cl-flet ((trees-alist (trees) - (loop for tr in trees - collect (cons (ebrowse-cs-name - (ebrowse-ts-class tr)) tr)))) + (cl-loop for tr in trees + collect (cons (ebrowse-cs-name + (ebrowse-ts-class tr)) + tr)))) (when supers - (let ((tree (if (second supers) + (let ((tree (if (cl-second supers) (ebrowse-completing-read-value "Relative to base class: " (trees-alist supers) nil) - (first supers)))) + (cl-first supers)))) (unless tree (error "Not found")) (setq containing-list (ebrowse-ts-subclasses tree))))) (setq index (+ inc (ebrowse-position ebrowse--displayed-class containing-list))) - (cond ((minusp index) (message "No previous class")) + (cond ((cl-minusp index) (message "No previous class")) ((null (nth index containing-list)) (message "No next class"))) (setq index (max 0 (min index (1- (length containing-list))))) (setq cls (nth index containing-list)) @@ -2986,16 +2976,16 @@ Prefix arg ARG says which class should be displayed. Default is the first derived class." (interactive "P") (cl-flet ((ebrowse-tree-obarray-as-alist () - (loop for s in (ebrowse-ts-subclasses - ebrowse--displayed-class) - collect (cons (ebrowse-cs-name - (ebrowse-ts-class s)) s)))) + (cl-loop for s in (ebrowse-ts-subclasses + ebrowse--displayed-class) + collect (cons (ebrowse-cs-name + (ebrowse-ts-class s)) s)))) (let ((subs (or (ebrowse-ts-subclasses ebrowse--displayed-class) (error "No derived classes")))) - (if (and arg (second subs)) + (if (and arg (cl-second subs)) (ebrowse-switch-member-buffer-to-other-class "Goto derived class: " (ebrowse-tree-obarray-as-alist)) - (setq ebrowse--displayed-class (first subs) + (setq ebrowse--displayed-class (cl-first subs) ebrowse--member-list (funcall ebrowse--accessor ebrowse--displayed-class)) (ebrowse-redisplay-member-buffer))))) @@ -3191,15 +3181,15 @@ the first derived class." EVENT is the mouse event." (interactive "e") (mouse-set-point event) - (case (event-click-count event) + (pcase (event-click-count event) (2 (ebrowse-find-member-definition)) - (1 (case (get-text-property (posn-point (event-start event)) - 'ebrowse-what) - (member-name + (1 (pcase (get-text-property (posn-point (event-start event)) + 'ebrowse-what) + (`member-name (ebrowse-popup-menu ebrowse-member-name-object-menu event)) - (class-name + (`class-name (ebrowse-popup-menu ebrowse-member-class-name-object-menu event)) - (t + (_ (ebrowse-popup-menu ebrowse-member-buffer-object-menu event)))))) @@ -3208,11 +3198,11 @@ EVENT is the mouse event." EVENT is the mouse event." (interactive "e") (mouse-set-point event) - (case (event-click-count event) + (pcase (event-click-count event) (2 (ebrowse-find-member-definition)) - (1 (case (get-text-property (posn-point (event-start event)) + (1 (pcase (get-text-property (posn-point (event-start event)) 'ebrowse-what) - (member-name + (`member-name (ebrowse-view-member-definition 0)))))) @@ -3233,11 +3223,11 @@ member was found. The CDR of the acons is described in function alist) (when name (dolist (info (gethash name table) alist) - (unless (memq (first info) known-classes) - (setf alist (acons (ebrowse-qualified-class-name - (ebrowse-ts-class (first info))) - info alist) - known-classes (cons (first info) known-classes))))))) + (unless (memq (cl-first info) known-classes) + (setf alist (cl-acons (ebrowse-qualified-class-name + (ebrowse-ts-class (cl-first info))) + info alist) + known-classes (cons (cl-first info) known-classes))))))) (defun ebrowse-choose-tree () @@ -3247,8 +3237,8 @@ the one he wants. Value is (TREE HEADER BUFFER), with TREE being the class tree, HEADER the header structure of the tree, and BUFFER being the tree or member buffer containing the tree." (let* ((buffer (ebrowse-choose-from-browser-buffers))) - (if buffer (list (ebrowse-value-in-buffer 'ebrowse--tree buffer) - (ebrowse-value-in-buffer 'ebrowse--header buffer) + (if buffer (list (buffer-local-value 'ebrowse--tree buffer) + (buffer-local-value 'ebrowse--header buffer) buffer)))) @@ -3259,8 +3249,8 @@ Prompt with PROMPT. Insert into the minibuffer a C++ identifier read from point as default. Value is a list (CLASS-NAME MEMBER-NAME)." (save-excursion (let ((members (ebrowse-member-table header))) - (multiple-value-bind (class-name member-name) - (values-list (ebrowse-tags-read-member+class-name)) + (cl-multiple-value-bind (class-name member-name) + (cl-values-list (ebrowse-tags-read-member+class-name)) (unless member-name (error "No member name at point")) (if members @@ -3272,7 +3262,7 @@ from point as default. Value is a list (CLASS-NAME MEMBER-NAME)." (unless (gethash name members) (if (y-or-n-p "No exact match found. Try substrings? ") (setq name - (or (first (ebrowse-list-of-matching-members + (or (cl-first (ebrowse-list-of-matching-members members (regexp-quote name) name)) (error "Sorry, nothing found"))) (error "Canceled"))) @@ -3305,15 +3295,15 @@ Value is a list (TREE ACCESSOR MEMBER) for the member." (let ((alist (or (ebrowse-class-alist-for-member header name) (error "No classes with member `%s' found" name)))) (ebrowse-ignoring-completion-case - (if (null (second alist)) - (cdr (first alist)) + (if (null (cl-second alist)) + (cdr (cl-first alist)) (push ?\? unread-command-events) (cdr (assoc (completing-read "In class: " alist nil t initial-class-name) alist)))))) -(defun* ebrowse-tags-view/find-member-decl/defn +(cl-defun ebrowse-tags-view/find-member-decl/defn (prefix &key view definition member-name) "If VIEW is t, view, else find an occurrence of MEMBER-NAME. @@ -3324,16 +3314,16 @@ of all classes containing a member with the given name and lets the user choose the class to use. As a last step, a tags search is performed that positions point on the member declaration or definition." - (multiple-value-bind - (tree header tree-buffer) (values-list (ebrowse-choose-tree)) + (cl-multiple-value-bind + (tree header tree-buffer) (cl-values-list (ebrowse-choose-tree)) (unless tree (error "No class tree")) (let* ((marker (point-marker)) class-name (name member-name) info) (unless name - (multiple-value-setq (class-name name) - (values-list + (cl-multiple-value-setq (class-name name) + (cl-values-list (ebrowse-tags-read-name header (concat (if view "View" "Find") " member " @@ -3344,7 +3334,7 @@ definition." (ebrowse-view/find-member-declaration/definition prefix view definition info header - (ebrowse-value-in-buffer 'ebrowse--tags-file-name tree-buffer)) + (buffer-local-value 'ebrowse--tags-file-name tree-buffer)) ;; Record position jumped to (ebrowse-push-position (point-marker) info t)))) @@ -3439,14 +3429,14 @@ It is a list (TREE ACCESSOR MEMBER)." (cond ((null buffer) (set-buffer tree-buffer) (switch-to-buffer (ebrowse-display-member-buffer - (second info) nil (first info)))) + (cl-second info) nil (cl-first info)))) (t (switch-to-buffer buffer) - (setq ebrowse--displayed-class (first info) - ebrowse--accessor (second info) + (setq ebrowse--displayed-class (cl-first info) + ebrowse--accessor (cl-second info) ebrowse--member-list (funcall ebrowse--accessor ebrowse--displayed-class)) (ebrowse-redisplay-member-buffer))) - (ebrowse-move-point-to-member (ebrowse-ms-name (third info))))) + (ebrowse-move-point-to-member (ebrowse-ms-name (cl-third info))))) (defun ebrowse-tags-display-member-buffer (&optional fix-name) @@ -3454,13 +3444,13 @@ It is a list (TREE ACCESSOR MEMBER)." FIX-NAME non-nil means display the buffer for that member. Otherwise read a member name from point." (interactive) - (multiple-value-bind - (tree header tree-buffer) (values-list (ebrowse-choose-tree)) + (cl-multiple-value-bind + (tree header tree-buffer) (cl-values-list (ebrowse-choose-tree)) (unless tree (error "No class tree")) (let* ((marker (point-marker)) class-name (name fix-name) info) (unless name - (multiple-value-setq (class-name name) - (values-list + (cl-multiple-value-setq (class-name name) + (cl-values-list (ebrowse-tags-read-name header (concat "Find member list of: "))))) (setq info (ebrowse-tags-choose-class tree header name class-name)) @@ -3487,7 +3477,7 @@ are not performed." (interactive) (let* ((buffer (or (ebrowse-choose-from-browser-buffers) (error "No tree buffer"))) - (header (ebrowse-value-in-buffer 'ebrowse--header buffer)) + (header (buffer-local-value 'ebrowse--header buffer)) (members (ebrowse-member-table header)) temp-buffer-setup-hook (regexp (read-from-minibuffer "List members matching regexp: "))) @@ -3495,9 +3485,9 @@ are not performed." (set-buffer standard-output) (erase-buffer) (insert "Members matching `" regexp "'\n\n") - (loop for s in (ebrowse-list-of-matching-members members regexp) do - (loop for info in (gethash s members) do - (ebrowse-draw-file-member-info info)))))) + (cl-loop for s in (ebrowse-list-of-matching-members members regexp) do + (cl-loop for info in (gethash s members) do + (ebrowse-draw-file-member-info info)))))) (defun ebrowse-tags-list-members-in-file () @@ -3508,50 +3498,50 @@ The file name is read from the minibuffer." (error "No tree buffer"))) (files (with-current-buffer buffer (ebrowse-files-table))) (file (completing-read "List members in file: " files nil t)) - (header (ebrowse-value-in-buffer 'ebrowse--header buffer)) + (header (buffer-local-value 'ebrowse--header buffer)) temp-buffer-setup-hook (members (ebrowse-member-table header))) (with-output-to-temp-buffer (concat "*Members in file " file "*") (set-buffer standard-output) (maphash (lambda (_member-name list) - (loop for info in list - as member = (third info) - as class = (ebrowse-ts-class (first info)) - when (or (and (null (ebrowse-ms-file member)) - (string= (ebrowse-cs-file class) file)) - (string= file (ebrowse-ms-file member))) - do (ebrowse-draw-file-member-info info "decl.") - when (or (and (null (ebrowse-ms-definition-file member)) - (string= (ebrowse-cs-source-file class) file)) - (string= file (ebrowse-ms-definition-file member))) - do (ebrowse-draw-file-member-info info "defn."))) + (cl-loop for info in list + as member = (cl-third info) + as class = (ebrowse-ts-class (cl-first info)) + when (or (and (null (ebrowse-ms-file member)) + (string= (ebrowse-cs-file class) file)) + (string= file (ebrowse-ms-file member))) + do (ebrowse-draw-file-member-info info "decl.") + when (or (and (null (ebrowse-ms-definition-file member)) + (string= (ebrowse-cs-source-file class) file)) + (string= file (ebrowse-ms-definition-file member))) + do (ebrowse-draw-file-member-info info "defn."))) members)))) -(defun* ebrowse-draw-file-member-info (info &optional (kind "")) +(cl-defun ebrowse-draw-file-member-info (info &optional (kind "")) "Display a line in the members info buffer. INFO describes the member. It has the form (TREE ACCESSOR MEMBER). TREE is the class of the member to display. ACCESSOR is the accessor symbol of its member list. MEMBER is the member structure. KIND is an additional string printed in the buffer." - (let* ((tree (first info)) + (let* ((tree (cl-first info)) (globals-p (ebrowse-globals-tree-p tree))) (unless globals-p (insert (ebrowse-cs-name (ebrowse-ts-class tree)))) - (insert "::" (ebrowse-ms-name (third info))) + (insert "::" (ebrowse-ms-name (cl-third info))) (indent-to 40) (insert kind) (indent-to 50) - (insert (case (second info) - (ebrowse-ts-member-functions "member function") - (ebrowse-ts-member-variables "member variable") - (ebrowse-ts-static-functions "static function") - (ebrowse-ts-static-variables "static variable") - (ebrowse-ts-friends (if globals-p "define" "friend")) - (ebrowse-ts-types "type") - (t "unknown")) + (insert (pcase (cl-second info) + (`ebrowse-ts-member-functions "member function") + (`ebrowse-ts-member-variables "member variable") + (`ebrowse-ts-static-functions "static function") + (`ebrowse-ts-static-variables "static variable") + (`ebrowse-ts-friends (if globals-p "define" "friend")) + (`ebrowse-ts-types "type") + (_ "unknown")) "\n"))) (defvar ebrowse-last-completion nil @@ -3582,11 +3572,11 @@ KIND is an additional string printed in the buffer." If there's only one tree loaded, use that. Otherwise let the use choose a tree." (let* ((buffers (ebrowse-known-class-trees-buffer-list)) - (buffer (cond ((and (first buffers) (not (second buffers))) - (first buffers)) + (buffer (cond ((and (cl-first buffers) (not (cl-second buffers))) + (cl-first buffers)) (t (or (ebrowse-electric-choose-tree) (error "No tree buffer"))))) - (header (ebrowse-value-in-buffer 'ebrowse--header buffer))) + (header (buffer-local-value 'ebrowse--header buffer))) (ebrowse-member-table header))) @@ -3594,13 +3584,13 @@ use choose a tree." "Return the item following STRING in LIST. If STRING is the last element, return the first element as successor." (or (nth (1+ (ebrowse-position string list 'string=)) list) - (first list))) + (cl-first list))) ;;; Symbol completion ;;;###autoload -(defun* ebrowse-tags-complete-symbol (prefix) +(cl-defun ebrowse-tags-complete-symbol (prefix) "Perform completion on the C++ symbol preceding point. A second call of this function without changing point inserts the next match. A call with prefix PREFIX reads the symbol to insert from the minibuffer with @@ -3640,7 +3630,7 @@ completion." ;; buffer: Start new completion. (t (let* ((members (ebrowse-some-member-table)) - (completion (first (all-completions pattern members nil)))) + (completion (cl-first (all-completions pattern members nil)))) (cond ((eq completion t)) ((null completion) (error "Can't find completion for `%s'" pattern)) @@ -3766,15 +3756,15 @@ Searches in all files mentioned in a class tree for something that looks like a function call to the member." (interactive) ;; Choose the tree to use if there is more than one. - (multiple-value-bind (tree header tree-buffer) - (values-list (ebrowse-choose-tree)) + (cl-multiple-value-bind (tree header tree-buffer) + (cl-values-list (ebrowse-choose-tree)) (unless tree (error "No class tree")) ;; Get the member name NAME (class-name is ignored). (let ((name fix-name) class-name regexp) (unless name - (multiple-value-setq (class-name name) - (values-list (ebrowse-tags-read-name header "Find calls of: ")))) + (cl-multiple-value-setq (class-name name) + (cl-values-list (ebrowse-tags-read-name header "Find calls of: ")))) ;; Set tags loop form to search for member and begin loop. (setq regexp (concat "\\<" name "[ \t]*(") ebrowse-tags-loop-form (list 're-search-forward regexp nil t)) @@ -3786,7 +3776,7 @@ looks like a function call to the member." ;;; Structures of this kind are the elements of the position stack. -(defstruct (ebrowse-position (:type vector) :named) +(cl-defstruct (ebrowse-position (:type vector) :named) file-name ; in which file point ; point in file target ; t if target of a jump @@ -3806,8 +3796,8 @@ looks like a function call to the member." The string is printed in the electric position list buffer." (let ((info (ebrowse-position-info position))) (concat (if (ebrowse-position-target position) "at " "to ") - (ebrowse-cs-name (ebrowse-ts-class (first info))) - "::" (ebrowse-ms-name (third info))))) + (ebrowse-cs-name (ebrowse-ts-class (cl-first info))) + "::" (ebrowse-ms-name (cl-third info))))) (defun ebrowse-view/find-position (position &optional view) @@ -3837,7 +3827,7 @@ Positions in buffers that have no file names are not saved." (let ((too-much (- (length ebrowse-position-stack) ebrowse-max-positions))) ;; Do not let the stack grow to infinity. - (when (plusp too-much) + (when (cl-plusp too-much) (setq ebrowse-position-stack (butlast ebrowse-position-stack too-much))) ;; Push the position. @@ -4108,9 +4098,9 @@ Otherwise, FILE-NAME specifies the file to save the tree in." (let ((tree-file (buffer-file-name)) temp-buffer-setup-hook) (with-output-to-temp-buffer "*Tree Statistics*" - (multiple-value-bind (classes member-functions member-variables + (cl-multiple-value-bind (classes member-functions member-variables static-functions static-variables) - (values-list (ebrowse-gather-statistics)) + (cl-values-list (ebrowse-gather-statistics)) (set-buffer standard-output) (erase-buffer) (insert "STATISTICS FOR TREE " (or tree-file "unknown") ":\n\n") @@ -4142,11 +4132,11 @@ NUMBER-OF-STATIC-VARIABLES:" (let ((classes 0) (member-functions 0) (member-variables 0) (static-functions 0) (static-variables 0)) (ebrowse-for-all-trees (tree ebrowse--tree-obarray) - (incf classes) - (incf member-functions (length (ebrowse-ts-member-functions tree))) - (incf member-variables (length (ebrowse-ts-member-variables tree))) - (incf static-functions (length (ebrowse-ts-static-functions tree))) - (incf static-variables (length (ebrowse-ts-static-variables tree)))) + (cl-incf classes) + (cl-incf member-functions (length (ebrowse-ts-member-functions tree))) + (cl-incf member-variables (length (ebrowse-ts-member-variables tree))) + (cl-incf static-functions (length (ebrowse-ts-static-functions tree))) + (cl-incf static-variables (length (ebrowse-ts-static-variables tree)))) (list classes member-functions member-variables static-functions static-variables))) @@ -4390,12 +4380,12 @@ EVENT is the mouse event." (mouse-set-point event) (let* ((where (posn-point (event-start event))) (property (get-text-property where 'ebrowse-what))) - (case (event-click-count event) + (pcase (event-click-count event) (1 - (case property - (class-name + (pcase property + (`class-name (ebrowse-popup-menu ebrowse-tree-buffer-class-object-menu event)) - (t + (_ (ebrowse-popup-menu ebrowse-tree-buffer-object-menu event))))))) @@ -4406,9 +4396,9 @@ EVENT is the mouse event." (mouse-set-point event) (let* ((where (posn-point (event-start event))) (property (get-text-property where 'ebrowse-what))) - (case (event-click-count event) - (1 (case property - (class-name + (pcase (event-click-count event) + (1 (pcase property + (`class-name (ebrowse-tree-command:show-member-functions))))))) @@ -4419,13 +4409,13 @@ EVENT is the mouse event." (mouse-set-point event) (let* ((where (posn-point (event-start event))) (property (get-text-property where 'ebrowse-what))) - (case (event-click-count event) - (2 (case property - (class-name + (pcase (event-click-count event) + (2 (pcase property + (`class-name (let ((collapsed (save-excursion (skip-chars-forward "^\r\n") (looking-at "\r")))) (ebrowse-collapse-fn (not collapsed)))) - (mark + (`mark (ebrowse-toggle-mark-at-point 1))))))) diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index 2664b51eea9..071a0fb6037 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -26,8 +26,6 @@ ;;; Code: -(eval-when-compile - (require 'cl)) (require 'ring) (require 'button) diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index a410f45eeb4..85f8b64cf44 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -35,7 +35,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (if (featurep 'xemacs) (require 'overlay)) (defvar flymake-is-running nil @@ -684,7 +684,7 @@ It's flymake process filter." (defun flymake-er-get-line-err-info-list (err-info) (nth 1 err-info)) -(defstruct (flymake-ler +(cl-defstruct (flymake-ler (:constructor nil) (:constructor flymake-ler-make-ler (file line type text &optional full-file))) file line type text full-file) diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el index 5ea0f6a3fd2..23a34b85194 100644 --- a/lisp/progmodes/gdb-mi.el +++ b/lisp/progmodes/gdb-mi.el @@ -91,7 +91,7 @@ (require 'gud) (require 'json) (require 'bindat) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (declare-function speedbar-change-initial-expansion-list "speedbar" (new-default)) @@ -2269,8 +2269,7 @@ Return position where LINE begins." ;; gdb-table struct is a way to programmatically construct simple ;; tables. It help to reliably align columns of data in GDB buffers ;; and provides -(defstruct - gdb-table +(cl-defstruct gdb-table (column-sizes nil) (rows nil) (row-properties nil) @@ -2757,9 +2756,9 @@ corresponding to the mode line clicked." (add-to-list 'gdb-threads-list (cons (bindat-get-field thread 'id) thread)) - (if running - (incf gdb-running-threads-count) - (incf gdb-stopped-threads-count)) + (cl-incf (if running + gdb-running-threads-count + gdb-stopped-threads-count)) (gdb-table-add-row table (list diff --git a/lisp/progmodes/glasses.el b/lisp/progmodes/glasses.el index 7c131dd316c..a5ac7b43057 100644 --- a/lisp/progmodes/glasses.el +++ b/lisp/progmodes/glasses.el @@ -51,10 +51,6 @@ ;;; Code: -(eval-when-compile - (require 'cl)) - - ;;; User variables diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index 0b67bbed7ea..8912e67d603 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -37,8 +37,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) ; for case macro - (require 'comint) (defvar gdb-active-process) @@ -528,10 +526,10 @@ required by the caller." nil 'gdb-edit-value) nil (if gdb-show-changed-values - (or parent (case status - (changed 'font-lock-warning-face) - (out-of-scope 'shadow) - (t t))) + (or parent (pcase status + (`changed 'font-lock-warning-face) + (`out-of-scope 'shadow) + (_ t))) t) depth) (if (eq status 'out-of-scope) (setq parent 'shadow)) @@ -549,10 +547,10 @@ required by the caller." nil 'gdb-edit-value) nil (if gdb-show-changed-values - (or parent (case status - (changed 'font-lock-warning-face) - (out-of-scope 'shadow) - (t t))) + (or parent (pcase status + (`changed 'font-lock-warning-face) + (`out-of-scope 'shadow) + (_ t))) t) depth) (speedbar-make-tag-line @@ -3412,11 +3410,11 @@ With arg, dereference expr if ARG is positive, otherwise do not dereference." (defun gud-tooltip-print-command (expr) "Return a suitable command to print the expression EXPR." - (case gud-minor-mode - (gdbmi (concat "-data-evaluate-expression " expr)) - (dbx (concat "print " expr)) - ((xdb pdb) (concat "p " expr)) - (sdb (concat expr "/")))) + (pcase gud-minor-mode + (`gdbmi (concat "-data-evaluate-expression " expr)) + (`dbx (concat "print " expr)) + ((or `xdb `pdb) (concat "p " expr)) + (`sdb (concat expr "/")))) (declare-function gdb-input "gdb-mi" (command handler)) (declare-function tooltip-expr-to-print "tooltip" (event)) diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el index 2e943be412b..519e5aef2bc 100644 --- a/lisp/progmodes/js.el +++ b/lisp/progmodes/js.el @@ -54,7 +54,7 @@ (require 'json nil t) (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'comint) (require 'ido)) @@ -240,12 +240,11 @@ name as matched contains ") (defconst js--available-frameworks - (loop with available-frameworks - for style in js--class-styles - for framework = (plist-get style :framework) - unless (memq framework available-frameworks) - collect framework into available-frameworks - finally return available-frameworks) + (cl-loop for style in js--class-styles + for framework = (plist-get style :framework) + unless (memq framework available-frameworks) + collect framework into available-frameworks + finally return available-frameworks) "List of available JavaScript frameworks symbols.") (defconst js--function-heading-1-re @@ -374,7 +373,7 @@ Match group 1 is the name of the macro.") ;; (The exception for b-end and its caveats is described below.) ;; -(defstruct (js--pitem (:type list)) +(cl-defstruct (js--pitem (:type list)) ;; IMPORTANT: Do not alter the position of fields within the list. ;; Various bits of code depend on their positions, particularly ;; anything that manipulates the list of children. @@ -555,10 +554,10 @@ getting timeout messages." (make-variable-buffer-local 'js--state-at-last-parse-pos) (defun js--flatten-list (list) - (loop for item in list - nconc (cond ((consp item) - (js--flatten-list item)) - (item (list item))))) + (cl-loop for item in list + nconc (cond ((consp item) + (js--flatten-list item)) + (item (list item))))) (defun js--maybe-join (prefix separator suffix &rest list) "Helper function for `js--update-quick-match-re'. @@ -768,13 +767,13 @@ If invoked while inside a macro, treat the macro as normal text." "Move forward over a whole JavaScript expression. This function doesn't move over expressions continued across lines." - (loop + (cl-loop ;; non-continued case; simplistic, but good enough? - do (loop until (or (eolp) - (progn - (forward-comment most-positive-fixnum) - (memq (char-after) '(?\, ?\; ?\] ?\) ?\})))) - do (forward-sexp)) + do (cl-loop until (or (eolp) + (progn + (forward-comment most-positive-fixnum) + (memq (char-after) '(?\, ?\; ?\] ?\) ?\})))) + do (forward-sexp)) while (and (eq (char-after) ?\n) (save-excursion @@ -788,7 +787,7 @@ This puts point at the 'function' keyword. If this is a syntactically-correct non-expression function, return the name of the function, or t if the name could not be determined. Otherwise, return nil." - (assert (looking-at "\\_<function\\_>")) + (cl-assert (looking-at "\\_<function\\_>")) (let ((name t)) (forward-word) (forward-comment most-positive-fixnum) @@ -847,32 +846,32 @@ anything." "Helper function for `js--beginning-of-defun-nested'. If PSTATE represents a non-empty top-level defun, return the top-most pitem. Otherwise, return nil." - (loop for pitem in pstate - with func-depth = 0 - with func-pitem - if (eq 'function (js--pitem-type pitem)) - do (incf func-depth) - and do (setq func-pitem pitem) - finally return (if (eq func-depth 1) func-pitem))) + (cl-loop for pitem in pstate + with func-depth = 0 + with func-pitem + if (eq 'function (js--pitem-type pitem)) + do (cl-incf func-depth) + and do (setq func-pitem pitem) + finally return (if (eq func-depth 1) func-pitem))) (defun js--beginning-of-defun-nested () "Helper function for `js--beginning-of-defun'. Return the pitem of the function we went to the beginning of." (or ;; Look for the smallest function that encloses point... - (loop for pitem in (js--parse-state-at-point) - if (and (eq 'function (js--pitem-type pitem)) - (js--inside-pitem-p pitem)) - do (goto-char (js--pitem-h-begin pitem)) - and return pitem) + (cl-loop for pitem in (js--parse-state-at-point) + if (and (eq 'function (js--pitem-type pitem)) + (js--inside-pitem-p pitem)) + do (goto-char (js--pitem-h-begin pitem)) + and return pitem) ;; ...and if that isn't found, look for the previous top-level ;; defun - (loop for pstate = (js--backward-pstate) - while pstate - if (js--pstate-is-toplevel-defun pstate) - do (goto-char (js--pitem-h-begin it)) - and return it))) + (cl-loop for pstate = (js--backward-pstate) + while pstate + if (js--pstate-is-toplevel-defun pstate) + do (goto-char (js--pitem-h-begin it)) + and return it))) (defun js--beginning-of-defun-flat () "Helper function for `js-beginning-of-defun'." @@ -884,7 +883,7 @@ Return the pitem of the function we went to the beginning of." "Value of `beginning-of-defun-function' for `js-mode'." (setq arg (or arg 1)) (while (and (not (eobp)) (< arg 0)) - (incf arg) + (cl-incf arg) (when (and (not js-flat-functions) (or (eq (js-syntactic-context) 'function) (js--function-prologue-beginning))) @@ -896,7 +895,7 @@ Return the pitem of the function we went to the beginning of." (goto-char (point-max)))) (while (> arg 0) - (decf arg) + (cl-decf arg) ;; If we're just past the end of a function, the user probably wants ;; to go to the beginning of *that* function (when (eq (char-before) ?}) @@ -925,14 +924,14 @@ BEG defaults to `point-min', meaning to flush the entire cache." (defun js--ensure-cache--pop-if-ended (open-items paren-depth) (let ((top-item (car open-items))) (when (<= paren-depth (js--pitem-paren-depth top-item)) - (assert (not (get-text-property (1- (point)) 'js-pend))) + (cl-assert (not (get-text-property (1- (point)) 'js-pend))) (put-text-property (1- (point)) (point) 'js--pend top-item) (setf (js--pitem-b-end top-item) (point)) (setq open-items ;; open-items must contain at least two items for this to ;; work, but because we push a dummy item to start with, ;; that assumption holds. - (cons (js--pitem-add-child (second open-items) top-item) + (cons (js--pitem-add-child (cl-second open-items) top-item) (cddr open-items))))) open-items) @@ -950,7 +949,7 @@ the body of `js--ensure-cache'." ;; Make sure parse-partial-sexp doesn't stop because we *entered* ;; the given depth -- i.e., make sure we're deeper than the target ;; depth. - (assert (> (nth 0 parse) + (cl-assert (> (nth 0 parse) (js--pitem-paren-depth (car open-items)))) (setq parse (parse-partial-sexp prev-parse-point goal-point @@ -1045,10 +1044,10 @@ LIMIT defaults to point." ;; Figure out which class styles we need to look for (setq filtered-class-styles - (loop for style in js--class-styles - if (memq (plist-get style :framework) - js-enabled-frameworks) - collect style)) + (cl-loop for style in js--class-styles + if (memq (plist-get style :framework) + js-enabled-frameworks) + collect style)) (save-excursion (save-restriction @@ -1067,7 +1066,7 @@ LIMIT defaults to point." (unless (bobp) (setq open-items (get-text-property (1- (point)) 'js--pstate)) - (assert open-items)))) + (cl-assert open-items)))) (unless open-items ;; Make a placeholder for the top-level definition @@ -1080,97 +1079,98 @@ LIMIT defaults to point." (narrow-to-region (point-min) limit) - (loop while (re-search-forward js--quick-match-re-func nil t) - for orig-match-start = (goto-char (match-beginning 0)) - for orig-match-end = (match-end 0) - do (js--ensure-cache--update-parse) - for orig-depth = (nth 0 parse) - - ;; Each of these conditions should return non-nil if - ;; we should add a new item and leave point at the end - ;; of the new item's header (h-end in the - ;; js--pitem diagram). This point is the one - ;; after the last character we need to unambiguously - ;; detect this construct. If one of these evaluates to - ;; nil, the location of the point is ignored. - if (cond - ;; In comment or string - ((nth 8 parse) nil) - - ;; Regular function declaration - ((and (looking-at "\\_<function\\_>") - (setq name (js--forward-function-decl))) - - (when (eq name t) - (setq name (js--guess-function-name orig-match-end)) - (if name - (when js--guess-function-name-start - (setq orig-match-start - js--guess-function-name-start)) - - (setq name t))) - - (assert (eq (char-after) ?{)) - (forward-char) - (make-js--pitem - :paren-depth orig-depth - :h-begin orig-match-start - :type 'function - :name (if (eq name t) - name - (js--split-name name)))) - - ;; Macro - ((looking-at js--macro-decl-re) - - ;; Macros often contain unbalanced parentheses. - ;; Make sure that h-end is at the textual end of - ;; the macro no matter what the parenthesis say. - (c-end-of-macro) - (js--ensure-cache--update-parse) - - (make-js--pitem - :paren-depth (nth 0 parse) - :h-begin orig-match-start - :type 'macro - :name (list (match-string-no-properties 1)))) - - ;; "Prototype function" declaration - ((looking-at js--plain-method-re) - (goto-char (match-beginning 3)) - (when (save-match-data - (js--forward-function-decl)) - (forward-char) - (make-js--pitem - :paren-depth orig-depth - :h-begin orig-match-start - :type 'function - :name (nconc (js--split-name - (match-string-no-properties 1)) - (list (match-string-no-properties 2)))))) - - ;; Class definition - ((loop with syntactic-context = - (js--syntactic-context-from-pstate open-items) - for class-style in filtered-class-styles - if (and (memq syntactic-context - (plist-get class-style :contexts)) - (looking-at (plist-get class-style - :class-decl))) - do (goto-char (match-end 0)) - and return - (make-js--pitem - :paren-depth orig-depth - :h-begin orig-match-start - :type class-style - :name (js--split-name - (match-string-no-properties 1)))))) - - do (js--ensure-cache--update-parse) - and do (push it open-items) - and do (put-text-property - (1- (point)) (point) 'js--pstate open-items) - else do (goto-char orig-match-end)) + (cl-loop while (re-search-forward js--quick-match-re-func nil t) + for orig-match-start = (goto-char (match-beginning 0)) + for orig-match-end = (match-end 0) + do (js--ensure-cache--update-parse) + for orig-depth = (nth 0 parse) + + ;; Each of these conditions should return non-nil if + ;; we should add a new item and leave point at the end + ;; of the new item's header (h-end in the + ;; js--pitem diagram). This point is the one + ;; after the last character we need to unambiguously + ;; detect this construct. If one of these evaluates to + ;; nil, the location of the point is ignored. + if (cond + ;; In comment or string + ((nth 8 parse) nil) + + ;; Regular function declaration + ((and (looking-at "\\_<function\\_>") + (setq name (js--forward-function-decl))) + + (when (eq name t) + (setq name (js--guess-function-name orig-match-end)) + (if name + (when js--guess-function-name-start + (setq orig-match-start + js--guess-function-name-start)) + + (setq name t))) + + (cl-assert (eq (char-after) ?{)) + (forward-char) + (make-js--pitem + :paren-depth orig-depth + :h-begin orig-match-start + :type 'function + :name (if (eq name t) + name + (js--split-name name)))) + + ;; Macro + ((looking-at js--macro-decl-re) + + ;; Macros often contain unbalanced parentheses. + ;; Make sure that h-end is at the textual end of + ;; the macro no matter what the parenthesis say. + (c-end-of-macro) + (js--ensure-cache--update-parse) + + (make-js--pitem + :paren-depth (nth 0 parse) + :h-begin orig-match-start + :type 'macro + :name (list (match-string-no-properties 1)))) + + ;; "Prototype function" declaration + ((looking-at js--plain-method-re) + (goto-char (match-beginning 3)) + (when (save-match-data + (js--forward-function-decl)) + (forward-char) + (make-js--pitem + :paren-depth orig-depth + :h-begin orig-match-start + :type 'function + :name (nconc (js--split-name + (match-string-no-properties 1)) + (list (match-string-no-properties 2)))))) + + ;; Class definition + ((cl-loop + with syntactic-context = + (js--syntactic-context-from-pstate open-items) + for class-style in filtered-class-styles + if (and (memq syntactic-context + (plist-get class-style :contexts)) + (looking-at (plist-get class-style + :class-decl))) + do (goto-char (match-end 0)) + and return + (make-js--pitem + :paren-depth orig-depth + :h-begin orig-match-start + :type class-style + :name (js--split-name + (match-string-no-properties 1)))))) + + do (js--ensure-cache--update-parse) + and do (push it open-items) + and do (put-text-property + (1- (point)) (point) 'js--pstate open-items) + else do (goto-char orig-match-end)) (goto-char limit) (js--ensure-cache--update-parse) @@ -1181,12 +1181,12 @@ LIMIT defaults to point." (defun js--end-of-defun-flat () "Helper function for `js-end-of-defun'." - (loop while (js--re-search-forward "}" nil t) - do (js--ensure-cache) - if (get-text-property (1- (point)) 'js--pend) - if (eq 'function (js--pitem-type it)) - return t - finally do (goto-char (point-max)))) + (cl-loop while (js--re-search-forward "}" nil t) + do (js--ensure-cache) + if (get-text-property (1- (point)) 'js--pend) + if (eq 'function (js--pitem-type it)) + return t + finally do (goto-char (point-max)))) (defun js--end-of-defun-nested () "Helper function for `js-end-of-defun'." @@ -1218,14 +1218,14 @@ LIMIT defaults to point." "Value of `end-of-defun-function' for `js-mode'." (setq arg (or arg 1)) (while (and (not (bobp)) (< arg 0)) - (incf arg) + (cl-incf arg) (js-beginning-of-defun) (js-beginning-of-defun) (unless (bobp) (js-end-of-defun))) (while (> arg 0) - (decf arg) + (cl-decf arg) ;; look for function backward. if we're inside it, go to that ;; function's end. otherwise, search for the next function's end and ;; go there @@ -1349,7 +1349,7 @@ REGEXPS, but only if FRAMEWORK is in `js-enabled-frameworks'." If FUNC is supplied, call it with no arguments before every variable name in the spec. Return true iff this was actually a spec. FUNC must preserve the match data." - (case (char-after) + (pcase (char-after) (?\[ (forward-char) (while @@ -1554,8 +1554,8 @@ point of view of font-lock. It applies highlighting directly with (defun js--inside-pitem-p (pitem) "Return whether point is inside the given pitem's header or body." (js--ensure-cache) - (assert (js--pitem-h-begin pitem)) - (assert (js--pitem-paren-depth pitem)) + (cl-assert (js--pitem-h-begin pitem)) + (cl-assert (js--pitem-paren-depth pitem)) (and (> (point) (js--pitem-h-begin pitem)) (or (null (js--pitem-b-end pitem)) @@ -1576,11 +1576,11 @@ will be returned." ;; Loop until we either hit a pitem at BOB or pitem ends after ;; point (or at point if we're at eob) - (loop for pitem = (car pstate) - until (or (eq (js--pitem-type pitem) - 'toplevel) - (js--inside-pitem-p pitem)) - do (pop pstate)) + (cl-loop for pitem = (car pstate) + until (or (eq (js--pitem-type pitem) + 'toplevel) + (js--inside-pitem-p pitem)) + do (pop pstate)) pstate)))) @@ -1609,22 +1609,22 @@ context." (defun js--class-decl-matcher (limit) "Font lock function used by `js-mode'. This performs fontification according to `js--class-styles'." - (loop initially (js--ensure-cache limit) - while (re-search-forward js--quick-match-re limit t) - for orig-end = (match-end 0) - do (goto-char (match-beginning 0)) - if (loop for style in js--class-styles - for decl-re = (plist-get style :class-decl) - if (and (memq (plist-get style :framework) - js-enabled-frameworks) - (memq (js-syntactic-context) - (plist-get style :contexts)) - decl-re - (looking-at decl-re)) - do (goto-char (match-end 0)) - and return t) - return t - else do (goto-char orig-end))) + (cl-loop initially (js--ensure-cache limit) + while (re-search-forward js--quick-match-re limit t) + for orig-end = (match-end 0) + do (goto-char (match-beginning 0)) + if (cl-loop for style in js--class-styles + for decl-re = (plist-get style :class-decl) + if (and (memq (plist-get style :framework) + js-enabled-frameworks) + (memq (js-syntactic-context) + (plist-get style :contexts)) + decl-re + (looking-at decl-re)) + do (goto-char (match-end 0)) + and return t) + return t + else do (goto-char orig-end))) (defconst js--font-lock-keywords '(js--font-lock-keywords-3 js--font-lock-keywords-1 @@ -1789,7 +1789,7 @@ nil." js-expr-indent-offset)) (t (+ (current-column) js-indent-level - (case (char-after (nth 1 parse-status)) + (pcase (char-after (nth 1 parse-status)) (?\( js-paren-indent-offset) (?\[ js-square-indent-offset) (?\{ js-curly-indent-offset)))))) @@ -1821,15 +1821,17 @@ nil." (defun js-c-fill-paragraph (&optional justify) "Fill the paragraph with `c-fill-paragraph'." (interactive "*P") - (letf (((symbol-function 'c-forward-sws) - (lambda (&optional limit) - (js--forward-syntactic-ws limit))) - ((symbol-function 'c-backward-sws) - (lambda (&optional limit) - (js--backward-syntactic-ws limit))) - ((symbol-function 'c-beginning-of-macro) - (lambda (&optional limit) - (js--beginning-of-macro limit)))) + ;; FIXME: Such redefinitions are bad style. We should try and use some other + ;; way to get the same result. + (cl-letf (((symbol-function 'c-forward-sws) + (lambda (&optional limit) + (js--forward-syntactic-ws limit))) + ((symbol-function 'c-backward-sws) + (lambda (&optional limit) + (js--backward-syntactic-ws limit))) + ((symbol-function 'c-beginning-of-macro) + (lambda (&optional limit) + (js--beginning-of-macro limit)))) (let ((fill-paragraph-function 'c-fill-paragraph)) (c-fill-paragraph justify)))) @@ -1924,8 +1926,8 @@ the broken-down class name of the item to insert." name-parts (mapcar #'js--pitem-name items)) - (assert (stringp top-name)) - (assert (> (length top-name) 0)) + (cl-assert (stringp top-name)) + (cl-assert (> (length top-name) 0)) ;; If top-name isn't found in items, then we build a copy of items ;; and throw it away. But that's okay, since most of the time, we @@ -1990,10 +1992,10 @@ the broken-down class name of the item to insert." (defun js--pitem-add-child (pitem child) "Copy `js--pitem' PITEM, and push CHILD onto its list of children." - (assert (integerp (js--pitem-h-begin child))) - (assert (if (consp (js--pitem-name child)) - (loop for part in (js--pitem-name child) - always (stringp part)) + (cl-assert (integerp (js--pitem-h-begin child))) + (cl-assert (if (consp (js--pitem-name child)) + (cl-loop for part in (js--pitem-name child) + always (stringp part)) t)) ;; This trick works because we know (based on our defstructs) that @@ -2015,7 +2017,7 @@ the broken-down class name of the item to insert." ;; name is a list here because down in ;; `js--ensure-cache', we made sure to only add ;; class entries with lists for :name - (assert (consp name)) + (cl-assert (consp name)) (js--splice-into-items (car pitem) child name)) (t @@ -2040,11 +2042,11 @@ the broken-down class name of the item to insert." (setq pitem-name (js--pitem-strname pitem)) (when (eq pitem-name t) (setq pitem-name (format "[unknown %s]" - (incf (car unknown-ctr))))) + (cl-incf (car unknown-ctr))))) (cond ((memq pitem-type '(function macro)) - (assert (integerp (js--pitem-h-begin pitem))) + (cl-assert (integerp (js--pitem-h-begin pitem))) (push (cons pitem-name (js--maybe-make-marker (js--pitem-h-begin pitem))) @@ -2059,7 +2061,7 @@ the broken-down class name of the item to insert." imenu-items)) ((js--pitem-h-begin pitem) - (assert (integerp (js--pitem-h-begin pitem))) + (cl-assert (integerp (js--pitem-h-begin pitem))) (setq subitems (list (cons "[empty]" (js--maybe-make-marker @@ -2078,7 +2080,7 @@ the broken-down class name of the item to insert." (widen) (goto-char (point-max)) (js--ensure-cache) - (assert (or (= (point-min) (point-max)) + (cl-assert (or (= (point-min) (point-max)) (eq js--last-parse-pos (point)))) (when js--last-parse-pos (let ((state js--state-at-last-parse-pos) @@ -2087,10 +2089,10 @@ the broken-down class name of the item to insert." ;; Make sure everything is closed (while (cdr state) (setq state - (cons (js--pitem-add-child (second state) (car state)) + (cons (js--pitem-add-child (cl-second state) (car state)) (cddr state)))) - (assert (= (length state) 1)) + (cl-assert (= (length state) 1)) ;; Convert the new-finalized state into what imenu expects (js--pitems-to-imenu @@ -2104,34 +2106,34 @@ the broken-down class name of the item to insert." (mapconcat #'identity parts ".")) (defun js--imenu-to-flat (items prefix symbols) - (loop for item in items - if (imenu--subalist-p item) - do (js--imenu-to-flat - (cdr item) (concat prefix (car item) ".") - symbols) - else - do (let* ((name (concat prefix (car item))) - (name2 name) - (ctr 0)) + (cl-loop for item in items + if (imenu--subalist-p item) + do (js--imenu-to-flat + (cdr item) (concat prefix (car item) ".") + symbols) + else + do (let* ((name (concat prefix (car item))) + (name2 name) + (ctr 0)) - (while (gethash name2 symbols) - (setq name2 (format "%s<%d>" name (incf ctr)))) + (while (gethash name2 symbols) + (setq name2 (format "%s<%d>" name (cl-incf ctr)))) - (puthash name2 (cdr item) symbols)))) + (puthash name2 (cdr item) symbols)))) (defun js--get-all-known-symbols () "Return a hash table of all JavaScript symbols. This searches all existing `js-mode' buffers. Each key is the name of a symbol (possibly disambiguated with <N>, where N > 1), and each value is a marker giving the location of that symbol." - (loop with symbols = (make-hash-table :test 'equal) - with imenu-use-markers = t - for buffer being the buffers - for imenu-index = (with-current-buffer buffer - (when (derived-mode-p 'js-mode) - (js--imenu-create-index))) - do (js--imenu-to-flat imenu-index "" symbols) - finally return symbols)) + (cl-loop with symbols = (make-hash-table :test 'equal) + with imenu-use-markers = t + for buffer being the buffers + for imenu-index = (with-current-buffer buffer + (when (derived-mode-p 'js-mode) + (js--imenu-create-index))) + do (js--imenu-to-flat imenu-index "" symbols) + finally return symbols)) (defvar js--symbol-history nil "History of entered JavaScript symbols.") @@ -2149,8 +2151,8 @@ marker." (let ((choice (ido-completing-read prompt - (loop for key being the hash-keys of symbols-table - collect key) + (cl-loop for key being the hash-keys of symbols-table + collect key) nil t initial-input 'js--symbol-history))) (cons choice (gethash choice symbols-table)))) @@ -2204,20 +2206,20 @@ On timeout, return nil. On success, return t with match data set. If START is non-nil, look for output starting from START. Otherwise, use the current value of `process-mark'." (with-current-buffer (process-buffer process) - (loop with start-pos = (or start - (marker-position (process-mark process))) - with end-time = (+ (float-time) timeout) - for time-left = (- end-time (float-time)) - do (goto-char (point-max)) - if (looking-back regexp start-pos) return t - while (> time-left 0) - do (accept-process-output process time-left nil t) - do (goto-char (process-mark process)) - finally do (signal - 'js-moz-bad-rpc - (list (format "Timed out waiting for output matching %S" regexp)))))) - -(defstruct js--js-handle + (cl-loop with start-pos = (or start + (marker-position (process-mark process))) + with end-time = (+ (float-time) timeout) + for time-left = (- end-time (float-time)) + do (goto-char (point-max)) + if (looking-back regexp start-pos) return t + while (> time-left 0) + do (accept-process-output process time-left nil t) + do (goto-char (process-mark process)) + finally do (signal + 'js-moz-bad-rpc + (list (format "Timed out waiting for output matching %S" regexp)))))) + +(cl-defstruct js--js-handle ;; Integer, mirrors the value we see in JS (id nil :read-only t) @@ -2626,11 +2628,11 @@ with `js--js-encode-value'." (inferior-moz-process) js--js-repl-prompt-regexp js-js-timeout)) - (incf js--js-repl-depth))) + (cl-incf js--js-repl-depth))) (defun js--js-leave-repl () - (assert (> js--js-repl-depth 0)) - (when (= 0 (decf js--js-repl-depth)) + (cl-assert (> js--js-repl-depth 0)) + (when (= 0 (cl-decf js--js-repl-depth)) (with-current-buffer inferior-moz-buffer (goto-char (point-max)) (js--js-wait-for-eval-prompt) @@ -2649,33 +2651,33 @@ with `js--js-encode-value'." (eval-and-compile (defun js--optimize-arglist (arglist) "Convert immediate js< and js! references to deferred ones." - (loop for item in arglist - if (eq (car-safe item) 'js<) - collect (append (list 'list ''js--funcall - '(list 'interactor "_getProp")) - (js--optimize-arglist (cdr item))) - else if (eq (car-safe item) 'js>) - collect (append (list 'list ''js--funcall - '(list 'interactor "_putProp")) - - (if (atom (cadr item)) - (list (cadr item)) - (list - (append - (list 'list ''js--funcall - '(list 'interactor "_mkArray")) - (js--optimize-arglist (cadr item))))) - (js--optimize-arglist (cddr item))) - else if (eq (car-safe item) 'js!) - collect (destructuring-bind (ignored function &rest body) item - (append (list 'list ''js--funcall - (if (consp function) - (cons 'list - (js--optimize-arglist function)) - function)) - (js--optimize-arglist body))) - else - collect item))) + (cl-loop for item in arglist + if (eq (car-safe item) 'js<) + collect (append (list 'list ''js--funcall + '(list 'interactor "_getProp")) + (js--optimize-arglist (cdr item))) + else if (eq (car-safe item) 'js>) + collect (append (list 'list ''js--funcall + '(list 'interactor "_putProp")) + + (if (atom (cadr item)) + (list (cadr item)) + (list + (append + (list 'list ''js--funcall + '(list 'interactor "_mkArray")) + (js--optimize-arglist (cadr item))))) + (js--optimize-arglist (cddr item))) + else if (eq (car-safe item) 'js!) + collect (pcase-let ((`(,_ ,function . ,body) item)) + (append (list 'list ''js--funcall + (if (consp function) + (cons 'list + (js--optimize-arglist function)) + function)) + (js--optimize-arglist body))) + else + collect item))) (defmacro js--js-get-service (class-name interface-name) `(js! ("Components" "classes" ,class-name "getService") @@ -2698,56 +2700,56 @@ Inside the lexical scope of `with-js', `js?', `js!', `(progn (js--js-enter-repl) (unwind-protect - (macrolet ((js? (&rest body) `(js--js-true ,@body)) - (js! (function &rest body) - `(js--js-funcall - ,(if (consp function) - (cons 'list - (js--optimize-arglist function)) - function) - ,@(js--optimize-arglist body))) - - (js-new (function &rest body) - `(js--js-new + (cl-macrolet ((js? (&rest body) `(js--js-true ,@body)) + (js! (function &rest body) + `(js--js-funcall ,(if (consp function) (cons 'list (js--optimize-arglist function)) function) - ,@body)) - - (js-eval (thisobj js) - `(js--js-eval - ,@(js--optimize-arglist - (list thisobj js)))) - - (js-list (&rest args) - `(js--js-list - ,@(js--optimize-arglist args))) - - (js-get-service (&rest args) - `(js--js-get-service - ,@(js--optimize-arglist args))) - - (js-create-instance (&rest args) - `(js--js-create-instance - ,@(js--optimize-arglist args))) - - (js-qi (&rest args) - `(js--js-qi - ,@(js--optimize-arglist args))) - - (js< (&rest body) `(js--js-get - ,@(js--optimize-arglist body))) - (js> (props value) - `(js--js-funcall - '(interactor "_putProp") - ,(if (consp props) - (cons 'list - (js--optimize-arglist props)) - props) - ,@(js--optimize-arglist (list value)) - )) - (js-handle? (arg) `(js--js-handle-p ,arg))) + ,@(js--optimize-arglist body))) + + (js-new (function &rest body) + `(js--js-new + ,(if (consp function) + (cons 'list + (js--optimize-arglist function)) + function) + ,@body)) + + (js-eval (thisobj js) + `(js--js-eval + ,@(js--optimize-arglist + (list thisobj js)))) + + (js-list (&rest args) + `(js--js-list + ,@(js--optimize-arglist args))) + + (js-get-service (&rest args) + `(js--js-get-service + ,@(js--optimize-arglist args))) + + (js-create-instance (&rest args) + `(js--js-create-instance + ,@(js--optimize-arglist args))) + + (js-qi (&rest args) + `(js--js-qi + ,@(js--optimize-arglist args))) + + (js< (&rest body) `(js--js-get + ,@(js--optimize-arglist body))) + (js> (props value) + `(js--js-funcall + '(interactor "_putProp") + ,(if (consp props) + (cons 'list + (js--optimize-arglist props)) + props) + ,@(js--optimize-arglist (list value)) + )) + (js-handle? (arg) `(js--js-handle-p ,arg))) ,@forms) (js--js-leave-repl)))) @@ -2756,21 +2758,22 @@ Inside the lexical scope of `with-js', `js?', `js!', If nil, the whole Array is treated as a JS symbol.") (defun js--js-decode-retval (result) - (ecase (intern (first result)) - (atom (second result)) - (special (intern (second result))) - (array - (mapcar #'js--js-decode-retval (second result))) - (objid - (or (gethash (second result) - js--js-references) - (puthash (second result) - (make-js--js-handle - :id (second result) - :process (inferior-moz-process)) - js--js-references))) - - (error (signal 'js-js-error (list (second result)))))) + (pcase (intern (cl-first result)) + (`atom (cl-second result)) + (`special (intern (cl-second result))) + (`array + (mapcar #'js--js-decode-retval (cl-second result))) + (`objid + (or (gethash (cl-second result) + js--js-references) + (puthash (cl-second result) + (make-js--js-handle + :id (cl-second result) + :process (inferior-moz-process)) + js--js-references))) + + (`error (signal 'js-js-error (list (cl-second result)))) + (x (error "Unmatched case in js--js-decode-retval: %S" x)))) (defun js--js-funcall (function &rest arguments) "Call the Mozilla function FUNCTION with arguments ARGUMENTS. @@ -2853,9 +2856,9 @@ With argument, run even if no intervening GC has happened." (looking-back js--js-prompt-regexp (save-excursion (forward-line 0) (point)))))) - (setq keys (loop for x being the hash-keys - of js--js-references - collect x)) + (setq keys (cl-loop for x being the hash-keys + of js--js-references + collect x)) (setq num (js--js-funcall '(repl "_jsGC") (or keys []))) (setq js--js-last-gcs-done this-gcs-done) @@ -2889,58 +2892,58 @@ left-to-right." (with-js (let (windows) - (loop with window-mediator = (js! ("Components" "classes" - "@mozilla.org/appshell/window-mediator;1" - "getService") - (js< "Components" "interfaces" - "nsIWindowMediator")) - with enumerator = (js! (window-mediator "getEnumerator") nil) - - while (js? (js! (enumerator "hasMoreElements"))) - for window = (js! (enumerator "getNext")) - for window-info = (js-list window - (js< window "document" "title") - (js! (window "location" "toString")) - (js< window "closed") - (js< window "windowState")) - - unless (or (js? (fourth window-info)) - (eq (fifth window-info) 2)) - do (push window-info windows)) - - (loop for window-info in windows - for window = (first window-info) - collect (list (second window-info) - (third window-info) - window) - - for gbrowser = (js< window "gBrowser") - if (js-handle? gbrowser) - nconc (loop - for x below (js< gbrowser "browsers" "length") - collect (js-list (js< gbrowser - "browsers" - x - "contentDocument" - "title") - - (js! (gbrowser - "browsers" - x - "contentWindow" - "location" - "toString")) - (js< gbrowser - "browsers" - x) - - (js! (gbrowser - "tabContainer" - "childNodes" - "item") - x) - - gbrowser)))))) + (cl-loop with window-mediator = (js! ("Components" "classes" + "@mozilla.org/appshell/window-mediator;1" + "getService") + (js< "Components" "interfaces" + "nsIWindowMediator")) + with enumerator = (js! (window-mediator "getEnumerator") nil) + + while (js? (js! (enumerator "hasMoreElements"))) + for window = (js! (enumerator "getNext")) + for window-info = (js-list window + (js< window "document" "title") + (js! (window "location" "toString")) + (js< window "closed") + (js< window "windowState")) + + unless (or (js? (cl-fourth window-info)) + (eq (cl-fifth window-info) 2)) + do (push window-info windows)) + + (cl-loop for window-info in windows + for window = (cl-first window-info) + collect (list (cl-second window-info) + (cl-third window-info) + window) + + for gbrowser = (js< window "gBrowser") + if (js-handle? gbrowser) + nconc (cl-loop + for x below (js< gbrowser "browsers" "length") + collect (js-list (js< gbrowser + "browsers" + x + "contentDocument" + "title") + + (js! (gbrowser + "browsers" + x + "contentWindow" + "location" + "toString")) + (js< gbrowser + "browsers" + x) + + (js! (gbrowser + "tabContainer" + "childNodes" + "item") + x) + + gbrowser)))))) (defvar js-read-tab-history nil) @@ -2960,106 +2963,110 @@ browser, respectively." selected-tab prev-hitab) ;; Disambiguate names - (setq tabs (loop with tab-names = (make-hash-table :test 'equal) - for tab in tabs - for cname = (format "%s (%s)" (second tab) (first tab)) - for num = (incf (gethash cname tab-names -1)) - if (> num 0) - do (setq cname (format "%s <%d>" cname num)) - collect (cons cname tab))) - - (labels ((find-tab-by-cname - (cname) - (loop for tab in tabs - if (equal (car tab) cname) - return (cdr tab))) - - (mogrify-highlighting - (hitab unhitab) - - ;; Hack to reduce the number of - ;; round-trips to mozilla - (let (cmds) - (cond - ;; Highlighting tab - ((fourth hitab) - (push '(js! ((fourth hitab) "setAttribute") - "style" - "color: red; font-weight: bold") - cmds) - - ;; Highlight window proper - (push '(js! ((third hitab) - "setAttribute") - "style" - "border: 8px solid red") - cmds) - - ;; Select tab, when appropriate - (when js-js-switch-tabs - (push - '(js> ((fifth hitab) "selectedTab") (fourth hitab)) - cmds))) - - ;; Highlighting whole window - ((third hitab) - (push '(js! ((third hitab) "document" - "documentElement" "setAttribute") - "style" - (concat "-moz-appearance: none;" - "border: 8px solid red;")) - cmds))) - - (cond - ;; Unhighlighting tab - ((fourth unhitab) - (push '(js! ((fourth unhitab) "setAttribute") "style" "") - cmds) - (push '(js! ((third unhitab) "setAttribute") "style" "") - cmds)) - - ;; Unhighlighting window - ((third unhitab) - (push '(js! ((third unhitab) "document" - "documentElement" "setAttribute") - "style" "") - cmds))) - - (eval (list 'with-js - (cons 'js-list (nreverse cmds)))))) - - (command-hook - () - (let* ((tab (find-tab-by-cname (car ido-matches)))) - (mogrify-highlighting tab prev-hitab) - (setq prev-hitab tab))) - - (setup-hook - () - ;; Fiddle with the match list a bit: if our first match - ;; is a tabbrowser window, rotate the match list until - ;; the active tab comes up - (let ((matched-tab (find-tab-by-cname (car ido-matches)))) - (when (and matched-tab - (null (fourth matched-tab)) - (equal "navigator:browser" - (js! ((third matched-tab) - "document" - "documentElement" - "getAttribute") - "windowtype"))) - - (loop with tab-to-match = (js< (third matched-tab) - "gBrowser" - "selectedTab") - - for match in ido-matches - for candidate-tab = (find-tab-by-cname match) - if (eq (fourth candidate-tab) tab-to-match) - do (setq ido-cur-list (ido-chop ido-cur-list match)) - and return t))) - - (add-hook 'post-command-hook #'command-hook t t))) + (setq tabs + (cl-loop with tab-names = (make-hash-table :test 'equal) + for tab in tabs + for cname = (format "%s (%s)" + (cl-second tab) (cl-first tab)) + for num = (cl-incf (gethash cname tab-names -1)) + if (> num 0) + do (setq cname (format "%s <%d>" cname num)) + collect (cons cname tab))) + + (cl-labels + ((find-tab-by-cname + (cname) + (cl-loop for tab in tabs + if (equal (car tab) cname) + return (cdr tab))) + + (mogrify-highlighting + (hitab unhitab) + + ;; Hack to reduce the number of + ;; round-trips to mozilla + (let (cmds) + (cond + ;; Highlighting tab + ((cl-fourth hitab) + (push '(js! ((cl-fourth hitab) "setAttribute") + "style" + "color: red; font-weight: bold") + cmds) + + ;; Highlight window proper + (push '(js! ((cl-third hitab) + "setAttribute") + "style" + "border: 8px solid red") + cmds) + + ;; Select tab, when appropriate + (when js-js-switch-tabs + (push + '(js> ((cl-fifth hitab) "selectedTab") (cl-fourth hitab)) + cmds))) + + ;; Highlighting whole window + ((cl-third hitab) + (push '(js! ((cl-third hitab) "document" + "documentElement" "setAttribute") + "style" + (concat "-moz-appearance: none;" + "border: 8px solid red;")) + cmds))) + + (cond + ;; Unhighlighting tab + ((cl-fourth unhitab) + (push '(js! ((cl-fourth unhitab) "setAttribute") "style" "") + cmds) + (push '(js! ((cl-third unhitab) "setAttribute") "style" "") + cmds)) + + ;; Unhighlighting window + ((cl-third unhitab) + (push '(js! ((cl-third unhitab) "document" + "documentElement" "setAttribute") + "style" "") + cmds))) + + (eval (list 'with-js + (cons 'js-list (nreverse cmds)))))) + + (command-hook + () + (let* ((tab (find-tab-by-cname (car ido-matches)))) + (mogrify-highlighting tab prev-hitab) + (setq prev-hitab tab))) + + (setup-hook + () + ;; Fiddle with the match list a bit: if our first match + ;; is a tabbrowser window, rotate the match list until + ;; the active tab comes up + (let ((matched-tab (find-tab-by-cname (car ido-matches)))) + (when (and matched-tab + (null (cl-fourth matched-tab)) + (equal "navigator:browser" + (js! ((cl-third matched-tab) + "document" + "documentElement" + "getAttribute") + "windowtype"))) + + (cl-loop with tab-to-match = (js< (cl-third matched-tab) + "gBrowser" + "selectedTab") + + for match in ido-matches + for candidate-tab = (find-tab-by-cname match) + if (eq (cl-fourth candidate-tab) tab-to-match) + do (setq ido-cur-list + (ido-chop ido-cur-list match)) + and return t))) + + (add-hook 'post-command-hook #'command-hook t t))) (unwind-protect @@ -3078,13 +3085,12 @@ browser, respectively." (add-to-history 'js-read-tab-history selected-tab-cname) - (setq selected-tab (loop for tab in tabs - if (equal (car tab) selected-tab-cname) - return (cdr tab))) + (setq selected-tab (cl-loop for tab in tabs + if (equal (car tab) selected-tab-cname) + return (cdr tab))) - (if (fourth selected-tab) - (cons 'browser (third selected-tab)) - (cons 'window (third selected-tab))))))) + (cons (if (cl-fourth selected-tab) 'browser 'window) + (cl-third selected-tab)))))) (defun js--guess-eval-defun-info (pstate) "Helper function for `js-eval-defun'. @@ -3092,19 +3098,19 @@ Return a list (NAME . CLASSPARTS), where CLASSPARTS is a list of strings making up the class name and NAME is the name of the function part." (cond ((and (= (length pstate) 3) - (eq (js--pitem-type (first pstate)) 'function) - (= (length (js--pitem-name (first pstate))) 1) - (consp (js--pitem-type (second pstate)))) + (eq (js--pitem-type (cl-first pstate)) 'function) + (= (length (js--pitem-name (cl-first pstate))) 1) + (consp (js--pitem-type (cl-second pstate)))) - (append (js--pitem-name (second pstate)) - (list (first (js--pitem-name (first pstate)))))) + (append (js--pitem-name (cl-second pstate)) + (list (cl-first (js--pitem-name (cl-first pstate)))))) ((and (= (length pstate) 2) - (eq (js--pitem-type (first pstate)) 'function)) + (eq (js--pitem-type (cl-first pstate)) 'function)) (append - (butlast (js--pitem-name (first pstate))) - (list (car (last (js--pitem-name (first pstate))))))) + (butlast (js--pitem-name (cl-first pstate))) + (list (car (last (js--pitem-name (cl-first pstate))))))) (t (error "Function not a toplevel defun or class member")))) @@ -3148,19 +3154,21 @@ If one hasn't been set, or if it's stale, prompt for a new one." (with-js (when (or (null js--js-context) (js--js-handle-expired-p (cdr js--js-context)) - (ecase (car js--js-context) - (window (js? (js< (cdr js--js-context) "closed"))) - (browser (not (js? (js< (cdr js--js-context) - "contentDocument")))))) + (pcase (car js--js-context) + (`window (js? (js< (cdr js--js-context) "closed"))) + (`browser (not (js? (js< (cdr js--js-context) + "contentDocument")))) + (x (error "Unmatched case in js--get-js-context: %S" x)))) (setq js--js-context (js--read-tab "Javascript Context: "))) js--js-context)) (defun js--js-content-window (context) (with-js - (ecase (car context) - (window (cdr context)) - (browser (js< (cdr context) - "contentWindow" "wrappedJSObject"))))) + (pcase (car context) + (`window (cdr context)) + (`browser (js< (cdr context) + "contentWindow" "wrappedJSObject")) + (x (error "Unmatched case in js--js-content-window: %S" x))))) (defun js--make-nsilocalfile (path) (with-js @@ -3179,7 +3187,7 @@ If one hasn't been set, or if it's stale, prompt for a new one." (path-uri (js! (io-service "newFileURI") path-file))) (js! (res-prot "setSubstitution") alias path-uri)))) -(defun* js-eval-defun () +(cl-defun js-eval-defun () "Update a Mozilla tab using the JavaScript defun at point." (interactive) @@ -3215,7 +3223,7 @@ If one hasn't been set, or if it's stale, prompt for a new one." (unless (y-or-n-p (format "Send %s to Mozilla? " (mapconcat #'identity defun-info "."))) (message "") ; question message lingers until next command - (return-from js-eval-defun)) + (cl-return-from js-eval-defun)) (delete-overlay overlay))) (setq defun-body (buffer-substring-no-properties begin end)) diff --git a/lisp/progmodes/pascal.el b/lisp/progmodes/pascal.el index ce37fc2c571..b313fd4aee6 100644 --- a/lisp/progmodes/pascal.el +++ b/lisp/progmodes/pascal.el @@ -57,7 +57,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (defgroup pascal nil "Major mode for editing Pascal source in Emacs." diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el index 9df9943cc00..848b92868e7 100644 --- a/lisp/progmodes/perl-mode.el +++ b/lisp/progmodes/perl-mode.el @@ -102,7 +102,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (defvar font-lock-comment-face) (defvar font-lock-doc-face) diff --git a/lisp/ps-samp.el b/lisp/ps-samp.el index f719b087277..5e7fbb2ca9a 100644 --- a/lisp/ps-samp.el +++ b/lisp/ps-samp.el @@ -251,8 +251,6 @@ ;; * CUPS has enabled the option "Share published printers connected ;; to this system" (see <http://localhost:631/admin>). -(eval-when-compile - (require 'cl)) (require 'printing) (require 'zeroconf) diff --git a/lisp/server.el b/lisp/server.el index e17e1118847..a25da406571 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -81,7 +81,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defgroup server nil "Emacs running as a server process." @@ -478,11 +478,11 @@ If CLIENT is non-nil, add a description of it to the logged message." See `server-quote-arg' and `server-process-filter'." (replace-regexp-in-string "&." (lambda (s) - (case (aref s 1) + (pcase (aref s 1) (?& "&") (?- "-") (?n "\n") - (t " "))) + (_ " "))) arg t t)) (defun server-quote-arg (arg) @@ -493,7 +493,7 @@ contains a space. See `server-unquote-arg' and `server-process-filter'." (replace-regexp-in-string "[-&\n ]" (lambda (s) - (case (aref s 0) + (pcase (aref s 0) (?& "&&") (?- "&-") (?\n "&n") @@ -514,7 +514,7 @@ Creates the directory if necessary and makes sure: (setq dir (directory-file-name dir)) (let ((attrs (file-attributes dir 'integer))) (unless attrs - (letf (((default-file-modes) ?\700)) (make-directory dir t)) + (cl-letf (((default-file-modes) ?\700)) (make-directory dir t)) (setq attrs (file-attributes dir 'integer))) ;; Check that it's safe for use. @@ -550,9 +550,9 @@ The key is a 64-byte string of random chars in the range `!'..`~'. If called interactively, also inserts it into current buffer." (interactive) (let ((auth-key - (loop repeat 64 - collect (+ 33 (random 94)) into auth - finally return (concat auth)))) + (cl-loop repeat 64 + collect (+ 33 (random 94)) into auth + finally return (concat auth)))) (if (called-interactively-p 'interactive) (insert auth-key)) auth-key)) @@ -632,11 +632,13 @@ server or call `M-x server-force-delete' to forcibly disconnect it.") (server-ensure-safe-dir server-dir) (when server-process (server-log (message "Restarting server"))) - (letf (((default-file-modes) ?\700)) + (cl-letf (((default-file-modes) ?\700)) (add-hook 'suspend-tty-functions 'server-handle-suspend-tty) (add-hook 'delete-frame-functions 'server-handle-delete-frame) - (add-hook 'kill-buffer-query-functions 'server-kill-buffer-query-function) - (add-hook 'kill-emacs-query-functions 'server-kill-emacs-query-function) + (add-hook 'kill-buffer-query-functions + 'server-kill-buffer-query-function) + (add-hook 'kill-emacs-query-functions + 'server-kill-emacs-query-function) (add-hook 'kill-emacs-hook 'server-force-stop) ;Cleanup upon exit. (setq server-process (apply #'make-network-process @@ -886,7 +888,7 @@ This handles splitting the command if it would be bigger than (process-put proc 'continuation nil) (if continuation (ignore-errors (funcall continuation))))) -(defun* server-process-filter (proc string) +(cl-defun server-process-filter (proc string) "Process a request from the server to edit some files. PROC is the server process. STRING consists of a sequence of commands prefixed by a dash. Some commands have arguments; @@ -1001,8 +1003,8 @@ The following commands are accepted by the client: ;; receive the error string and shut down on its own. (sit-for 1) (delete-process proc) - ;; We return immediately - (return-from server-process-filter))) + ;; We return immediately. + (cl-return-from server-process-filter))) (let ((prev (process-get proc 'previous-string))) (when prev (setq string (concat prev string)) @@ -1021,7 +1023,7 @@ The following commands are accepted by the client: ;; In earlier versions of server.el (where we used an `emacsserver' ;; process), there could be multiple lines. Nowadays this is not ;; supported any more. - (assert (eq (match-end 0) (length string))) + (cl-assert (eq (match-end 0) (length string))) (let ((request (substring string 0 (match-beginning 0))) (coding-system (and (default-value 'enable-multibyte-characters) (or file-name-coding-system diff --git a/lisp/ses.el b/lisp/ses.el index 7429653c7de..201d9cbf10b 100644 --- a/lisp/ses.el +++ b/lisp/ses.el @@ -56,7 +56,7 @@ ;;; Code: (require 'unsafep) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;;---------------------------------------------------------------------------- @@ -1520,7 +1520,7 @@ if the range was altered." (funcall field (ses-sym-rowcol min)))) ;; This range has changed size. (setq ses-relocate-return 'range)) - `(ses-range ,min ,max ,@(cdddr range))))) + `(ses-range ,min ,max ,@(cl-cdddr range))))) (defun ses-relocate-all (minrow mincol rowincr colincr) "Alter all cell values, symbols, formulas, and reference-lists to relocate @@ -3345,19 +3345,20 @@ Use `math-format-value' as a printer for Calc objects." (push result-row result) (while rest (let ((x (pop rest))) - (case x - ((>v) (setq transpose nil reorient-x nil reorient-y nil)) - ((>^)(setq transpose nil reorient-x nil reorient-y t)) - ((<^)(setq transpose nil reorient-x t reorient-y t)) - ((<v)(setq transpose nil reorient-x t reorient-y nil)) - ((v>)(setq transpose t reorient-x nil reorient-y t)) - ((^>)(setq transpose t reorient-x nil reorient-y nil)) - ((^<)(setq transpose t reorient-x t reorient-y nil)) - ((v<)(setq transpose t reorient-x t reorient-y t)) - ((* *2 *1) (setq vectorize x)) - ((!) (setq clean 'ses--clean-!)) - ((_) (setq clean `(lambda (&rest x) (ses--clean-_ x ,(if rest (pop rest) 0))))) - (t + (pcase x + (`>v (setq transpose nil reorient-x nil reorient-y nil)) + (`>^ (setq transpose nil reorient-x nil reorient-y t)) + (`<^ (setq transpose nil reorient-x t reorient-y t)) + (`<v (setq transpose nil reorient-x t reorient-y nil)) + (`v> (setq transpose t reorient-x nil reorient-y t)) + (`^> (setq transpose t reorient-x nil reorient-y nil)) + (`^< (setq transpose t reorient-x t reorient-y nil)) + (`v< (setq transpose t reorient-x t reorient-y t)) + ((or `* `*2 `*1) (setq vectorize x)) + (`! (setq clean 'ses--clean-!)) + (`_ (setq clean `(lambda (&rest x) + (ses--clean-_ x ,(if rest (pop rest) 0))))) + (_ (cond ; shorthands one row ((and (null (cddr result)) (memq x '(> <))) @@ -3389,14 +3390,14 @@ Use `math-format-value' as a printer for Calc objects." (mapcar (lambda (x) (cons clean (cons (quote 'vec) x))) result))))) - (case vectorize - ((nil) (cons clean (apply 'append result))) - ((*1) (vectorize-*1 clean result)) - ((*2) (vectorize-*2 clean result)) - ((*) (funcall (if (cdr result) - #'vectorize-*2 - #'vectorize-*1) - clean result)))))) + (pcase vectorize + (`nil (cons clean (apply 'append result))) + (`*1 (vectorize-*1 clean result)) + (`*2 (vectorize-*2 clean result)) + (`* (funcall (if (cdr result) + #'vectorize-*2 + #'vectorize-*1) + clean result)))))) (defun ses-delete-blanks (&rest args) "Return ARGS reversed, with the blank elements (nil and *skip*) removed." diff --git a/lisp/shell.el b/lisp/shell.el index ca238a443f3..b98efceefbf 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -96,7 +96,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'comint) (require 'pcomplete) @@ -1243,7 +1242,7 @@ Returns non-nil if successful." (variables (mapcar (lambda (x) (substring x 0 (string-match "=" x))) process-environment)) - (suffix (case (char-before start) (?\{ "}") (?\( ")") (t "")))) + (suffix (pcase (char-before start) (?\{ "}") (?\( ")") (_ "")))) (list start end variables :exit-function (lambda (s finished) diff --git a/lisp/strokes.el b/lisp/strokes.el index 1ae2300559d..302e441d282 100644 --- a/lisp/strokes.el +++ b/lisp/strokes.el @@ -180,7 +180,7 @@ ;;; Requirements and provisions... (autoload 'mail-position-on-field "sendmail") -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;;; Constants... @@ -542,10 +542,10 @@ The return value is a list ((XMIN . YMIN) (XMAX . YMAX))." (defun strokes-eliminate-consecutive-redundancies (entries) "Return a list with no consecutive redundant entries." ;; defun a grande vitesse grace a Dave G. - (loop for element on entries - if (not (equal (car element) (cadr element))) - collect (car element))) -;; (loop for element on entries + (cl-loop for element on entries + if (not (equal (car element) (cadr element))) + collect (car element))) +;; (cl-loop for element on entries ;; nconc (if (not (equal (car el) (cadr el))) ;; (list (car el))))) ;; yet another (orig) way of doing it... @@ -584,68 +584,70 @@ NOTE: This is where the global variable `strokes-last-stroke' is set." (if (and (strokes-click-p unfilled-stroke) (not force)) unfilled-stroke - (loop for grid-locs on unfilled-stroke - nconc (let* ((current (car grid-locs)) - (current-is-a-point-p (consp current)) - (next (cadr grid-locs)) - (next-is-a-point-p (consp next)) - (both-are-points-p (and current-is-a-point-p - next-is-a-point-p)) - (x1 (and current-is-a-point-p - (car current))) - (y1 (and current-is-a-point-p - (cdr current))) - (x2 (and next-is-a-point-p - (car next))) - (y2 (and next-is-a-point-p - (cdr next))) - (delta-x (and both-are-points-p - (- x2 x1))) - (delta-y (and both-are-points-p - (- y2 y1))) - (slope (and both-are-points-p - (if (zerop delta-x) - nil ; undefined vertical slope - (/ (float delta-y) - delta-x))))) - (cond ((not both-are-points-p) - (list current)) - ((null slope) ; undefined vertical slope - (if (>= delta-y 0) - (loop for y from y1 below y2 - collect (cons x1 y)) - (loop for y from y1 above y2 - collect (cons x1 y)))) - ((zerop slope) ; (= y1 y2) - (if (>= delta-x 0) - (loop for x from x1 below x2 - collect (cons x y1)) - (loop for x from x1 above x2 - collect (cons x y1)))) - ((>= (abs delta-x) (abs delta-y)) - (if (> delta-x 0) - (loop for x from x1 below x2 - collect (cons x - (+ y1 - (round (* slope - (- x x1)))))) - (loop for x from x1 above x2 - collect (cons x - (+ y1 - (round (* slope - (- x x1)))))))) - (t ; (< (abs delta-x) (abs delta-y)) - (if (> delta-y 0) - (loop for y from y1 below y2 - collect (cons (+ x1 - (round (/ (- y y1) - slope))) - y)) - (loop for y from y1 above y2 - collect (cons (+ x1 - (round (/ (- y y1) - slope))) - y)))))))))) + (cl-loop + for grid-locs on unfilled-stroke + nconc (let* ((current (car grid-locs)) + (current-is-a-point-p (consp current)) + (next (cadr grid-locs)) + (next-is-a-point-p (consp next)) + (both-are-points-p (and current-is-a-point-p + next-is-a-point-p)) + (x1 (and current-is-a-point-p + (car current))) + (y1 (and current-is-a-point-p + (cdr current))) + (x2 (and next-is-a-point-p + (car next))) + (y2 (and next-is-a-point-p + (cdr next))) + (delta-x (and both-are-points-p + (- x2 x1))) + (delta-y (and both-are-points-p + (- y2 y1))) + (slope (and both-are-points-p + (if (zerop delta-x) + nil ; undefined vertical slope + (/ (float delta-y) + delta-x))))) + (cond ((not both-are-points-p) + (list current)) + ((null slope) ; undefined vertical slope + (if (>= delta-y 0) + (cl-loop for y from y1 below y2 + collect (cons x1 y)) + (cl-loop for y from y1 above y2 + collect (cons x1 y)))) + ((zerop slope) ; (= y1 y2) + (if (>= delta-x 0) + (cl-loop for x from x1 below x2 + collect (cons x y1)) + (cl-loop for x from x1 above x2 + collect (cons x y1)))) + ((>= (abs delta-x) (abs delta-y)) + (if (> delta-x 0) + (cl-loop for x from x1 below x2 + collect (cons x + (+ y1 + (round (* slope + (- x x1)))))) + (cl-loop for x from x1 above x2 + collect (cons x + (+ y1 + (round (* slope + (- x x1)))))))) + (t ; (< (abs delta-x) (abs delta-y)) + (if (> delta-y 0) + ;; FIXME: Reduce redundancy between branches. + (cl-loop for y from y1 below y2 + collect (cons (+ x1 + (round (/ (- y y1) + slope))) + y)) + (cl-loop for y from y1 above y2 + collect (cons (+ x1 + (round (/ (- y y1) + slope))) + y)))))))))) (defun strokes-rate-stroke (stroke1 stroke2) "Rates STROKE1 with STROKE2 and return a score based on a distance metric. @@ -723,9 +725,9 @@ Returns the corresponding match as (COMMAND . SCORE)." (defsubst strokes-fill-current-buffer-with-whitespace () "Erase the contents of the current buffer and fill it with whitespace." (erase-buffer) - (loop repeat (frame-height) do - (insert-char ?\s (1- (frame-width))) - (newline)) + (cl-loop repeat (frame-height) do + (insert-char ?\s (1- (frame-width))) + (newline)) (goto-char (point-min))) ;;;###autoload @@ -1173,40 +1175,40 @@ the stroke as a character in some language." (set-buffer buf) (erase-buffer) (insert strokes-xpm-header) - (loop repeat 33 do - (insert ?\") - (insert-char ?\s 33) - (insert "\",") - (newline) - finally - (forward-line -1) - (end-of-line) - (insert "}\n")) - (loop for point in stroke - for x = (car-safe point) - for y = (cdr-safe point) do - (cond ((consp point) - ;; draw a point, and possibly a starting-point - (if (and lift-flag (not b/w-only)) - ;; mark starting point with the appropriate color - (let ((char (or (car rainbow-chars) ?\.))) - (loop for i from 0 to 2 do - (loop for j from 0 to 2 do - (goto-char (point-min)) - (forward-line (+ 15 i y)) - (forward-char (+ 1 j x)) - (delete-char 1) - (insert char))) - (setq rainbow-chars (cdr rainbow-chars) - lift-flag nil)) - ;; Otherwise, just plot the point... - (goto-char (point-min)) - (forward-line (+ 16 y)) - (forward-char (+ 2 x)) - (subst-char-in-region (point) (1+ (point)) ?\s ?\*))) - ((strokes-lift-p point) - ;; a lift--tell the loop to X out the next point... - (setq lift-flag t)))) + (cl-loop repeat 33 do + (insert ?\") + (insert-char ?\s 33) + (insert "\",") + (newline) + finally + (forward-line -1) + (end-of-line) + (insert "}\n")) + (cl-loop for point in stroke + for x = (car-safe point) + for y = (cdr-safe point) do + (cond ((consp point) + ;; draw a point, and possibly a starting-point + (if (and lift-flag (not b/w-only)) + ;; mark starting point with the appropriate color + (let ((char (or (car rainbow-chars) ?\.))) + (cl-loop for i from 0 to 2 do + (cl-loop for j from 0 to 2 do + (goto-char (point-min)) + (forward-line (+ 15 i y)) + (forward-char (+ 1 j x)) + (delete-char 1) + (insert char))) + (setq rainbow-chars (cdr rainbow-chars) + lift-flag nil)) + ;; Otherwise, just plot the point... + (goto-char (point-min)) + (forward-line (+ 16 y)) + (forward-char (+ 2 x)) + (subst-char-in-region (point) (1+ (point)) ?\s ?\*))) + ((strokes-lift-p point) + ;; a lift--tell the loop to X out the next point... + (setq lift-flag t)))) (when (called-interactively-p 'interactive) (pop-to-buffer " *strokes-xpm*") ;; (xpm-mode 1) @@ -1288,7 +1290,7 @@ the stroke as a character in some language." ;; (insert ;; "Command Stroke\n" ;; "------- ------") -;; (loop for def in strokes-map +;; (cl-loop for def in strokes-map ;; for i from 0 to (1- (length strokes-map)) do ;; (let ((stroke (car def)) ;; (command-name (symbol-name (cdr def)))) @@ -1343,27 +1345,28 @@ If STROKES-MAP is not given, `strokes-global-map' will be used instead." (insert "Command Stroke\n" "------- ------") - (loop for def in strokes-map do - (let ((stroke (car def)) - (command-name (if (symbolp (cdr def)) - (symbol-name (cdr def)) - (prin1-to-string (cdr def))))) - (strokes-xpm-for-stroke stroke " *strokes-xpm*") - (newline 2) - (insert-char ?\s 45) - (beginning-of-line) - (insert command-name) - (beginning-of-line) - (forward-char 45) - (insert-image - (create-image (with-current-buffer " *strokes-xpm*" - (buffer-string)) - 'xpm t - :color-symbols - `(("foreground" - . ,(frame-parameter nil 'foreground-color)))))) - finally do (unless (eobp) - (kill-region (1+ (point)) (point-max)))) + (cl-loop + for def in strokes-map do + (let ((stroke (car def)) + (command-name (if (symbolp (cdr def)) + (symbol-name (cdr def)) + (prin1-to-string (cdr def))))) + (strokes-xpm-for-stroke stroke " *strokes-xpm*") + (newline 2) + (insert-char ?\s 45) + (beginning-of-line) + (insert command-name) + (beginning-of-line) + (forward-char 45) + (insert-image + (create-image (with-current-buffer " *strokes-xpm*" + (buffer-string)) + 'xpm t + :color-symbols + `(("foreground" + . ,(frame-parameter nil 'foreground-color)))))) + finally do (unless (eobp) + (kill-region (1+ (point)) (point-max)))) (view-buffer "*Strokes List*" nil) (set (make-local-variable 'view-mode-map) (let ((map (copy-keymap view-mode-map))) @@ -1588,7 +1591,7 @@ XPM-BUFFER defaults to ` *strokes-xpm*'." ;; yet another of the same bit-type, so we continue ;; counting... (progn - (incf count) + (cl-incf count) (forward-char 1)) ;; otherwise, it's the opposite bit-type, so we do a ;; write and then restart count ### NOTE (for myself @@ -1727,10 +1730,10 @@ Store XPM in buffer BUFNAME if supplied \(default is ` *strokes-xpm*'\)" (delete-char 1) (setq current-char-is-on-p (not current-char-is-on-p))) (goto-char (point-min)) - (loop repeat 33 do - (insert ?\") - (forward-char 33) - (insert "\",\n")) + (cl-loop repeat 33 do + (insert ?\") + (forward-char 33) + (insert "\",\n")) (goto-char (point-min)) (insert strokes-xpm-header)))) diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el index 82329677643..0e818e0be14 100644 --- a/lisp/tar-mode.el +++ b/lisp/tar-mode.el @@ -97,7 +97,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defgroup tar nil "Simple editing of tar files." @@ -168,7 +168,7 @@ This information is useful, but it takes screen space away from file names." ;; state correctly: the raw data is expected to be always larger than ;; the summary. (progn - (assert (or (= (buffer-size tar-data-buffer) (buffer-size)) + (cl-assert (or (= (buffer-size tar-data-buffer) (buffer-size)) (eq tar-data-swapped (> (buffer-size tar-data-buffer) (buffer-size))))) tar-data-swapped))) @@ -186,7 +186,7 @@ Preserve the modified states of the buffers and set `buffer-swapped-with'." ;;; down to business. -(defstruct (tar-header +(cl-defstruct (tar-header (:constructor nil) (:type vector) :named @@ -226,8 +226,8 @@ Preserve the modified states of the buffers and set `buffer-swapped-with'." This is a list of name, mode, uid, gid, size, write-date, checksum, link-type, and link-name." (if (> (+ pos 512) (point-max)) (error "Malformed Tar header")) - (assert (zerop (mod (- pos (point-min)) 512))) - (assert (not enable-multibyte-characters)) + (cl-assert (zerop (mod (- pos (point-min)) 512))) + (cl-assert (not enable-multibyte-characters)) (let ((string (buffer-substring pos (setq pos (+ pos 512))))) (when ;(some 'plusp string) ; <-- oops, massive cycle hog! (or (not (= 0 (aref string 0))) ; This will do. @@ -373,7 +373,7 @@ write-date, checksum, link-type, and link-name." (defun tar-header-block-checksum (string) "Compute and return a tar-acceptable checksum for this block." - (assert (not (multibyte-string-p string))) + (cl-assert (not (multibyte-string-p string))) (let* ((chk-field-start tar-chk-offset) (chk-field-end (+ chk-field-start 8)) (sum 0) @@ -486,7 +486,7 @@ MODE should be an integer which is a file mode value." (defun tar-summarize-buffer () "Parse the contents of the tar file in the current buffer." - (assert (tar-data-swapped-p)) + (cl-assert (tar-data-swapped-p)) (let* ((modified (buffer-modified-p)) (result '()) (pos (point-min)) @@ -654,7 +654,7 @@ See also: variables `tar-update-datestamp' and `tar-anal-blocksize'. (widen) ;; Now move the Tar data into an auxiliary buffer, so we can use the main ;; buffer for the summary. - (assert (not (tar-data-swapped-p))) + (cl-assert (not (tar-data-swapped-p))) (set (make-local-variable 'revert-buffer-function) 'tar-mode-revert) ;; We started using write-contents-functions, but this hook is not ;; used during auto-save, so we now use @@ -1119,15 +1119,15 @@ for this to be permanent." (insert (tar-header-block-summarize descriptor) "\n"))) (forward-line -1) (move-to-column col)) - (assert (tar-data-swapped-p)) + (cl-assert (tar-data-swapped-p)) (with-current-buffer tar-data-buffer (let* ((start (- (tar-header-data-start descriptor) 512))) ;; ;; delete the old field and insert a new one. (goto-char (+ start data-position)) (delete-region (point) (+ (point) (length new-data-string))) ; <-- - (assert (not (or enable-multibyte-characters - (multibyte-string-p new-data-string)))) + (cl-assert (not (or enable-multibyte-characters + (multibyte-string-p new-data-string)))) (insert new-data-string) ;; ;; compute a new checksum and insert it. diff --git a/lisp/term.el b/lisp/term.el index a9ebf66108a..014adb610b4 100644 --- a/lisp/term.el +++ b/lisp/term.el @@ -393,9 +393,7 @@ ;; so it is important to increase it if there are protocol-relevant changes. (defconst term-protocol-version "0.96") -(eval-when-compile - (require 'ange-ftp) - (require 'cl)) +(eval-when-compile (require 'ange-ftp)) (require 'ring) (require 'ehelp) @@ -3220,11 +3218,11 @@ See `term-prompt-regexp'." (when term-ansi-current-bold (setq term-current-face - (list* term-current-face :inherit 'term-bold))) + `(,term-current-face :inherit term-bold))) (when term-ansi-current-underline (setq term-current-face - (list* term-current-face :inherit 'term-underline))))) + `(,term-current-face :inherit term-underline))))) ;; (message "Debug %S" term-current-face) ;; FIXME: shouldn't we set term-ansi-face-already-done to t here? --Stef diff --git a/lisp/term/ns-win.el b/lisp/term/ns-win.el index 344c3d434d2..06b67475c1d 100644 --- a/lisp/term/ns-win.el +++ b/lisp/term/ns-win.el @@ -44,8 +44,6 @@ (error "%s: Loading ns-win.el but not compiled for GNUstep/MacOS" (invocation-name))) -(eval-when-compile (require 'cl)) - ;; Documentation-purposes only: actually loaded in loadup.el. (require 'frame) (require 'mouse) diff --git a/lisp/term/tvi970.el b/lisp/term/tvi970.el index 161e6222df2..b02d39c1e0f 100644 --- a/lisp/term/tvi970.el +++ b/lisp/term/tvi970.el @@ -27,8 +27,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (defvar tvi970-terminal-map (let ((map (make-sparse-keymap))) diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el index b9e4da59e18..d50aadef25b 100644 --- a/lisp/textmodes/css-mode.el +++ b/lisp/textmodes/css-mode.el @@ -37,7 +37,6 @@ "Cascading Style Sheets (CSS) editing mode." :group 'languages) -(eval-when-compile (require 'cl)) (defun css-extract-keyword-list (res) (with-temp-buffer diff --git a/lisp/textmodes/refill.el b/lisp/textmodes/refill.el index cb7e9ff0b88..d6b355bdd0d 100644 --- a/lisp/textmodes/refill.el +++ b/lisp/textmodes/refill.el @@ -83,8 +83,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (defgroup refill nil "Refilling paragraphs on changes." :group 'fill) @@ -169,8 +167,8 @@ complex processing.") "Post-command function to do refilling (conditionally)." (when refill-doit ; there was a change ;; There's probably scope for more special cases here... - (case this-command - (self-insert-command + (pcase this-command + (`self-insert-command ;; Treat self-insertion commands specially, since they don't ;; always reset `refill-doit' -- for self-insertion commands that ;; *don't* cause a refill, we want to leave it turned on so that @@ -180,9 +178,9 @@ complex processing.") ;; newline, covered below). (refill-fill-paragraph-at refill-doit) (setq refill-doit nil))) - ((quoted-insert fill-paragraph fill-region) nil) - ((newline newline-and-indent open-line indent-new-comment-line - reindent-then-newline-and-indent) + ((or `quoted-insert `fill-paragraph `fill-region) nil) + ((or `newline `newline-and-indent `open-line `indent-new-comment-line + `reindent-then-newline-and-indent) ;; Don't zap what was just inserted. (save-excursion (beginning-of-line) ; for newline-and-indent @@ -196,7 +194,7 @@ complex processing.") (save-restriction (narrow-to-region (line-beginning-position) (point-max)) (refill-fill-paragraph-at refill-doit)))) - (t + (_ (refill-fill-paragraph-at refill-doit))) (setq refill-doit nil))) diff --git a/lisp/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el index aed4ecb4e3e..5bcd87ede68 100644 --- a/lisp/textmodes/sgml-mode.el +++ b/lisp/textmodes/sgml-mode.el @@ -35,7 +35,7 @@ (eval-when-compile (require 'skeleton) (require 'outline) - (require 'cl)) + (require 'cl-lib)) (defgroup sgml nil "SGML editing mode." @@ -1192,7 +1192,7 @@ You might want to turn on `auto-fill-mode' to get better results." ;; Parsing -(defstruct (sgml-tag +(cl-defstruct (sgml-tag (:constructor sgml-make-tag (type start end name))) type start end name) @@ -1272,7 +1272,7 @@ Leave point at the beginning of the tag." (throw 'found (sgml-parse-tag-backward limit)))) (point)))) (goto-char (1+ tag-start)) - (case (char-after) + (pcase (char-after) (?! (setq tag-type 'decl)) ; declaration (?? (setq tag-type 'pi)) ; processing-instruction (?% (setq tag-type 'jsp)) ; JSP tags @@ -1280,7 +1280,7 @@ Leave point at the beginning of the tag." (forward-char 1) (setq tag-type 'close name (sgml-parse-tag-name))) - (t ; open or empty tag + (_ ; open or empty tag (setq tag-type 'open name (sgml-parse-tag-name)) (if (or (eq ?/ (char-before (- tag-end 1))) @@ -1405,19 +1405,19 @@ If FULL is non-nil, parse back to the beginning of the buffer." Depending on context, inserts a matching close-tag, or closes the current start-tag or the current comment or the current cdata, ..." (interactive) - (case (car (sgml-lexical-context)) - (comment (insert " -->")) - (cdata (insert "]]>")) - (pi (insert " ?>")) - (jsp (insert " %>")) - (tag (insert " />")) - (text + (pcase (car (sgml-lexical-context)) + (`comment (insert " -->")) + (`cdata (insert "]]>")) + (`pi (insert " ?>")) + (`jsp (insert " %>")) + (`tag (insert " />")) + (`text (let ((context (save-excursion (sgml-get-context)))) (if context (progn (insert "</" (sgml-tag-name (car (last context))) ">") (indent-according-to-mode))))) - (otherwise + (_ (error "Nothing to close")))) (defun sgml-empty-tag-p (tag-name) @@ -1442,9 +1442,9 @@ LCON is the lexical context, if any." (save-excursion (goto-char (cdr lcon)) (looking-at "<!--"))) (setq lcon (cons 'comment (+ (cdr lcon) 2)))) - (case (car lcon) + (pcase (car lcon) - (string + (`string ;; Go back to previous non-empty line. (while (and (> (point) (cdr lcon)) (zerop (forward-line -1)) @@ -1455,7 +1455,7 @@ LCON is the lexical context, if any." (goto-char (cdr lcon)) (1+ (current-column)))) - (comment + (`comment (let ((mark (looking-at "--"))) ;; Go back to previous non-empty line. (while (and (> (point) (cdr lcon)) @@ -1474,11 +1474,11 @@ LCON is the lexical context, if any." (current-column))) ;; We don't know how to indent it. Let's be honest about it. - (cdata nil) + (`cdata nil) ;; We don't know how to indent it. Let's be honest about it. - (pi nil) + (`pi nil) - (tag + (`tag (goto-char (1+ (cdr lcon))) (skip-chars-forward "^ \t\n") ;Skip tag name. (skip-chars-forward " \t") @@ -1488,7 +1488,7 @@ LCON is the lexical context, if any." (goto-char (1+ (cdr lcon))) (+ (current-column) sgml-basic-offset))) - (text + (`text (while (looking-at "</") (forward-sexp 1) (skip-chars-forward " \t")) @@ -1536,7 +1536,7 @@ LCON is the lexical context, if any." (+ (current-column) (* sgml-basic-offset (length context))))))) - (otherwise + (_ (error "Unrecognized context %s" (car lcon))) )) diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el index 43005a03415..a0e282c6fcc 100644 --- a/lisp/textmodes/tex-mode.el +++ b/lisp/textmodes/tex-mode.el @@ -31,7 +31,7 @@ ;; Pacify the byte-compiler (eval-when-compile (require 'compare-w) - (require 'cl) + (require 'cl-lib) (require 'skeleton)) (defvar font-lock-comment-face) @@ -1543,8 +1543,8 @@ Puts point on a blank line between them." (save-excursion (let ((pt (point))) (skip-chars-backward "^ {}\n\t\\\\") - (case (char-before) - ((nil ?\s ?\n ?\t ?\}) nil) + (pcase (char-before) + ((or `nil ?\s ?\n ?\t ?\}) nil) (?\\ ;; TODO: Complete commands. nil) @@ -1793,7 +1793,7 @@ Mark is left at original location." (if (not (eq (char-syntax (preceding-char)) ?/)) (progn ;; Don't count single-char words. - (unless (looking-at ".\\>") (incf count)) + (unless (looking-at ".\\>") (cl-incf count)) (forward-char 1)) (let ((cmd (buffer-substring-no-properties @@ -2861,10 +2861,10 @@ There might be text before point." (cons (append (car font-lock-defaults) '(doctex-font-lock-keywords)) (mapcar (lambda (x) - (case (car-safe x) - (font-lock-syntactic-face-function + (pcase (car-safe x) + (`font-lock-syntactic-face-function (cons (car x) 'doctex-font-lock-syntactic-face-function)) - (t x))) + (_ x))) (cdr font-lock-defaults)))) (set (make-local-variable 'syntax-propertize-function) (syntax-propertize-rules doctex-syntax-propertize-rules))) diff --git a/lisp/textmodes/texinfo.el b/lisp/textmodes/texinfo.el index 31af2e72699..4e7715dcea9 100644 --- a/lisp/textmodes/texinfo.el +++ b/lisp/textmodes/texinfo.el @@ -32,7 +32,7 @@ ;;; Code: -(eval-when-compile (require 'tex-mode) (require 'cl)) +(eval-when-compile (require 'tex-mode)) (defvar outline-heading-alist) (defgroup texinfo nil diff --git a/lisp/tree-widget.el b/lisp/tree-widget.el index d1150d52f3f..0dd0203e098 100644 --- a/lisp/tree-widget.el +++ b/lisp/tree-widget.el @@ -115,7 +115,6 @@ ;; ;;; Code: -(eval-when-compile (require 'cl)) (require 'wid-edit) ;;; Customization diff --git a/lisp/url/ChangeLog b/lisp/url/ChangeLog index 8b4c6ea779d..c753a1d2e61 100644 --- a/lisp/url/ChangeLog +++ b/lisp/url/ChangeLog @@ -1,3 +1,10 @@ +2012-07-11 Stefan Monnier <monnier@iro.umontreal.ca> + + * url.el, url-queue.el, url-parse.el, url-http.el, url-future.el: + * url-dav.el, url-cookie.el: Use cl-lib. + * url-util.el, url-privacy.el, url-nfs.el, url-misc.el, url-methods.el: + * url-gw.el, url-file.el, url-expand.el: Dont use CL. + 2012-06-30 Glenn Morris <rgm@gnu.org> * url-vars.el (mm-mime-mule-charset-alist, mm-coding-system-p): diff --git a/lisp/url/url-cookie.el b/lisp/url/url-cookie.el index aefe8fffd0a..84200d1d41b 100644 --- a/lisp/url/url-cookie.el +++ b/lisp/url/url-cookie.el @@ -27,7 +27,7 @@ (require 'url-parse) (require 'url-domsuf) -(eval-when-compile (require 'cl)) ; defstruct +(eval-when-compile (require 'cl-lib)) (defgroup url-cookie nil "URL cookies." @@ -38,7 +38,7 @@ ;; A cookie is stored internally as a vector of 7 slots ;; [ url-cookie NAME VALUE EXPIRES LOCALPART DOMAIN SECURE ] -(defstruct (url-cookie +(cl-defstruct (url-cookie (:constructor url-cookie-create) (:copier nil) (:type vector) diff --git a/lisp/url/url-dav.el b/lisp/url/url-dav.el index 085785524b7..77e48b0e47d 100644 --- a/lisp/url/url-dav.el +++ b/lisp/url/url-dav.el @@ -27,8 +27,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'xml) (require 'url-util) @@ -37,6 +36,10 @@ (defvar url-dav-supported-protocols '(1 2) "List of supported DAV versions.") +(defvar url-http-content-type) +(defvar url-http-response-status) +(defvar url-http-end-of-headers) + (defun url-intersection (l1 l2) "Return a list of the elements occurring in both of the lists L1 and L2." (if (null l2) @@ -198,25 +201,25 @@ "unknown")) value nil) - (case node-type - ((dateTime.iso8601tz - dateTime.iso8601 - dateTime.tz - dateTime.rfc1123 - dateTime - date) ; date is our 'special' one... + (pcase node-type + ((or `dateTime.iso8601tz + `dateTime.iso8601 + `dateTime.tz + `dateTime.rfc1123 + `dateTime + `date) ; date is our 'special' one... ;; Some type of date/time string. (setq value (url-dav-process-date-property node))) - (int + (`int ;; Integer type... (setq value (url-dav-process-integer-property node))) - ((number float) + ((or `number `float) (setq value (url-dav-process-number-property node))) - (boolean + (`boolean (setq value (url-dav-process-boolean-property node))) - (uri + (`uri (setq value (url-dav-process-uri-property node))) - (otherwise + (_ (if (not (eq node-type 'unknown)) (url-debug 'dav "Unknown data type in url-dav-process-prop: %s" node-type)) @@ -377,9 +380,6 @@ The buffer must have been retrieved by HTTP or HTTPS and contain an XML document." - (declare (special url-http-content-type - url-http-response-status - url-http-end-of-headers)) (let ((tree nil) (overall-status nil)) (when buffer @@ -561,7 +561,6 @@ FAILURE-RESULTS is a list of (URL STATUS)." (defun url-dav-unlock-resource (url lock-token) "Release the lock on URL represented by LOCK-TOKEN. Returns t if the lock was successfully released." - (declare (special url-http-response-status)) (let* ((url-request-extra-headers (list (cons "Lock-Token" (concat "<" lock-token ">")))) (url-request-method "UNLOCK") @@ -603,16 +602,16 @@ Returns t if the lock was successfully released." (while supported-locks (setq lock (car supported-locks) supported-locks (cdr supported-locks)) - (case (car lock) - (DAV:write - (case (cdr lock) - (DAV:shared ; group permissions (possibly world) + (pcase (car lock) + (`DAV:write + (pcase (cdr lock) + (`DAV:shared ; group permissions (possibly world) (aset modes 5 ?w)) - (DAV:exclusive + (`DAV:exclusive (aset modes 2 ?w)) ; owner permissions? - (otherwise + (_ (url-debug 'dav "Unrecognized DAV:lockscope (%S)" (cdr lock))))) - (otherwise + (_ (url-debug 'dav "Unrecognized DAV:locktype (%S)" (car lock))))) modes)) @@ -674,7 +673,6 @@ Returns t if the lock was successfully released." "Save OBJ as URL using WebDAV. URL must be a fully qualified URL. OBJ may be a buffer or a string." - (declare (special url-http-response-status)) (let ((buffer nil) (result nil) (url-request-extra-headers nil) @@ -820,7 +818,6 @@ If NOSORT is non-nil, the list is not sorted--its order is unpredictable. (defun url-dav-make-directory (url &optional parents) "Create the directory DIR and any nonexistent parent dirs." - (declare (special url-http-response-status)) (let* ((url-request-extra-headers nil) (url-request-method "MKCOL") (url-request-data nil) @@ -829,7 +826,7 @@ If NOSORT is non-nil, the list is not sorted--its order is unpredictable. (when buffer (unwind-protect (with-current-buffer buffer - (case url-http-response-status + (pcase url-http-response-status (201 ; Collection created in its entirety (setq result t)) (403 ; Forbidden @@ -842,7 +839,7 @@ If NOSORT is non-nil, the list is not sorted--its order is unpredictable. nil) (507 ; Insufficient storage nil) - (otherwise + (_ nil))) (kill-buffer buffer))) result)) @@ -924,7 +921,7 @@ Returns nil if URL contains no name starting with FILE." (setq failed t))) (if failed (setq searching nil) - (incf n))) + (cl-incf n))) (substring (car matches) 0 n)))))) (defun url-dav-register-handler (op) diff --git a/lisp/url/url-expand.el b/lisp/url/url-expand.el index e5c795969aa..4bf13f4abe3 100644 --- a/lisp/url/url-expand.el +++ b/lisp/url/url-expand.el @@ -24,7 +24,6 @@ (require 'url-methods) (require 'url-util) (require 'url-parse) -(eval-when-compile (require 'cl)) (defun url-expander-remove-relative-links (name) ;; Strip . and .. from pathnames diff --git a/lisp/url/url-file.el b/lisp/url/url-file.el index 62052fcaafb..4bbbdcf200c 100644 --- a/lisp/url/url-file.el +++ b/lisp/url/url-file.el @@ -23,7 +23,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'mailcap) (require 'url-vars) (require 'url-parse) @@ -172,13 +171,13 @@ to them." filename)) (setq content-type (mailcap-extension-to-mime (url-file-extension uncompressed-filename)) - content-encoding (case (intern (url-file-extension filename)) - ((\.z \.gz) "gzip") - (\.Z "compress") - (\.uue "x-uuencoded") - (\.hqx "x-hqx") - (\.bz2 "x-bzip2") - (otherwise nil))) + content-encoding (pcase (url-file-extension filename) + ((or ".z" ".gz") "gzip") + (".Z" "compress") + (".uue" "x-uuencoded") + (".hqx" "x-hqx") + (".bz2" "x-bzip2") + (_ nil))) (if (file-directory-p filename) ;; A directory is done the same whether we are local or remote diff --git a/lisp/url/url-future.el b/lisp/url/url-future.el index 8cdd6916a35..db074807e1b 100644 --- a/lisp/url/url-future.el +++ b/lisp/url/url-future.el @@ -40,9 +40,9 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) -(defstruct url-future callback errorback status value) +(cl-defstruct url-future callback errorback status value) (defmacro url-future-done-p (url-future) `(url-future-status ,url-future)) diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el index ec26ae053d8..c475fb05c9c 100644 --- a/lisp/url/url-gw.el +++ b/lisp/url/url-gw.el @@ -22,7 +22,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'url-vars) ;; Fixme: support SSH explicitly or via a url-gateway-rlogin-program? @@ -233,8 +232,8 @@ Might do a non-blocking connection; use `process-status' to check." ;; right coding systems in both Emacs and XEmacs. (let ((coding-system-for-read 'binary) (coding-system-for-write 'binary)) - (setq conn (case gw-method - ((tls ssl native) + (setq conn (pcase gw-method + ((or `tls `ssl `native) (if (eq gw-method 'native) (setq gw-method 'plain)) (open-network-stream @@ -243,13 +242,13 @@ Might do a non-blocking connection; use `process-status' to check." ;; Use non-blocking socket if we can. :nowait (featurep 'make-network-process '(:nowait t)))) - (socks + (`socks (socks-open-network-stream name buffer host service)) - (telnet + (`telnet (url-open-telnet name buffer host service)) - (rlogin + (`rlogin (url-open-rlogin name buffer host service)) - (otherwise + (_ (error "Bad setting of url-gateway-method: %s" url-gateway-method)))))) conn))) diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index fbefdbba560..0b5ecc7bf98 100644 --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el @@ -24,12 +24,32 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) + +(defvar url-callback-arguments) +(defvar url-callback-function) +(defvar url-current-object) +(defvar url-http-after-change-function) +(defvar url-http-chunked-counter) +(defvar url-http-chunked-length) +(defvar url-http-chunked-start) +(defvar url-http-connection-opened) +(defvar url-http-content-length) +(defvar url-http-content-type) +(defvar url-http-data) +(defvar url-http-end-of-headers) (defvar url-http-extra-headers) -(defvar url-http-target-url) +(defvar url-http-method) (defvar url-http-no-retry) +(defvar url-http-process) (defvar url-http-proxy) -(defvar url-http-connection-opened) +(defvar url-http-response-status) +(defvar url-http-response-version) +(defvar url-http-target-url) +(defvar url-http-transfer-encoding) +(defvar url-http-end-of-headers) +(defvar url-show-status) + (require 'url-gw) (require 'url-util) (require 'url-parse) @@ -209,9 +229,6 @@ request.") (defun url-http-create-request (&optional ref-url) "Create an HTTP request for `url-http-target-url', referred to by REF-URL." - (declare (special proxy-info - url-http-method url-http-data - url-http-extra-headers)) (let* ((extra-headers) (request nil) (no-cache (cdr-safe (assoc "Pragma" url-http-extra-headers))) @@ -358,16 +375,16 @@ request.") "Remove trailing \r from header lines. This allows us to use `mail-fetch-field', etc. Return the number of characters removed." - (declare (special url-http-end-of-headers)) (let ((end (marker-position url-http-end-of-headers))) (goto-char (point-min)) (while (re-search-forward "\r$" url-http-end-of-headers t) (replace-match "")) (- end url-http-end-of-headers))) +(defvar status) +(defvar success) + (defun url-http-handle-authentication (proxy) - (declare (special status success url-http-method url-http-data - url-callback-function url-callback-arguments)) (url-http-debug "Handling %s authentication" (if proxy "proxy" "normal")) (let ((auths (or (nreverse (mail-fetch-field @@ -427,8 +444,6 @@ Return the number of characters removed." (defun url-http-parse-response () "Parse just the response code." - (declare (special url-http-end-of-headers url-http-response-status - url-http-response-version)) (if (not url-http-end-of-headers) (error "Trying to parse HTTP response code in odd buffer: %s" (buffer-name))) (url-http-debug "url-http-parse-response called in (%s)" (buffer-name)) @@ -463,11 +478,6 @@ Return t if and only if the current buffer is still active and should be shown to the user." ;; The comments after each status code handled are taken from RFC ;; 2616 (HTTP/1.1) - (declare (special url-http-end-of-headers url-http-response-status - url-http-response-version - url-http-method url-http-data url-http-process - url-callback-function url-callback-arguments)) - (url-http-mark-connection-as-free (url-host url-current-object) (url-port url-current-object) url-http-process) @@ -508,7 +518,7 @@ should be shown to the user." (when (url-use-cookies url-http-target-url) (url-http-handle-cookies)) - (case class + (pcase class ;; Classes of response codes ;; ;; 5xx = Server Error @@ -531,12 +541,12 @@ should be shown to the user." ;; 205 Reset content ;; 206 Partial content ;; 207 Multi-status (Added by DAV) - (case status-symbol - ((no-content reset-content) + (pcase status-symbol + ((or `no-content `reset-content) ;; No new data, just stay at the same document (url-mark-buffer-as-dead buffer) (setq success t)) - (otherwise + (_ ;; Generic success for all others. Store in the cache, and ;; mark it as successful. (widen) @@ -553,8 +563,8 @@ should be shown to the user." ;; 307 Temporary redirect (let ((redirect-uri (or (mail-fetch-field "Location") (mail-fetch-field "URI")))) - (case status-symbol - (multiple-choices ; 300 + (pcase status-symbol + (`multiple-choices ; 300 ;; Quoth the spec (section 10.3.1) ;; ------------------------------- ;; The requested resource corresponds to any one of a set of @@ -571,7 +581,7 @@ should be shown to the user." ;; We do not support agent-driven negotiation, so we just ;; redirect to the preferred URI if one is provided. nil) - ((moved-permanently found temporary-redirect) ; 301 302 307 + ((or `moved-permanently `found `temporary-redirect) ; 301 302 307 ;; If the 301|302 status code is received in response to a ;; request other than GET or HEAD, the user agent MUST NOT ;; automatically redirect the request unless it can be @@ -579,20 +589,20 @@ should be shown to the user." ;; conditions under which the request was issued. (unless (member url-http-method '("HEAD" "GET")) (setq redirect-uri nil))) - (see-other ; 303 + (`see-other ; 303 ;; The response to the request can be found under a different ;; URI and SHOULD be retrieved using a GET method on that ;; resource. (setq url-http-method "GET" url-http-data nil)) - (not-modified ; 304 + (`not-modified ; 304 ;; The 304 response MUST NOT contain a message-body. (url-http-debug "Extracting document from cache... (%s)" (url-cache-create-filename (url-view-url t))) (url-cache-extract (url-cache-create-filename (url-view-url t))) (setq redirect-uri nil success t)) - (use-proxy ; 305 + (`use-proxy ; 305 ;; The requested resource MUST be accessed through the ;; proxy given by the Location field. The Location field ;; gives the URI of the proxy. The recipient is expected @@ -600,7 +610,7 @@ should be shown to the user." ;; responses MUST only be generated by origin servers. (error "Redirection thru a proxy server not supported: %s" redirect-uri)) - (otherwise + (_ ;; Treat everything like '300' nil)) (when redirect-uri @@ -682,51 +692,51 @@ should be shown to the user." ;; 422 Unprocessable Entity (Added by DAV) ;; 423 Locked ;; 424 Failed Dependency - (case status-symbol - (unauthorized ; 401 + (pcase status-symbol + (`unauthorized ; 401 ;; The request requires user authentication. The response ;; MUST include a WWW-Authenticate header field containing a ;; challenge applicable to the requested resource. The ;; client MAY repeat the request with a suitable ;; Authorization header field. (url-http-handle-authentication nil)) - (payment-required ; 402 + (`payment-required ; 402 ;; This code is reserved for future use (url-mark-buffer-as-dead buffer) (error "Somebody wants you to give them money")) - (forbidden ; 403 + (`forbidden ; 403 ;; The server understood the request, but is refusing to ;; fulfill it. Authorization will not help and the request ;; SHOULD NOT be repeated. (setq success t)) - (not-found ; 404 + (`not-found ; 404 ;; Not found (setq success t)) - (method-not-allowed ; 405 + (`method-not-allowed ; 405 ;; The method specified in the Request-Line is not allowed ;; for the resource identified by the Request-URI. The ;; response MUST include an Allow header containing a list of ;; valid methods for the requested resource. (setq success t)) - (not-acceptable ; 406 + (`not-acceptable ; 406 ;; The resource identified by the request is only capable of ;; generating response entities which have content ;; characteristics not acceptable according to the accept ;; headers sent in the request. (setq success t)) - (proxy-authentication-required ; 407 + (`proxy-authentication-required ; 407 ;; This code is similar to 401 (Unauthorized), but indicates ;; that the client must first authenticate itself with the ;; proxy. The proxy MUST return a Proxy-Authenticate header ;; field containing a challenge applicable to the proxy for ;; the requested resource. (url-http-handle-authentication t)) - (request-timeout ; 408 + (`request-timeout ; 408 ;; The client did not produce a request within the time that ;; the server was prepared to wait. The client MAY repeat ;; the request without modifications at any later time. (setq success t)) - (conflict ; 409 + (`conflict ; 409 ;; The request could not be completed due to a conflict with ;; the current state of the resource. This code is only ;; allowed in situations where it is expected that the user @@ -735,11 +745,11 @@ should be shown to the user." ;; information for the user to recognize the source of the ;; conflict. (setq success t)) - (gone ; 410 + (`gone ; 410 ;; The requested resource is no longer available at the ;; server and no forwarding address is known. (setq success t)) - (length-required ; 411 + (`length-required ; 411 ;; The server refuses to accept the request without a defined ;; Content-Length. The client MAY repeat the request if it ;; adds a valid Content-Length header field containing the @@ -749,35 +759,35 @@ should be shown to the user." ;; `url-http-create-request' automatically calculates the ;; content-length. (setq success t)) - (precondition-failed ; 412 + (`precondition-failed ; 412 ;; The precondition given in one or more of the ;; request-header fields evaluated to false when it was ;; tested on the server. (setq success t)) - ((request-entity-too-large request-uri-too-large) ; 413 414 + ((or `request-entity-too-large `request-uri-too-large) ; 413 414 ;; The server is refusing to process a request because the ;; request entity|URI is larger than the server is willing or ;; able to process. (setq success t)) - (unsupported-media-type ; 415 + (`unsupported-media-type ; 415 ;; The server is refusing to service the request because the ;; entity of the request is in a format not supported by the ;; requested resource for the requested method. (setq success t)) - (requested-range-not-satisfiable ; 416 + (`requested-range-not-satisfiable ; 416 ;; A server SHOULD return a response with this status code if ;; a request included a Range request-header field, and none ;; of the range-specifier values in this field overlap the ;; current extent of the selected resource, and the request ;; did not include an If-Range request-header field. (setq success t)) - (expectation-failed ; 417 + (`expectation-failed ; 417 ;; The expectation given in an Expect request-header field ;; could not be met by this server, or, if the server is a ;; proxy, the server has unambiguous evidence that the ;; request could not be met by the next-hop server. (setq success t)) - (otherwise + (_ ;; The request could not be understood by the server due to ;; malformed syntax. The client SHOULD NOT repeat the ;; request without modifications. @@ -797,17 +807,17 @@ should be shown to the user." ;; 505 HTTP version not supported ;; 507 Insufficient storage (setq success t) - (case url-http-response-status - (not-implemented ; 501 + (pcase url-http-response-status + (`not-implemented ; 501 ;; The server does not support the functionality required to ;; fulfill the request. nil) - (bad-gateway ; 502 + (`bad-gateway ; 502 ;; The server, while acting as a gateway or proxy, received ;; an invalid response from the upstream server it accessed ;; in attempting to fulfill the request. nil) - (service-unavailable ; 503 + (`service-unavailable ; 503 ;; The server is currently unable to handle the request due ;; to a temporary overloading or maintenance of the server. ;; The implication is that this is a temporary condition @@ -816,19 +826,19 @@ should be shown to the user." ;; header. If no Retry-After is given, the client SHOULD ;; handle the response as it would for a 500 response. nil) - (gateway-timeout ; 504 + (`gateway-timeout ; 504 ;; The server, while acting as a gateway or proxy, did not ;; receive a timely response from the upstream server ;; specified by the URI (e.g. HTTP, FTP, LDAP) or some other ;; auxiliary server (e.g. DNS) it needed to access in ;; attempting to complete the request. nil) - (http-version-not-supported ; 505 + (`http-version-not-supported ; 505 ;; The server does not support, or refuses to support, the ;; HTTP protocol version that was used in the request ;; message. nil) - (insufficient-storage ; 507 (DAV) + (`insufficient-storage ; 507 (DAV) ;; The method could not be performed on the resource ;; because the server is unable to store the representation ;; needed to successfully complete the request. This @@ -843,7 +853,7 @@ should be shown to the user." (setf (car url-callback-arguments) (nconc (list :error (list 'error 'http url-http-response-status)) (car url-callback-arguments))))) - (otherwise + (_ (error "Unknown class of HTTP response code: %d (%d)" class url-http-response-status))) (if (not success) @@ -855,9 +865,6 @@ should be shown to the user." ;; Miscellaneous (defun url-http-activate-callback () "Activate callback specified when this buffer was created." - (declare (special url-http-process - url-callback-function - url-callback-arguments)) (url-http-mark-connection-as-free (url-host url-current-object) (url-port url-current-object) url-http-process) @@ -899,7 +906,6 @@ should be shown to the user." (defun url-http-simple-after-change-function (st nd length) ;; Function used when we do NOT know how long the document is going to be ;; Just _very_ simple 'downloaded %d' type of info. - (declare (special url-http-end-of-headers)) (url-lazy-message "Reading %s..." (url-pretty-length nd))) (defun url-http-content-length-after-change-function (st nd length) @@ -907,11 +913,6 @@ should be shown to the user." More sophisticated percentage downloaded, etc. Also does minimal parsing of HTTP headers and will actually cause the callback to be triggered." - (declare (special url-current-object - url-http-end-of-headers - url-http-content-length - url-http-content-type - url-http-process)) (if url-http-content-type (url-display-percentage "Reading [%s]... %s of %s (%d%%)" @@ -944,12 +945,6 @@ the callback to be triggered." Cannot give a sophisticated percentage, but we need a different function to look for the special 0-length chunk that signifies the end of the document." - (declare (special url-current-object - url-http-end-of-headers - url-http-content-type - url-http-chunked-length - url-http-chunked-counter - url-http-process url-http-chunked-start)) (save-excursion (goto-char st) (let ((read-next-chunk t) @@ -1035,17 +1030,6 @@ the end of the document." (defun url-http-wait-for-headers-change-function (st nd length) ;; This will wait for the headers to arrive and then splice in the ;; next appropriate after-change-function, etc. - (declare (special url-current-object - url-http-end-of-headers - url-http-content-type - url-http-content-length - url-http-transfer-encoding - url-callback-function - url-callback-arguments - url-http-process - url-http-method - url-http-after-change-function - url-http-response-status)) (url-http-debug "url-http-wait-for-headers-change-function (%s)" (buffer-name)) (let ((end-of-headers nil) @@ -1180,28 +1164,13 @@ CBARGS as the arguments. Optional arg RETRY-BUFFER, if non-nil, specifies the buffer of a previous `url-http' call, which is being re-attempted." - (check-type url vector "Need a pre-parsed URL.") - (declare (special url-current-object - url-http-end-of-headers - url-http-content-type - url-http-content-length - url-http-transfer-encoding - url-http-after-change-function - url-callback-function - url-callback-arguments - url-show-status - url-http-method - url-http-extra-headers - url-http-data - url-http-chunked-length - url-http-chunked-start - url-http-chunked-counter - url-http-process)) + (cl-check-type url vector "Need a pre-parsed URL.") (let* ((host (url-host (or url-using-proxy url))) (port (url-port (or url-using-proxy url))) (connection (url-http-find-free-connection host port)) (buffer (or retry-buffer - (generate-new-buffer (format " *http %s:%d*" host port))))) + (generate-new-buffer + (format " *http %s:%d*" host port))))) (if (not connection) ;; Failed to open the connection for some reason (progn @@ -1262,12 +1231,12 @@ previous `url-http' call, which is being re-attempted." ;; Asynchronous connection failed (error "Could not create connection to %s:%d" host port)) (t - (set-process-sentinel connection 'url-http-end-of-document-sentinel) + (set-process-sentinel connection + 'url-http-end-of-document-sentinel) (process-send-string connection (url-http-create-request))))))) buffer)) (defun url-http-async-sentinel (proc why) - (declare (special url-callback-arguments)) ;; We are performing an asynchronous connection, and a status change ;; has occurred. (when (buffer-name (process-buffer proc)) @@ -1302,7 +1271,6 @@ previous `url-http' call, which is being re-attempted." ;; Sometimes we get a zero-length data chunk after the process has ;; been changed to 'free', which means it has no buffer associated ;; with it. Do nothing if there is no buffer, or 0 length data. - (declare (special url-http-after-change-function)) (and (process-buffer proc) (/= (length data) 0) (with-current-buffer (process-buffer proc) diff --git a/lisp/url/url-methods.el b/lisp/url/url-methods.el index b61198393b5..bd7d8e33922 100644 --- a/lisp/url/url-methods.el +++ b/lisp/url/url-methods.el @@ -23,9 +23,6 @@ ;;; Code: -(eval-when-compile - (require 'cl)) - ;; This loads up some of the small, silly URLs that I really don't ;; want to bother putting in their own separate files. (require 'url-parse) @@ -134,17 +131,17 @@ it has not already been loaded." (let ((symbol (intern-soft (format "%s-%s" stub (car cell)))) (type (cdr cell))) (if symbol - (case type - (function + (pcase type + (`function ;; Store the symbol name of a function (if (fboundp symbol) (setq desc (plist-put desc (car cell) symbol)))) - (variable + (`variable ;; Store the VALUE of a variable (if (boundp symbol) (setq desc (plist-put desc (car cell) (symbol-value symbol))))) - (otherwise + (_ (error "Malformed url-scheme-methods entry: %S" cell)))))) (puthash scheme desc url-scheme-registry))))) diff --git a/lisp/url/url-misc.el b/lisp/url/url-misc.el index fa8176873a8..dd521ccd690 100644 --- a/lisp/url/url-misc.el +++ b/lisp/url/url-misc.el @@ -21,7 +21,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'url-vars) (require 'url-parse) (autoload 'Info-goto-node "info" "" t) @@ -47,23 +46,23 @@ (defun url-do-terminal-emulator (type server port user) (terminal-emulator (generate-new-buffer (format "%s%s" (if user (concat user "@") "") server)) - (case type - (rlogin "rlogin") - (telnet "telnet") - (tn3270 "tn3270") - (otherwise + (pcase type + (`rlogin "rlogin") + (`telnet "telnet") + (`tn3270 "tn3270") + (_ (error "Unknown terminal emulator required: %s" type))) - (case type - (rlogin + (pcase type + (`rlogin (if user (list server "-l" user) (list server))) - (telnet + (`telnet (if user (message "Please log in as user: %s" user)) (if port (list server port) (list server))) - (tn3270 + (`tn3270 (if user (message "Please log in as user: %s" user)) (list server))))) diff --git a/lisp/url/url-nfs.el b/lisp/url/url-nfs.el index cb5695b5549..2eed16c3ad3 100644 --- a/lisp/url/url-nfs.el +++ b/lisp/url/url-nfs.el @@ -23,7 +23,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'url-parse) (require 'url-file) @@ -49,7 +48,7 @@ Each can be used any number of times." (while (re-search-forward "%\\(.\\)" nil t) (let ((escape (aref (match-string 1) 0))) (replace-match "" t t) - (case escape + (pcase escape (?% (insert "%")) (?h (insert host)) (?n (insert (or port ""))) diff --git a/lisp/url/url-parse.el b/lisp/url/url-parse.el index 18c5790313e..46ad1daef01 100644 --- a/lisp/url/url-parse.el +++ b/lisp/url/url-parse.el @@ -25,11 +25,11 @@ (require 'url-vars) (require 'auth-source) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (autoload 'url-scheme-get-property "url-methods") -(defstruct (url +(cl-defstruct (url (:constructor nil) (:constructor url-parse-make-urlobj (&optional type user password host portspec filename @@ -40,11 +40,11 @@ (defsubst url-port (urlobj) "Return the port number for the URL specified by URLOBJ." + (declare (gv-setter (lambda (port) `(setf (url-portspec ,urlobj) ,port)))) (or (url-portspec urlobj) (if (url-type urlobj) (url-scheme-get-property (url-type urlobj) 'default-port)))) -(defsetf url-port (urlobj) (port) `(setf (url-portspec ,urlobj) ,port)) (defun url-path-and-query (urlobj) "Return the path and query components of URLOBJ. diff --git a/lisp/url/url-privacy.el b/lisp/url/url-privacy.el index 85247857beb..4524cb416bf 100644 --- a/lisp/url/url-privacy.el +++ b/lisp/url/url-privacy.el @@ -21,7 +21,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'url-vars) (defun url-device-type (&optional device) @@ -46,11 +45,11 @@ ((memq (url-device-type) '(win32 w32)) "Windows; 32bit") ((eq (url-device-type) 'pm) "OS/2; 32bit") (t - (case (url-device-type) - (x "X11") - (ns "OpenStep") - (tty "TTY") - (otherwise nil))))) + (pcase (url-device-type) + (`x "X11") + (`ns "OpenStep") + (`tty "TTY") + (_ nil))))) (setq url-personal-mail-address (or url-personal-mail-address user-mail-address diff --git a/lisp/url/url-queue.el b/lisp/url/url-queue.el index 917c787df29..327ce977cfd 100644 --- a/lisp/url/url-queue.el +++ b/lisp/url/url-queue.el @@ -28,7 +28,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'browse-url) (require 'url-parse) @@ -48,7 +48,7 @@ (defvar url-queue nil) -(defstruct url-queue +(cl-defstruct url-queue url callback cbargs silentp buffer start-time pre-triggered inhibit-cookiesp) @@ -84,7 +84,7 @@ The variable `url-queue-timeout' sets a timeout." (cond ((or (url-queue-start-time entry) (url-queue-pre-triggered entry)) - (incf running)) + (cl-incf running)) ((not waiting) (setq waiting entry)))) (when (and waiting @@ -99,7 +99,7 @@ The variable `url-queue-timeout' sets a timeout." (dolist (entry url-queue) (cond ((url-queue-start-time entry) - (incf running)) + (cl-incf running)) ((not waiting) (setq waiting entry)))) (when (and waiting diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el index 18fc51f0d10..2faca26f2dd 100644 --- a/lisp/url/url-util.el +++ b/lisp/url/url-util.el @@ -26,7 +26,6 @@ (require 'url-parse) (require 'url-vars) -(eval-when-compile (require 'cl)) (autoload 'timezone-parse-date "timezone") (autoload 'timezone-make-date-arpa-standard "timezone") (autoload 'mail-header-extract "mailheader") diff --git a/lisp/url/url.el b/lisp/url/url.el index 999b006cf02..87ae7a51aac 100644 --- a/lisp/url/url.el +++ b/lisp/url/url.el @@ -26,7 +26,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'mailcap) diff --git a/lisp/vc/vc-annotate.el b/lisp/vc/vc-annotate.el index f4964ef85cc..1b98194e74a 100644 --- a/lisp/vc/vc-annotate.el +++ b/lisp/vc/vc-annotate.el @@ -29,8 +29,7 @@ (require 'vc) ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defcustom vc-annotate-display-mode 'fullscale "Which mode to color the output of \\[vc-annotate] with by default." @@ -195,7 +194,7 @@ The current time is used as the offset." (let ((bol (point)) (date (vc-call-backend vc-annotate-backend 'annotate-time)) (inhibit-read-only t)) - (assert (>= (point) bol)) + (cl-assert (>= (point) bol)) (put-text-property bol (point) 'invisible 'vc-annotate-annotation) date)) diff --git a/lisp/vc/vc-arch.el b/lisp/vc/vc-arch.el index afeab878f1e..2e20d97e21d 100644 --- a/lisp/vc/vc-arch.el +++ b/lisp/vc/vc-arch.el @@ -54,7 +54,7 @@ ;;; Code: -(eval-when-compile (require 'vc) (require 'cl)) +(eval-when-compile (require 'vc)) ;;; Properties of the backend @@ -391,9 +391,9 @@ CALLBACK expects (ENTRIES &optional MORE-TO-COME); see (if (string-match (car rule) rev) (setq rev (replace-match (cdr rule) t nil rev)))) (format "Arch%c%s" - (case (vc-state file) - ((up-to-date needs-update) ?-) - (added ?@) + (pcase (vc-state file) + ((or `up-to-date `needs-update) ?-) + (`added ?@) (t ?:)) rev))) diff --git a/lisp/vc/vc-bzr.el b/lisp/vc/vc-bzr.el index b5488eb96a9..ce4d76dc5f2 100644 --- a/lisp/vc/vc-bzr.el +++ b/lisp/vc/vc-bzr.el @@ -46,7 +46,7 @@ ;;; Code: (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'vc) ;; for vc-exec-after (require 'vc-dir)) @@ -102,9 +102,9 @@ Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and `LC_MESSAGES=C' to the environment. If BZR-COMMAND is \"status\", prepends `vc-bzr-status-switches' to ARGS." (let ((process-environment - (list* "BZR_PROGRESS_BAR=none" ; Suppress progress output (bzr >=0.9) - "LC_MESSAGES=C" ; Force English output - process-environment))) + `("BZR_PROGRESS_BAR=none" ; Suppress progress output (bzr >=0.9) + "LC_MESSAGES=C" ; Force English output + ,@process-environment))) (apply 'vc-do-command (or buffer "*vc*") okstatus vc-bzr-program file-or-list bzr-command (if (and (string-equal "status" bzr-command) @@ -123,8 +123,8 @@ Use the current Bzr root directory as the ROOT argument to `vc-do-async-command', and specify an output buffer named \"*vc-bzr : ROOT*\". Return this buffer." (let* ((process-environment - (list* "BZR_PROGRESS_BAR=none" "LC_MESSAGES=C" - process-environment)) + `("BZR_PROGRESS_BAR=none" "LC_MESSAGES=C" + ,@process-environment)) (root (vc-bzr-root default-directory)) (buffer (format "*vc-bzr : %s*" (expand-file-name root)))) (apply 'vc-do-async-command buffer root @@ -861,7 +861,7 @@ stream. Standard error output is discarded." (apply #'process-file command nil (list (current-buffer) nil) nil args) (buffer-substring (point-min) (point-max))))) -(defstruct (vc-bzr-extra-fileinfo +(cl-defstruct (vc-bzr-extra-fileinfo (:copier nil) (:constructor vc-bzr-create-extra-fileinfo (extra-name)) (:conc-name vc-bzr-extra-fileinfo->)) diff --git a/lisp/vc/vc-cvs.el b/lisp/vc/vc-cvs.el index 300dc463a3c..2a672623c01 100644 --- a/lisp/vc/vc-cvs.el +++ b/lisp/vc/vc-cvs.el @@ -25,7 +25,7 @@ ;;; Code: -(eval-when-compile (require 'cl) (require 'vc)) +(eval-when-compile (require 'vc)) ;; Clear up the cache to force vc-call to check again and discover ;; new functions when we reload this file. @@ -790,7 +790,7 @@ For an empty string, nil is returned (invalid CVS root)." ((= len 3) ;; :METHOD:PATH or :METHOD:USER@HOSTNAME/PATH (cons (cadr root-list) - (vc-cvs-parse-uhp (caddr root-list)))) + (vc-cvs-parse-uhp (nth 2 root-list)))) (t ;; :METHOD:[USER@]HOST:PATH (cdr root-list))))) diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index acb1a4d8862..7c840fd071b 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -43,8 +43,7 @@ (require 'ewoc) ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defcustom vc-dir-mode-hook nil "Normal hook run by `vc-dir-mode'. @@ -54,7 +53,7 @@ See `run-hooks'." ;; Used to store information for the files displayed in the directory buffer. ;; Each item displayed corresponds to one of these defstructs. -(defstruct (vc-dir-fileinfo +(cl-defstruct (vc-dir-fileinfo (:copier nil) (:type list) ;So we can use `member' on lists of FIs. (:constructor @@ -92,13 +91,13 @@ See `run-hooks'." (let* ;; Look for another buffer name BNAME visiting the same directory. ((buf (save-excursion (unless create-new - (dolist (buffer vc-dir-buffers) + (cl-dolist (buffer vc-dir-buffers) (when (buffer-live-p buffer) (set-buffer buffer) (when (and (derived-mode-p 'vc-dir-mode) (eq vc-dir-backend backend) (string= default-directory dir)) - (return buffer)))))))) + (cl-return buffer)))))))) (or buf ;; Create a new buffer named BNAME. ;; We pass a filename to create-file-buffer because it is what diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 8b48efbfd24..4dbc9eab27f 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -104,7 +104,7 @@ ;; - find-file-hook () NOT NEEDED (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'vc) (require 'vc-dir) (require 'grep)) @@ -201,7 +201,7 @@ matching the resulting Git log output, and KEYWORDS is a list of (defun vc-git--state-code (code) "Convert from a string to a added/deleted/modified state." - (case (string-to-char code) + (pcase (string-to-char code) (?M 'edited) (?A 'added) (?D 'removed) @@ -261,7 +261,7 @@ matching the resulting Git log output, and KEYWORDS is a list of (propertize def-ml 'help-echo (concat help-echo "\nCurrent branch: " branch))))) -(defstruct (vc-git-extra-fileinfo +(cl-defstruct (vc-git-extra-fileinfo (:copier nil) (:constructor vc-git-create-extra-fileinfo (old-perm new-perm &optional rename-state orig-name)) @@ -275,12 +275,12 @@ matching the resulting Git log output, and KEYWORDS is a list of (if (string-match "[\n\t\"\\]" name) (concat "\"" (mapconcat (lambda (c) - (case c + (pcase c (?\n "\\n") (?\t "\\t") (?\\ "\\\\") (?\" "\\\"") - (t (char-to-string c)))) + (_ (char-to-string c)))) name "") "\"") name)) @@ -289,28 +289,28 @@ matching the resulting Git log output, and KEYWORDS is a list of "Return a string describing the file type based on its permissions." (let* ((old-type (lsh (or old-perm 0) -9)) (new-type (lsh (or new-perm 0) -9)) - (str (case new-type + (str (pcase new-type (?\100 ;; File. - (case old-type + (pcase old-type (?\100 nil) (?\120 " (type change symlink -> file)") (?\160 " (type change subproject -> file)"))) (?\120 ;; Symlink. - (case old-type + (pcase old-type (?\100 " (type change file -> symlink)") (?\160 " (type change subproject -> symlink)") (t " (symlink)"))) (?\160 ;; Subproject. - (case old-type + (pcase old-type (?\100 " (type change file -> subproject)") (?\120 " (type change symlink -> subproject)") (t " (subproject)"))) (?\110 nil) ;; Directory (internal, not a real git state). (?\000 ;; Deleted or unknown. - (case old-type + (pcase old-type (?\120 " (symlink)") (?\160 " (subproject)"))) - (t (format " (unknown type %o)" new-type))))) + (_ (format " (unknown type %o)" new-type))))) (cond (str (propertize str 'face 'font-lock-comment-face)) ((eq new-type ?\110) "/") (t "")))) @@ -378,18 +378,18 @@ or an empty string if none." "Process sentinel for the various dir-status stages." (let (next-stage result) (goto-char (point-min)) - (case stage - (update-index + (pcase stage + (`update-index (setq next-stage (if (vc-git--empty-db-p) 'ls-files-added (if files 'ls-files-up-to-date 'diff-index)))) - (ls-files-added + (`ls-files-added (setq next-stage 'ls-files-unknown) (while (re-search-forward "\\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} 0\t\\([^\0]+\\)\0" nil t) (let ((new-perm (string-to-number (match-string 1) 8)) (name (match-string 2))) (push (list name 'added (vc-git-create-extra-fileinfo 0 new-perm)) result)))) - (ls-files-up-to-date + (`ls-files-up-to-date (setq next-stage 'diff-index) (while (re-search-forward "\\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} 0\t\\([^\0]+\\)\0" nil t) (let ((perm (string-to-number (match-string 1) 8)) @@ -397,18 +397,18 @@ or an empty string if none." (push (list name 'up-to-date (vc-git-create-extra-fileinfo perm perm)) result)))) - (ls-files-unknown + (`ls-files-unknown (when files (setq next-stage 'ls-files-ignored)) (while (re-search-forward "\\([^\0]*?\\)\0" nil t 1) (push (list (match-string 1) 'unregistered (vc-git-create-extra-fileinfo 0 0)) result))) - (ls-files-ignored + (`ls-files-ignored (while (re-search-forward "\\([^\0]*?\\)\0" nil t 1) (push (list (match-string 1) 'ignored (vc-git-create-extra-fileinfo 0 0)) result))) - (diff-index + (`diff-index (setq next-stage 'ls-files-unknown) (while (re-search-forward ":\\([0-7]\\{6\\}\\) \\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} [0-9a-f]\\{40\\} \\(\\([ADMUT]\\)\0\\([^\0]+\\)\\|\\([CR]\\)[0-9]*\0\\([^\0]+\\)\0\\([^\0]+\\)\\)\0" @@ -447,28 +447,28 @@ or an empty string if none." (defun vc-git-dir-status-goto-stage (stage files update-function) (erase-buffer) - (case stage - (update-index + (pcase stage + (`update-index (if files (vc-git-command (current-buffer) 'async files "add" "--refresh" "--") (vc-git-command (current-buffer) 'async nil "update-index" "--refresh"))) - (ls-files-added + (`ls-files-added (vc-git-command (current-buffer) 'async files "ls-files" "-z" "-c" "-s" "--")) - (ls-files-up-to-date + (`ls-files-up-to-date (vc-git-command (current-buffer) 'async files "ls-files" "-z" "-c" "-s" "--")) - (ls-files-unknown + (`ls-files-unknown (vc-git-command (current-buffer) 'async files "ls-files" "-z" "-o" "--directory" "--no-empty-directory" "--exclude-standard" "--")) - (ls-files-ignored + (`ls-files-ignored (vc-git-command (current-buffer) 'async files "ls-files" "-z" "-o" "-i" "--directory" "--no-empty-directory" "--exclude-standard" "--")) ;; --relative added in Git 1.5.5. - (diff-index + (`diff-index (vc-git-command (current-buffer) 'async files "diff-index" "--relative" "-z" "-M" "HEAD" "--"))) (vc-exec-after diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index e3af8a353ef..6dbf6978372 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -111,7 +111,7 @@ ;;; Code: (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'vc) (require 'vc-dir)) @@ -485,7 +485,7 @@ REV is the revision to check out into WORKFILE." (defvar log-view-vc-backend) -(defstruct (vc-hg-extra-fileinfo +(cl-defstruct (vc-hg-extra-fileinfo (:copier nil) (:constructor vc-hg-create-extra-fileinfo (rename-state extra-name)) (:conc-name vc-hg-extra-fileinfo->)) @@ -501,10 +501,10 @@ REV is the revision to check out into WORKFILE." (when extra (insert (propertize (format " (%s %s)" - (case (vc-hg-extra-fileinfo->rename-state extra) - (copied "copied from") - (renamed-from "renamed from") - (renamed-to "renamed to")) + (pcase (vc-hg-extra-fileinfo->rename-state extra) + (`copied "copied from") + (`renamed-from "renamed from") + (`renamed-to "renamed to")) (vc-hg-extra-fileinfo->extra-name extra)) 'face 'font-lock-comment-face))))) diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el index a753004d784..54c33769267 100644 --- a/lisp/vc/vc-hooks.el +++ b/lisp/vc/vc-hooks.el @@ -30,8 +30,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;; Customization Variables (the rest is in vc.el) @@ -311,7 +310,7 @@ non-nil if FILE exists and its contents were successfully inserted." (let ((filepos 0)) (while (and (< 0 (cadr (insert-file-contents - file nil filepos (incf filepos blocksize)))) + file nil filepos (cl-incf filepos blocksize)))) (progn (beginning-of-line) (let ((pos (re-search-forward limit nil 'move))) (when pos (delete-region (match-beginning 0) @@ -561,7 +560,7 @@ Return non-nil if FILE is unchanged." (if (or (not (eq (cadr err) (indirect-function (vc-find-backend-function backend 'diff)))) - (not (eq (caddr err) 4))) + (not (eq (cl-caddr err) 4))) (signal (car err) (cdr err)) (vc-call-backend backend 'diff (list file))))))) diff --git a/lisp/vc/vc-mtn.el b/lisp/vc/vc-mtn.el index a3d5f09255e..67c0f985ae1 100644 --- a/lisp/vc/vc-mtn.el +++ b/lisp/vc/vc-mtn.el @@ -32,7 +32,7 @@ ;;; Code: -(eval-when-compile (require 'cl) (require 'vc)) +(eval-when-compile (require 'vc)) (defgroup vc-mtn nil "VC Monotone (mtn) backend." @@ -167,10 +167,10 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches." (if (string-match (car rule) branch) (setq branch (replace-match (cdr rule) t nil branch)))) (format "Mtn%c%s" - (case (vc-state file) - ((up-to-date needs-update) ?-) - (added ?@) - (t ?:)) + (pcase (vc-state file) + ((or `up-to-date `needs-update) ?-) + (`added ?@) + (_ ?:)) branch))) (defun vc-mtn-register (files &optional _rev _comment) diff --git a/lisp/vc/vc-rcs.el b/lisp/vc/vc-rcs.el index 4f50e1c8690..ecd7b826437 100644 --- a/lisp/vc/vc-rcs.el +++ b/lisp/vc/vc-rcs.el @@ -38,7 +38,7 @@ ;;; (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'vc)) (defgroup vc-rcs nil @@ -705,17 +705,17 @@ Optional arg REVISION is a revision to annotate from." (goto-char (point-min)) (forward-line (1- (pop insn))) (setq p (point)) - (case (pop insn) - (k (setq s (buffer-substring-no-properties - p (progn (forward-line (car insn)) - (point)))) - (when prda - (push `(,p . ,(propertize s :vc-rcs-r/d/a prda)) path)) - (delete-region p (point))) - (i (setq s (car insn)) - (when prda - (push `(,p . ,(length s)) path)) - (insert s))))) + (pcase (pop insn) + (`k (setq s (buffer-substring-no-properties + p (progn (forward-line (car insn)) + (point)))) + (when prda + (push `(,p . ,(propertize s :vc-rcs-r/d/a prda)) path)) + (delete-region p (point))) + (`i (setq s (car insn)) + (when prda + (push `(,p . ,(length s)) path)) + (insert s))))) ;; For the initial revision, setting `:vc-rcs-r/d/a' directly is ;; equivalent to pushing an insert instruction (of the entire buffer ;; contents) onto `path' then erasing the buffer, but less wasteful. @@ -737,14 +737,14 @@ Optional arg REVISION is a revision to annotate from." (dolist (insn (cdr (assq :insn meta))) (goto-char (point-min)) (forward-line (1- (pop insn))) - (case (pop insn) - (k (delete-region - (point) (progn (forward-line (car insn)) - (point)))) - (i (insert (propertize - (car insn) - :vc-rcs-r/d/a - (or prda (setq prda (r/d/a)))))))) + (pcase (pop insn) + (`k (delete-region + (point) (progn (forward-line (car insn)) + (point)))) + (`i (insert (propertize + (car insn) + :vc-rcs-r/d/a + (or prda (setq prda (r/d/a)))))))) (prog1 (not (string= (if nbls (caar nbls) revision) pre)) (setq pre (cdr (assq 'next meta))))))))) ;; Lastly, for each line, insert at bol nicely-formatted history info. @@ -1461,7 +1461,7 @@ The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension." start (read (current-buffer)) act (read (current-buffer))) (forward-char 1) - (push (case cmd + (push (pcase cmd (?d ;; `d' means "delete lines". ;; For Emacs spirit, we use `k' for "kill". @@ -1475,7 +1475,7 @@ The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension." `(,(1+ start) i ,(funcall sub (point) (progn (forward-line act) (point))))) - (t (error "Bad command `%c' in `text' for rev `%s'" + (_ (error "Bad command `%c' in `text' for rev `%s'" cmd context))) acc)) (goto-char (1+ e)) diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 651008b4e65..0f3298d2686 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -658,7 +658,6 @@ (declare-function diff-setup-whitespace "diff-mode" ()) (eval-when-compile - (require 'cl) (require 'dired)) (unless (assoc 'vc-parent-buffer minor-mode-alist) diff --git a/lisp/wdired.el b/lisp/wdired.el index f65574c26ad..d5ce0beccbb 100644 --- a/lisp/wdired.el +++ b/lisp/wdired.el @@ -75,7 +75,6 @@ (defvar dired-backup-overwrite) ; Only in Emacs 20.x this is a custom var -(eval-when-compile (require 'cl)) (require 'dired) (autoload 'dired-do-create-files-regexp "dired-aux") diff --git a/lisp/wid-browse.el b/lisp/wid-browse.el index 005e87a6dae..ab5122d6153 100644 --- a/lisp/wid-browse.el +++ b/lisp/wid-browse.el @@ -30,7 +30,6 @@ (require 'easymenu) (require 'custom) (require 'wid-edit) -(eval-when-compile (require 'cl)) (defgroup widget-browse nil "Customization support for browsing widgets." diff --git a/lisp/winner.el b/lisp/winner.el index 10595ed4b5a..d808a54a10e 100644 --- a/lisp/winner.el +++ b/lisp/winner.el @@ -38,20 +38,17 @@ ;;; Code: -(eval-when-compile - (require 'cl)) - - -(defmacro winner-active-region () +(eval-when-compile (require 'cl-lib)) + +(defun winner-active-region () + (declare (gv-setter (lambda (store) + (if (featurep 'xemacs) + `(if ,store (zmacs-activate-region) + (zmacs-deactivate-region)) + `(setq mark-active ,store))))) (if (boundp 'mark-active) - 'mark-active - '(region-active-p))) - -(defsetf winner-active-region () (store) - (if (featurep 'xemacs) - `(if ,store (zmacs-activate-region) - (zmacs-deactivate-region)) - `(setq mark-active ,store))) + mark-active + (region-active-p))) (defalias 'winner-edges (if (featurep 'xemacs) 'window-pixel-edges 'window-edges)) @@ -107,15 +104,15 @@ You may want to include buffer names such as *Help*, *Apropos*, (defun winner-sorted-window-list () (sort (winner-window-list) (lambda (x y) - (loop for a in (winner-edges x) - for b in (winner-edges y) - while (= a b) - finally return (< a b))))) + (cl-loop for a in (winner-edges x) + for b in (winner-edges y) + while (= a b) + finally return (< a b))))) (defun winner-win-data () ;; Essential properties of the windows in the selected frame. - (loop for win in (winner-sorted-window-list) - collect (cons (winner-edges win) (window-buffer win)))) + (cl-loop for win in (winner-sorted-window-list) + collect (cons (winner-edges win) (window-buffer win)))) ;; This variable is updated with the current window configuration ;; every time it changes. @@ -240,8 +237,8 @@ You may want to include buffer names such as *Help*, *Apropos*, (let* ((miniwin (minibuffer-window)) (chosen (selected-window)) (minisize (window-height miniwin))) - (letf (((window-buffer miniwin)) - ((window-point miniwin))) + (cl-letf (((window-buffer miniwin)) + ((window-point miniwin))) (set-window-configuration winconf)) (cond ((window-live-p chosen) (select-window chosen)) @@ -262,16 +259,16 @@ You may want to include buffer names such as *Help*, *Apropos*, (defun winner-make-point-alist () (save-current-buffer - (loop with alist - for win in (winner-window-list) - for entry = - (or (assq (window-buffer win) alist) - (car (push (list (set-buffer (window-buffer win)) - (cons (mark t) (winner-active-region))) - alist))) - do (push (cons win (window-point win)) - (cddr entry)) - finally return alist))) + (cl-loop with alist + for win in (winner-window-list) + for entry = + (or (assq (window-buffer win) alist) + (car (push (list (set-buffer (window-buffer win)) + (cons (mark t) (winner-active-region))) + alist))) + do (push (cons win (window-point win)) + (cddr entry)) + finally return alist))) (defun winner-get-point (buf win) ;; Consult (and possibly extend) `winner-point-alist'. @@ -302,11 +299,11 @@ You may want to include buffer names such as *Help*, *Apropos*, (let* ((buffers nil) (alive ;; Possibly update `winner-point-alist' - (loop for buf in (mapcar 'cdr (cdr conf)) - for pos = (winner-get-point buf nil) - if (and pos (not (memq buf buffers))) - do (push buf buffers) - collect pos))) + (cl-loop for buf in (mapcar 'cdr (cdr conf)) + for pos = (winner-get-point buf nil) + if (and pos (not (memq buf buffers))) + do (push buf buffers) + collect pos))) (winner-set-conf (car conf)) (let (xwins) ; to be deleted @@ -321,11 +318,11 @@ You may want to include buffer names such as *Help*, *Apropos*, ;; Restore marks (save-current-buffer - (loop for buf in buffers - for entry = (cadr (assq buf winner-point-alist)) - do (progn (set-buffer buf) - (set-mark (car entry)) - (setf (winner-active-region) (cdr entry))))) + (cl-loop for buf in buffers + for entry = (cadr (assq buf winner-point-alist)) + do (progn (set-buffer buf) + (set-mark (car entry)) + (setf (winner-active-region) (cdr entry))))) ;; Delete windows, whose buffers are dead or boring. ;; Return t if this is still a possible configuration. (or (null xwins) @@ -422,7 +419,7 @@ In other words, \"undo\" changes in window configuration." (setq winner-pending-undo-ring (winner-ring (selected-frame))) (setq winner-undo-counter 0) (setq winner-undone-data (list (winner-win-data)))) - (incf winner-undo-counter) ; starting at 1 + (cl-incf winner-undo-counter) ; starting at 1 (when (and (winner-undo-this) (not (window-minibuffer-p (selected-window)))) (message "Winner undo (%d / %d)" @@ -433,11 +430,11 @@ In other words, \"undo\" changes in window configuration." (defun winner-undo-this () ; The heart of winner undo. - (loop + (cl-loop (cond ((>= winner-undo-counter (ring-length winner-pending-undo-ring)) (message "No further window configuration undo information") - (return nil)) + (cl-return nil)) ((and ; If possible configuration (winner-set (ring-ref winner-pending-undo-ring @@ -446,7 +443,7 @@ In other words, \"undo\" changes in window configuration." (let ((data (winner-win-data))) (and (not (member data winner-undone-data)) (push data winner-undone-data)))) - (return t)) ; .. then everything is fine. + (cl-return t)) ; .. then everything is fine. (t ;; Otherwise, discharge it (and try the next one). (ring-remove winner-pending-undo-ring winner-undo-counter))))) diff --git a/lisp/woman.el b/lisp/woman.el index 32aee3baff8..505ed4c00aa 100644 --- a/lisp/woman.el +++ b/lisp/woman.el @@ -435,7 +435,7 @@ (eval-when-compile ; to avoid compiler warnings (require 'dired) - (require 'cl) + (require 'cl-lib) (require 'apropos)) (defun woman-mapcan (fn x) @@ -3924,7 +3924,7 @@ Leave 1 blank line. Format paragraphs upto TO." (defun woman2-process-escapes (to &optional numeric) "Process remaining escape sequences up to marker TO, preserving point. Optional argument NUMERIC, if non-nil, means the argument is numeric." - (assert (and (markerp to) (marker-insertion-type to))) + (cl-assert (and (markerp to) (marker-insertion-type to))) ;; The first two cases below could be merged (maybe)! (let ((from (point))) ;; Discard zero width filler character used to hide leading dots diff --git a/test/ChangeLog b/test/ChangeLog index 1e77f972965..489298dbebe 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,11 +1,15 @@ +2012-07-11 Stefan Monnier <monnier@iro.umontreal.ca> + + * eshell.el: Use cl-lib. + 2012-07-03 Chong Yidong <cyd@gnu.org> * automated/xml-parse-tests.el (xml-parse-tests--bad-data): New. 2012-07-02 Chong Yidong <cyd@gnu.org> - * automated/xml-parse-tests.el (xml-parse-tests--data): More - testcases. + * automated/xml-parse-tests.el (xml-parse-tests--data): + More testcases. 2012-07-01 Chong Yidong <cyd@gnu.org> diff --git a/test/eshell.el b/test/eshell.el index 7acb34b6029..4d6480c81bb 100644 --- a/test/eshell.el +++ b/test/eshell.el @@ -28,7 +28,7 @@ ;;; Code: (eval-when-compile - (require 'cl) ; assert + (require 'cl-lib) (require 'eshell) (require 'esh-util)) (require 'esh-mode) @@ -267,9 +267,9 @@ (eshell-deftest banner banner-displayed "Startup banner is displayed at point-min" - (assert eshell-banner-message) + (cl-assert eshell-banner-message) (let ((msg (eval eshell-banner-message))) - (assert msg) + (cl-assert msg) (goto-char (point-min)) (looking-at msg))) |