procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

More CL cleanups and reduction of use of cl.el.

Browse source 
* 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.
This commit is contained in:
Stefan Monnier 2012-07-11 19:13:41 -04:00
parent c214e35e48
commit a464a6c73a
109 changed files with 2297 additions and 2349 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

46
lisp/ChangeLog
View file

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

12
lisp/calendar/parse-time.el
View file

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

19
lisp/emacs-lisp/cl-extra.el
View file

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

7
lisp/emacs-lisp/cl-lib.el
View file

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

109
lisp/emacs-lisp/cl-macs.el
View file

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

165
lisp/emacs-lisp/cl.el
View file

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

3
lisp/emacs-lisp/elint.el
View file

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

17
lisp/emacs-lisp/pcase.el
View file

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

8
lisp/eshell/em-banner.el
View file

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

8
lisp/eshell/em-cmpl.el
View file

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

9
lisp/eshell/em-hist.el
View file

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

6
lisp/eshell/em-ls.el
View file

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

1
lisp/eshell/em-script.el
View file

@ -24,6 +24,7 @@
;;; Code:
(require 'eshell)
(require 'esh-opt)
;;;###autoload
(progn

12
lisp/eshell/esh-cmd.el
View file

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

9
lisp/eshell/esh-ext.el
View file

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

4
lisp/eshell/esh-io.el
View file

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

15
lisp/eshell/esh-opt.el
View file

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

2
lisp/eshell/esh-var.el
View file

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

12
lisp/eshell/eshell.el
View file

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

4
lisp/hexl.el
View file

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

71
lisp/ibuf-ext.el
View file

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

25
lisp/ibuf-macs.el
View file

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

88
lisp/ibuffer.el
View file

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

15
lisp/image-dired.el
View file

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

206
lisp/mail/feedmail.el
View file

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

17
lisp/mail/footnote.el
View file

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

8
lisp/mail/mailheader.el
View file

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

75
lisp/man.el
View file

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

14
lisp/midnight.el
View file

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

33
lisp/net/browse-url.el
View file

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

4
lisp/net/eudc.el
View file

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

13
lisp/net/ldap.el
View file

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

2
lisp/net/mairix.el
View file

@ -70,8 +70,6 @@
(require 'widget)
(require 'cus-edit)
(eval-when-compile
(require 'cl))
;;; Keymappings

89
lisp/net/quickurl.el
View file

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

5
lisp/net/secrets.el
View file

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

1
lisp/net/snmp-mode.el
View file

@ -85,7 +85,6 @@
;;; Code:
(eval-when-compile
(require 'cl)
(require 'imenu) ; Need this stuff when compiling for imenu macros, etc.
(require 'tempo))

16
lisp/net/xesam.el
View file

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

5
lisp/net/zeroconf.el
View file

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

11
lisp/notifications.el
View file

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

4
lisp/novice.el
View file

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

8
lisp/nxml/nxml-mode.el
View file

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

112
lisp/play/5x5.el
View file

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

61
lisp/play/bubbles.el
View file

@ -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 .*\",$"

49
lisp/play/decipher.el
View file

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

41
lisp/play/gamegrid.el
View file

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

185
lisp/play/hanoi.el
View file

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

16
lisp/play/landmark.el
View file

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

50
lisp/play/pong.el
View file

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

29
lisp/play/snake.el
View file

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

181
lisp/play/tetris.el
View file

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

16
lisp/progmodes/compile.el
View file

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

2
lisp/progmodes/cwarn.el
View file

@ -105,8 +105,6 @@
;;{{{ Dependencies
(eval-when-compile (require 'cl))
(require 'custom)
(require 'font-lock)
(require 'cc-mode)

696
lisp/progmodes/ebrowse.el
View file

File diff suppressed because it is too large Load diff

2
lisp/progmodes/etags.el
View file

@ -26,8 +26,6 @@
;;; Code:
(eval-when-compile
(require 'cl))
(require 'ring)
(require 'button)

4
lisp/progmodes/flymake.el
View file

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

11
lisp/progmodes/gdb-mi.el
View file

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

4
lisp/progmodes/glasses.el
View file

@ -51,10 +51,6 @@
;;; Code:
(eval-when-compile
(require 'cl))
;;; User variables

28
lisp/progmodes/gud.el
View file

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

922
lisp/progmodes/js.el
View file

File diff suppressed because it is too large Load diff

1
lisp/progmodes/pascal.el
View file

@ -57,7 +57,6 @@
;;; Code:
(eval-when-compile (require 'cl))
(defgroup pascal nil
"Major mode for editing Pascal source in Emacs."

1
lisp/progmodes/perl-mode.el
View file

@ -102,7 +102,6 @@
;;; Code:
(eval-when-compile (require 'cl))
(defvar font-lock-comment-face)
(defvar font-lock-doc-face)

2
lisp/ps-samp.el
View file

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

32
lisp/server.el
View file

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

47
lisp/ses.el
View file

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

3
lisp/shell.el
View file

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

265
lisp/strokes.el
View file

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

22
lisp/tar-mode.el
View file

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

8
lisp/term.el
View file

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

2
lisp/term/ns-win.el
View file

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

2
lisp/term/tvi970.el
View file

@ -27,8 +27,6 @@
;;; Code:
(eval-when-compile (require 'cl))
(defvar tvi970-terminal-map
(let ((map (make-sparse-keymap)))

1
lisp/textmodes/css-mode.el
View file

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

14
lisp/textmodes/refill.el
View file

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

40
lisp/textmodes/sgml-mode.el
View file

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

14
lisp/textmodes/tex-mode.el
View file

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

2
lisp/textmodes/texinfo.el
View file

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

1
lisp/tree-widget.el
View file

@ -115,7 +115,6 @@
;;
;;; Code:
(eval-when-compile (require 'cl))
(require 'wid-edit)
;;; Customization

7
lisp/url/ChangeLog
View file

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

4
lisp/url/url-cookie.el
View file

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

57
lisp/url/url-dav.el
View file

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

1
lisp/url/url-expand.el
View file

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

15
lisp/url/url-file.el
View file

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

4
lisp/url/url-future.el
View file

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

13
lisp/url/url-gw.el
View file

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

172
lisp/url/url-http.el
View file

@ -24,12 +24,32 @@
;;; Code:
(eval-when-compile (require 'cl))
(defvar url-http-extra-headers)
(defvar url-http-target-url)
(defvar url-http-no-retry)
(defvar url-http-proxy)
(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-method)
(defvar url-http-no-retry)
(defvar url-http-process)
(defvar url-http-proxy)
(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)

11
lisp/url/url-methods.el
View file

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

19
lisp/url/url-misc.el
View file

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

3
lisp/url/url-nfs.el
View file

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

6
lisp/url/url-parse.el
View file

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

11
lisp/url/url-privacy.el
View file

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

8
lisp/url/url-queue.el
View file

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

1
lisp/url/url-util.el
View file

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

1
lisp/url/url.el
View file

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

5
lisp/vc/vc-annotate.el
View file

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

8
lisp/vc/vc-arch.el
View file

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

14
lisp/vc/vc-bzr.el
View file

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

4
lisp/vc/vc-cvs.el
View file

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

9
lisp/vc/vc-dir.el
View file

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

50
lisp/vc/vc-git.el
View file

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

12
lisp/vc/vc-hg.el
View file

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

7
lisp/vc/vc-hooks.el
View file

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

Some files were not shown because too many files have changed in this diff Show more