+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.
;;; 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))
(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))
(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)
(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.
"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.
;;;###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))
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)))
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)))
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)
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))
;;;###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))
(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...).
callf2
callf
letf*
- letf
+ ;; letf
rotatef
shiftf
remf
(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.
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)))
;; 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
(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)
;; (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
(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)
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))))
(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
;;; Code:
(eval-when-compile
- (require 'cl)
+ (require 'cl-lib)
(require 'esh-mode)
(require 'eshell))
;; `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)
;;; Code:
(eval-when-compile
- (require 'cl)
+ (require 'cl-lib)
(require 'eshell))
(require 'esh-util)
(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)
(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 ""))
(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)
;;; Code:
-(eval-when-compile
- (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'ring)
(require 'esh-opt)
(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
(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)
;;; Code:
(eval-when-compile
- (require 'cl)
+ (require 'cl-lib)
(require 'eshell))
(require 'esh-util)
(require 'esh-opt)
(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
(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))
;;; Code:
(require 'eshell)
+(require 'esh-opt)
;;;###autoload
(progn
(require 'esh-ext)
(eval-when-compile
- (require 'cl)
+ (require 'cl-lib)
(require 'pcomplete))
(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
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))
;; `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))
;; 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))))
(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
(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
(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
(provide 'esh-io)
(eval-when-compile
- (require 'cl)
+ (require 'cl-lib)
(require 'eshell))
(defgroup eshell-io nil
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)
(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:
;; 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)
(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
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))
(eval-when-compile
(require 'pcomplete)
(require 'esh-util)
- (require 'esh-opt)
(require 'esh-mode))
+(require 'esh-opt)
(require 'env)
(require 'ring)
;; things up.
(eval-when-compile
- (require 'cl)
+ (require 'cl-lib)
(require 'esh-util))
(require 'esh-util)
(require 'esh-mode)
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
;; 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))
(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)))))
(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))))))
;;; Code:
(require 'eldoc)
-(eval-when-compile (require 'cl)) ;For letf (default-value 'major-mode).
+(eval-when-compile (require 'cl-lib))
;;
;; vars here
(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)))
(eval-when-compile
(require 'ibuf-macs)
- (require 'cl))
+ (require 'cl-lib))
;;; Utility functions
(defun ibuffer-delete-alist (key alist)
(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)))
(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
(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)
(if (equal (car groups) group)
(setq found t
groups nil)
- (incf res)
+ (cl-incf res)
(setq groups (cdr groups))))
res)))
(cond ((not found)
(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)))
(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))
(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))
(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)))
""))
" "))))
(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
;;; 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)
(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'.
:autoload-end)))
;;;###autoload
-(defmacro* define-ibuffer-sorter (name documentation
+(cl-defmacro define-ibuffer-sorter (name documentation
(&key
description)
&rest body)
:autoload-end))
;;;###autoload
-(defmacro* define-ibuffer-op (op args
+(cl-defmacro define-ibuffer-op (op args
documentation
(&key
interactive
,(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)
,@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)
:autoload-end))
;;;###autoload
-(defmacro* define-ibuffer-filter (name documentation
+(cl-defmacro define-ibuffer-filter (name documentation
(&key
reader
description)
;;; Code:
(eval-when-compile
- (require 'cl)
+ (require 'cl-lib)
(require 'ibuf-macs)
(require 'dired))
(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."
(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)))
(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)))
(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...
(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
`(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)
(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)
(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)
;; `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
(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)))
(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)))))
(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)))
(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)
;; `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)
;;;;;; 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" "\
(require 'widget)
(eval-when-compile
- (require 'cl)
+ (require 'cl-lib)
(require 'wid-edit))
(defgroup image-dired nil
(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.
(require 'mail-utils) ; pick up mail-strip-quoted-names
(eval-when-compile
- (require 'smtpmail)
- (require 'cl))
+ (require 'smtpmail))
(autoload 'mail-do-fcc "sendmail")
(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.
(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)
(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
(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))
(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....
(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)
(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)
;;; 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."
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 ? ))
;;; 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),
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)
(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
\f
;;; Code:
-(eval-when-compile (require 'cl))
(require 'button)
;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
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
(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))
;;; Code:
-(eval-when-compile
- (require 'cl))
+(eval-when-compile (require 'cl-lib))
(defgroup midnight nil
"Run something every day at midnight."
(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.
(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
"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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Variables
-(eval-when-compile (require 'cl))
-
(defgroup browse-url nil
"Use a web browser to look at a URL."
:prefix "browse-url-"
(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)
(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"))
;;; Code:
(require 'custom)
-(eval-when-compile (require 'cl))
(autoload 'auth-source-search "auth-source")
(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)
(require 'widget)
(require 'cus-edit)
-(eval-when-compile
- (require 'cl))
;;; Keymappings
;; Things we need:
-(eval-when-compile
- (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'thingatpt)
(require 'pp)
(require 'browse-url)
(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.
;; 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)))))))
(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
(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."
(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)
(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))
;; 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)
(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))))))
;;; Code:
(eval-when-compile
- (require 'cl)
(require 'imenu) ; Need this stuff when compiling for imenu macros, etc.
(require 'tempo))
(require 'dbus)
-;; Pacify byte compiler.
-(eval-when-compile
- (require 'cl))
-
;; Widgets are used to highlight the search results.
(require 'widget)
(require 'wid-edit)
;; 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)
;; 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)
((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
;; active D-Bus session bus.
;;; Code:
-(eval-when-compile
- (require 'cl))
-
(require 'dbus)
(defconst notifications-specification-version "1.2"
(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"
;; 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")
(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
(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)
(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)))
;; Things we need.
-(eval-when-compile
- (require 'cl))
+(eval-when-compile (require 'cl-lib))
;; Customize options.
(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)
(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)
(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
(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))))
(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.
(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)
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
;; 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
"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 ()
(defconst bubbles-version "0.5" "Version number of bubbles.el.")
(require 'gamegrid)
-(eval-when-compile (require 'cl)) ; for 'case
;; User options
(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 ()
"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 .*\",$"
;;; Variables:
;;;===================================================================
-(eval-when-compile
- (require 'cl))
+(eval-when-compile (require 'cl-lib))
(defgroup decipher nil
"Cryptanalyze monoalphabetic substitution ciphers."
(let ((key ?a))
(while (<= key ?z)
(define-key map (vector key) 'decipher-keypress)
- (incf key)))
+ (cl-incf key)))
map)
"Keymap for Decipher mode.")
(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)
(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:
(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)))
(while (>= plain-char ?a)
(backward-char)
(push (cons plain-char (following-char)) decipher-alphabet)
- (decf plain-char)))))
+ (cl-decf plain-char)))))
;;;===================================================================
;;; Analyzing 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)
;; 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)))))
(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
"")
;; 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 ()
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
(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...")
;; 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)
(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)))
;; 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 " "
(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)
;;; Code:
-(eval-when-compile
- (require 'cl))
-
;; ;;;;;;;;;;;;; buffer-local variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar gamegrid-use-glyphs t
(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))))
(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)))
(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)
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))))
;;; 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."
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)))
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)))
(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)
(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)
;; 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)
;; 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
;; 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.
(/ (- 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))))
(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))
(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))
;; concise problem description.
;;;_* Require
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
;;;_* From Gomoku
(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 ()
(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)))
; 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))
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'gamegrid)
(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))
?\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 ()
(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))))))
;;; Code:
-(eval-when-compile
- (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'gamegrid)
(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)
(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)))))
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)
(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)
(= 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)
(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
;;; Code:
-(eval-when-compile
- (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'gamegrid)
(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))
(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)
(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))
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)
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'tool-bar)
(require 'comint)
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"))))
;; 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
;; 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.
(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))))
(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)))
(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)))
;;{{{ Dependencies
-(eval-when-compile (require 'cl))
-
(require 'custom)
(require 'font-lock)
(require 'cc-mode)
(require 'ebuff-menu)
(eval-when-compile
- (require 'cl)
+ (require 'cl-lib)
(require 'helper))
\f
(defmacro ebrowse-output (&rest body)
"Eval BODY with a writable current buffer.
Preserve buffer's modified state."
+ (declare (indent 0) (debug t))
(let ((modified (make-symbol "--ebrowse-output--")))
`(let (buffer-read-only (,modified (buffer-modified-p)))
(unwind-protect
(defmacro ebrowse-ignoring-completion-case (&rest body)
"Eval BODY with `completion-ignore-case' bound to t."
+ (declare (indent 0) (debug t))
`(let ((completion-ignore-case t))
,@body))
-
(defmacro ebrowse-save-selective (&rest body)
"Eval BODY with `selective-display' restored at the end."
- (let ((var (make-symbol "var")))
- `(let ((,var selective-display))
- (unwind-protect
- (progn ,@body)
- (setq selective-display ,var)))))
-
+ (declare (indent 0) (debug t))
+ ;; FIXME: Don't use selective-display.
+ `(let ((selective-display selective-display))
+ ,@body))
(defmacro ebrowse-for-all-trees (spec &rest body)
"For all trees in SPEC, eval BODY."
+ (declare (indent 1) (debug ((sexp form) body)))
(let ((var (make-symbol "var"))
(spec-var (car spec))
(array (cadr spec)))
- `(loop for ,var being the symbols of ,array
- as ,spec-var = (get ,var 'ebrowse-root) do
- (when (vectorp ,spec-var)
- ,@body))))
+ `(cl-loop for ,var being the symbols of ,array
+ as ,spec-var = (get ,var 'ebrowse-root) do
+ (when (vectorp ,spec-var)
+ ,@body))))
;;; Set indentation for macros above.
-(put 'ebrowse-output 'lisp-indent-hook 0)
-(put 'ebrowse-ignoring-completion-case 'lisp-indent-hook 0)
-(put 'ebrowse-save-selective 'lisp-indent-hook 0)
-(put 'ebrowse-for-all-trees 'lisp-indent-hook 1)
(defsubst ebrowse-set-face (start end face)
(ebrowse-ignoring-completion-case
(completing-read prompt table nil t initial-input)))
-
-(defun ebrowse-value-in-buffer (sym buffer)
- "Return the value of SYM in BUFFER."
- (let ((old-buffer (current-buffer)))
- (unwind-protect
- (progn
- (set-buffer buffer)
- (symbol-value sym))
- (set-buffer old-buffer))))
-
-
(defun ebrowse-rename-buffer (new-name)
"Rename current buffer to NEW-NAME.
If a buffer with name NEW-NAME already exists, delete it first."
Replace sequences of newlines with a single space."
(when (string-match "^[ \t\n\r]+" string)
(setq string (substring string (match-end 0))))
- (loop while (string-match "[\n]+" string)
- finally return string do
- (setq string (replace-match " " nil t string))))
+ (cl-loop while (string-match "[\n]+" string)
+ finally return string do
+ (setq string (replace-match " " nil t string))))
(defun ebrowse-width-of-drawable-area ()
\f
;;; Structure definitions
-(defstruct (ebrowse-hs (:type vector) :named)
+(cl-defstruct (ebrowse-hs (:type vector) :named)
"Header structure found at the head of BROWSE files."
;; A version string that is compared against the version number of
;; the Lisp package when the file is loaded. This is done to
member-table)
-(defstruct (ebrowse-ts (:type vector) :named)
+(cl-defstruct (ebrowse-ts (:type vector) :named)
"Tree structure.
Following the header structure, a BROWSE file contains a number
of `ebrowse-ts' structures, each one describing one root class of
mark)
-(defstruct (ebrowse-bs (:type vector) :named)
+(cl-defstruct (ebrowse-bs (:type vector) :named)
"Common sub-structure.
A common structure defining an occurrence of some name in the
source files."
point)
-(defstruct (ebrowse-cs (:include ebrowse-bs) (:type vector) :named)
+(cl-defstruct (ebrowse-cs (:include ebrowse-bs) (:type vector) :named)
"Class structure.
This is the structure stored in the CLASS slot of a `ebrowse-ts'
structure. It describes the location of the class declaration."
source-file)
-(defstruct (ebrowse-ms (:include ebrowse-bs) (:type vector) :named)
+(cl-defstruct (ebrowse-ms (:include ebrowse-bs) (:type vector) :named)
"Member structure.
This is the structure describing a single member. The `ebrowse-ts'
structure contains various lists for the different types of
(ebrowse-for-all-trees (tree ebrowse--tree-obarray)
(when (or (not marked-only) (ebrowse-ts-mark tree))
(let ((class (ebrowse-ts-class tree)))
- (when (zerop (% (incf i) 20))
+ (when (zerop (% (cl-incf i) 20))
(ebrowse-show-progress "Preparing file list" (zerop i)))
;; Add files mentioned in class description
(let ((source-file (ebrowse-cs-source-file class))
(when file
(puthash file file files))
;; For all member lists in this class
- (loop for accessor in ebrowse-member-list-accessors do
- (loop for m in (funcall accessor tree)
- for file = (ebrowse-ms-file m)
- for def-file = (ebrowse-ms-definition-file m) do
- (when file
- (puthash file file files))
- (when def-file
- (puthash def-file def-file files))))))))
+ (dolist (accessor ebrowse-member-list-accessors)
+ (cl-loop for m in (funcall accessor tree)
+ for file = (ebrowse-ms-file m)
+ for def-file = (ebrowse-ms-definition-file m) do
+ (when file
+ (puthash file file files))
+ (when def-file
+ (puthash def-file def-file files))))))))
files))
list))
-(defun* ebrowse-marked-classes-p ()
+(cl-defun ebrowse-marked-classes-p ()
"Value is non-nil if any class in the current class tree is marked."
(ebrowse-for-all-trees (tree ebrowse--tree-obarray)
(when (ebrowse-ts-mark tree)
- (return-from ebrowse-marked-classes-p tree))))
+ (cl-return-from ebrowse-marked-classes-p tree))))
(defsubst ebrowse-globals-tree-p (tree)
(if qualified-names-p
(ebrowse-for-all-trees (tree ebrowse--tree-obarray)
(setq alist
- (acons (ebrowse-qualified-class-name (ebrowse-ts-class tree))
- tree alist)))
+ (cl-acons (ebrowse-qualified-class-name
+ (ebrowse-ts-class tree))
+ tree alist)))
(ebrowse-for-all-trees (tree ebrowse--tree-obarray)
(setq alist
- (acons (ebrowse-cs-name (ebrowse-ts-class tree))
- tree alist))))
+ (cl-acons (ebrowse-cs-name (ebrowse-ts-class tree))
+ tree alist))))
alist))
computes this information lazily."
(or (ebrowse-ts-base-classes tree)
(setf (ebrowse-ts-base-classes tree)
- (loop with to-search = (list tree)
- with result = nil
- as search = (pop to-search)
- while search finally return result
- do (ebrowse-for-all-trees (ti ebrowse--tree-obarray)
- (when (memq search (ebrowse-ts-subclasses ti))
- (unless (memq ti result)
- (setq result (nconc result (list ti))))
- (push ti to-search)))))))
+ (cl-loop with to-search = (list tree)
+ with result = nil
+ as search = (pop to-search)
+ while search finally return result
+ do (ebrowse-for-all-trees (ti ebrowse--tree-obarray)
+ (when (memq search (ebrowse-ts-subclasses ti))
+ (unless (memq ti result)
+ (setq result (nconc result (list ti))))
+ (push ti to-search)))))))
(defun ebrowse-direct-base-classes (tree)
ACCESSOR is the accessor function for the member list.
Elements of the result have the form (NAME . ACCESSOR), where NAME
is the member name."
- (loop for member in (funcall accessor tree)
- collect (cons (ebrowse-ms-name member) accessor)))
+ (cl-loop for member in (funcall accessor tree)
+ collect (cons (ebrowse-ms-name member) accessor)))
(defun ebrowse-name/accessor-alist-for-visible-members ()
ebrowse--accessor)))
(if ebrowse--show-inherited-flag
(nconc list
- (loop for tree in (ebrowse-base-classes
- ebrowse--displayed-class)
- nconc (ebrowse-name/accessor-alist
- tree ebrowse--accessor)))
+ (cl-loop for tree in (ebrowse-base-classes
+ ebrowse--displayed-class)
+ nconc (ebrowse-name/accessor-alist
+ tree ebrowse--accessor)))
list)))
See that variable's documentation for the meaning of IGNORE-AUTO-SAVE and
NOCONFIRM."
(when (or noconfirm (yes-or-no-p "Revert tree from disk? "))
- (loop for member-buffer in (ebrowse-same-tree-member-buffer-list)
- do (kill-buffer member-buffer))
+ (mapc #'kill-buffer (ebrowse-same-tree-member-buffer-list))
(erase-buffer)
(with-no-warnings
(insert-file (or buffer-file-name ebrowse--tags-file-name)))
ebrowse--frozen-flag nil)
(ebrowse-redraw-tree)
(set-buffer-modified-p nil)
- (case pop
- (switch (switch-to-buffer name))
- (pop (pop-to-buffer name)))
+ (pcase pop
+ (`switch (switch-to-buffer name))
+ (`pop (pop-to-buffer name)))
(current-buffer)))
(garbage-collect)
;; For all classes...
(ebrowse-for-all-trees (c ebrowse--tree-obarray)
- (when (zerop (% (incf i) 10))
+ (when (zerop (% (cl-incf i) 10))
(ebrowse-show-progress "Preparing member lookup" (zerop i)))
- (loop for f in ebrowse-member-list-accessors do
- (loop for m in (funcall f c) do
- (let* ((member-name (ebrowse-ms-name m))
- (value (gethash member-name members)))
- (push (list c f m) value)
- (puthash member-name value members)))))
+ (dolist (f ebrowse-member-list-accessors)
+ (dolist (m (funcall f c))
+ (let* ((member-name (ebrowse-ms-name m))
+ (value (gethash member-name members)))
+ (push (list c f m) value)
+ (puthash member-name value members)))))
(setf (ebrowse-hs-member-table ebrowse--header) members)))
"Return the member obarray. Build it if it hasn't been set up yet.
HEADER is the tree header structure of the class tree."
(when (null (ebrowse-hs-member-table header))
- (loop for buffer in (ebrowse-browser-buffer-list)
- until (eq header (ebrowse-value-in-buffer 'ebrowse--header buffer))
- finally do
- (with-current-buffer buffer
- (ebrowse-fill-member-table))))
+ (cl-loop for buffer in (ebrowse-browser-buffer-list)
+ until (eq header (buffer-local-value 'ebrowse--header buffer))
+ finally do
+ (with-current-buffer buffer
+ (ebrowse-fill-member-table))))
(ebrowse-hs-member-table header))
Build obarray of all classes in TREE."
(let ((classes (make-vector 127 0)))
;; Add root classes...
- (loop for root in tree
- as sym =
- (intern (ebrowse-qualified-class-name (ebrowse-ts-class root)) classes)
- do (unless (get sym 'ebrowse-root)
- (setf (get sym 'ebrowse-root) root)))
+ (cl-loop for root in tree
+ as sym =
+ (intern (ebrowse-qualified-class-name (ebrowse-ts-class root))
+ classes)
+ do (unless (get sym 'ebrowse-root)
+ (setf (get sym 'ebrowse-root) root)))
;; Process subclasses
(ebrowse-insert-supers tree classes)
classes))
We have to be cautious here not to end up in an infinite recursion
if for some reason a circle is in the inheritance graph."
- (loop for class in tree
- as subclasses = (ebrowse-ts-subclasses class) do
- ;; Make sure every class is represented by a unique object
- (loop for subclass on subclasses
- as sym = (intern
- (ebrowse-qualified-class-name (ebrowse-ts-class (car subclass)))
- classes)
- as next = nil
- do
- ;; Replace the subclass tree with the one found in
- ;; CLASSES if there is already an entry for that class
- ;; in it. Otherwise make a new entry.
- ;;
- ;; CAVEAT: If by some means (e.g., use of the
- ;; preprocessor in class declarations, a name is marked
- ;; as a subclass of itself on some path, we would end up
- ;; in an endless loop. We have to omit subclasses from
- ;; the recursion that already have been processed.
- (if (get sym 'ebrowse-root)
- (setf (car subclass) (get sym 'ebrowse-root))
- (setf (get sym 'ebrowse-root) (car subclass))))
- ;; Process subclasses
- (ebrowse-insert-supers subclasses classes)))
+ (cl-loop for class in tree
+ as subclasses = (ebrowse-ts-subclasses class) do
+ ;; Make sure every class is represented by a unique object
+ (cl-loop for subclass on subclasses
+ as sym = (intern
+ (ebrowse-qualified-class-name
+ (ebrowse-ts-class (car subclass)))
+ classes)
+ as next = nil
+ do
+ ;; Replace the subclass tree with the one found in
+ ;; CLASSES if there is already an entry for that class
+ ;; in it. Otherwise make a new entry.
+ ;;
+ ;; CAVEAT: If by some means (e.g., use of the
+ ;; preprocessor in class declarations, a name is marked
+ ;; as a subclass of itself on some path, we would end up
+ ;; in an endless loop. We have to omit subclasses from
+ ;; the recursion that already have been processed.
+ (if (get sym 'ebrowse-root)
+ (setf (car subclass) (get sym 'ebrowse-root))
+ (setf (get sym 'ebrowse-root) (car subclass))))
+ ;; Process subclasses
+ (ebrowse-insert-supers subclasses classes)))
\f
;;; Tree buffers
(unless (zerop (buffer-size))
(goto-char (point-min))
- (multiple-value-setq (header tree) (values-list (ebrowse-read)))
+ (cl-multiple-value-setq (header tree) (cl-values-list (ebrowse-read)))
(message "Sorting. Please be patient...")
(setq tree (ebrowse-sort-tree-list tree))
(erase-buffer)
;; Get the classes whose mark must be toggled. Note that
;; ebrowse-tree-at-point might issue an error.
(ignore-errors
- (loop repeat (or n-times 1)
- as tree = (ebrowse-tree-at-point)
- do (progn
- (setf (ebrowse-ts-mark tree) (not (ebrowse-ts-mark tree)))
- (forward-line 1)
- (push tree to-change))))
+ (cl-loop repeat (or n-times 1)
+ as tree = (ebrowse-tree-at-point)
+ do (progn
+ (setf (ebrowse-ts-mark tree) (not (ebrowse-ts-mark tree)))
+ (forward-line 1)
+ (push tree to-change))))
(save-excursion
;; For all these classes, reverse the mark char in the display
;; by a regexp replace over the whole buffer. The reason for this
;; is that classes might have multiple base classes. If this is
;; the case, they are displayed more than once in the tree.
(ebrowse-output
- (loop for tree in to-change
- as regexp = (concat "^.*\\b"
- (regexp-quote
- (ebrowse-cs-name (ebrowse-ts-class tree)))
- "\\b")
- do
- (goto-char (point-min))
- (loop while (re-search-forward regexp nil t)
- do (progn
- (goto-char (match-beginning 0))
- (delete-char 1)
- (insert-char (if (ebrowse-ts-mark tree) ?> ? ) 1)
- (ebrowse-set-mark-props (1- (point)) (point) tree)
- (goto-char (match-end 0)))))))))
+ (cl-loop
+ for tree in to-change
+ as regexp = (concat "^.*\\b"
+ (regexp-quote
+ (ebrowse-cs-name (ebrowse-ts-class tree)))
+ "\\b")
+ do
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (goto-char (match-beginning 0))
+ (delete-char 1)
+ (insert-char (if (ebrowse-ts-mark tree) ?> ? ) 1)
+ (ebrowse-set-mark-props (1- (point)) (point) tree)
+ (goto-char (match-end 0))))))))
(defun ebrowse-mark-all-classes (prefix)
(set (make-hash-table))
result)
(dolist (buffer buffers)
- (let ((tree (ebrowse-value-in-buffer 'ebrowse--tree buffer)))
+ (let ((tree (buffer-local-value 'ebrowse--tree buffer)))
(unless (gethash tree set)
(push buffer result))
(puthash tree t set)))
"Return a list of members buffers with same tree as current buffer."
(ebrowse-delete-if-not
(lambda (buffer)
- (eq (ebrowse-value-in-buffer 'ebrowse--tree buffer)
+ (eq (buffer-local-value 'ebrowse--tree buffer)
ebrowse--tree))
(ebrowse-member-buffer-list)))
Switch to buffer if prefix ARG.
If no member buffer exists, make one."
(interactive "P")
- (let ((buf (or (first (ebrowse-same-tree-member-buffer-list))
+ (let ((buf (or (cl-first (ebrowse-same-tree-member-buffer-list))
(get-buffer ebrowse-member-buffer-name)
(ebrowse-tree-command:show-member-functions))))
(when buf
(defun ebrowse-kill-member-buffers-displaying (tree)
"Kill all member buffers displaying TREE."
- (loop for buffer in (ebrowse-member-buffer-list)
- as class = (ebrowse-value-in-buffer 'ebrowse--displayed-class buffer)
- when (eq class tree) do (kill-buffer buffer)))
+ (cl-loop for buffer in (ebrowse-member-buffer-list)
+ as class = (buffer-local-value 'ebrowse--displayed-class buffer)
+ when (eq class tree) do (kill-buffer buffer)))
(defun ebrowse-frozen-tree-buffer-name (tags-file)
(int-to-string ebrowse--indentation)
"): ")
nil nil ebrowse--indentation))))
- (when (plusp width)
+ (when (cl-plusp width)
(set (make-local-variable 'ebrowse--indentation) width)
(ebrowse-redraw-tree))))
(error "Not on a class")))
-(defun* ebrowse-view/find-class-declaration (&key view where)
+(cl-defun ebrowse-view/find-class-declaration (&key view where)
"View or find the declarator of the class point is on.
VIEW non-nil means view it. WHERE is additional position info."
(let* ((class (ebrowse-ts-class (ebrowse-tree-at-point)))
exit-action ebrowse--view-exit-action))
;; Delete the frame in which we viewed.
(mapc 'delete-frame
- (loop for frame in (frame-list)
- when (not (assq frame original-frame-configuration))
- collect frame))
+ (cl-loop for frame in (frame-list)
+ when (not (assq frame original-frame-configuration))
+ collect frame))
(when exit-action
(funcall exit-action buffer))))
(unless (boundp 'view-mode-hook)
(setq view-mode-hook nil))
(push 'ebrowse-find-pattern view-mode-hook)
- (case where
- (other-window (view-file-other-window file))
- (other-frame (ebrowse-view-file-other-frame file))
- (t (view-file file))))
+ (pcase where
+ (`other-window (view-file-other-window file))
+ (`other-frame (ebrowse-view-file-other-frame file))
+ (_ (view-file file))))
(t
- (case where
- (other-window (find-file-other-window file))
- (other-frame (find-file-other-frame file))
- (t (find-file file)))
+ (pcase where
+ (`other-window (find-file-other-window file))
+ (`other-frame (find-file-other-frame file))
+ (_ (find-file file)))
(ebrowse-find-pattern struc info))))
which may contain whitespace. For these symbols, replace white
space in the symbol name (generated by BROWSE) with a regular
expression matching any number of whitespace characters."
- (loop with regexp = (regexp-quote name)
- with start = 0
- finally return regexp
- while (string-match "[ \t]+" regexp start)
- do (setq regexp (concat (substring regexp 0 (match-beginning 0))
- "[ \t]*"
- (substring regexp (match-end 0)))
- start (+ (match-beginning 0) 5))))
+ (cl-loop with regexp = (regexp-quote name)
+ with start = 0
+ finally return regexp
+ while (string-match "[ \t]+" regexp start)
+ do (setq regexp (concat (substring regexp 0 (match-beginning 0))
+ "[ \t]*"
+ (substring regexp (match-end 0)))
+ start (+ (match-beginning 0) 5))))
(defun ebrowse-class-declaration-regexp (name)
(concat "^[ \t]*#[ \t]*define[ \t]+" (regexp-quote name)))
-(defun* ebrowse-find-pattern (&optional position info &aux viewing)
+(cl-defun ebrowse-find-pattern (&optional position info &aux viewing)
"Find a pattern.
This is a kluge: Ebrowse allows you to find or view a file containing
(start (ebrowse-bs-point position))
(offset 100)
found)
- (destructuring-bind (header class-or-member member-list) info
+ (pcase-let ((`(,header ,class-or-member ,member-list) info))
;; If no pattern is specified, construct one from the member name.
(when (stringp pattern)
(setq pattern (concat "^.*" (regexp-quote pattern))))
;; Construct a regular expression if none given.
(unless pattern
- (typecase class-or-member
+ (cl-typecase class-or-member
(ebrowse-ms
- (case member-list
- ((ebrowse-ts-member-variables
- ebrowse-ts-static-variables
- ebrowse-ts-types)
- (setf pattern (ebrowse-variable-declaration-regexp
- (ebrowse-bs-name position))))
- (otherwise
- (if (ebrowse-define-p class-or-member)
- (setf pattern (ebrowse-pp-define-regexp (ebrowse-bs-name position)))
- (setf pattern (ebrowse-function-declaration/definition-regexp
- (ebrowse-bs-name position)))))))
+ (setf pattern
+ (pcase member-list
+ ((or `ebrowse-ts-member-variables
+ `ebrowse-ts-static-variables
+ `ebrowse-ts-types)
+ (ebrowse-variable-declaration-regexp
+ (ebrowse-bs-name position)))
+ (_
+ (if (ebrowse-define-p class-or-member)
+ (ebrowse-pp-define-regexp (ebrowse-bs-name position))
+ (ebrowse-function-declaration/definition-regexp
+ (ebrowse-bs-name position)))))))
(ebrowse-cs
(setf pattern (ebrowse-class-declaration-regexp
(ebrowse-bs-name position))))))
(y-or-n-p (format "start = %d? " start))
(y-or-n-p pattern))
(setf found
- (loop do (goto-char (max (point-min) (- start offset)))
- when (re-search-forward pattern (+ start offset) t) return t
- never (bobp)
- do (incf offset offset)))
+ (cl-loop do (goto-char (max (point-min) (- start offset)))
+ when (re-search-forward pattern (+ start offset) t)
+ return t
+ never (bobp)
+ do (cl-incf offset offset)))
(cond (found
(beginning-of-line)
(run-hooks 'ebrowse-view/find-hook))
(ebrowse-set-face start end 'ebrowse-tree-mark))
-(defun* ebrowse-draw-tree-fn (&aux stack1 stack2 start)
+(cl-defun ebrowse-draw-tree-fn (&aux stack1 stack2 start)
"Display a single class and recursively its subclasses.
This function may look weird, but this is faster than recursion."
(setq stack1 (make-list (length ebrowse--tree) 0)
stack2 (copy-sequence ebrowse--tree))
- (loop while stack2
- as level = (pop stack1)
- as tree = (pop stack2)
- as class = (ebrowse-ts-class tree) do
- (let ((start-of-line (point))
- start-of-class-name end-of-class-name)
- ;; Insert mark
- (insert (if (ebrowse-ts-mark tree) ">" " "))
-
- ;; Indent and insert class name
- (indent-to (+ (* level ebrowse--indentation)
- ebrowse-tree-left-margin))
- (setq start (point))
- (insert (ebrowse-qualified-class-name class))
-
- ;; If template class, add <>
- (when (ebrowse-template-p class)
- (insert "<>"))
- (ebrowse-set-face start (point) (if (zerop level)
- 'ebrowse-root-class
- 'ebrowse-default))
- (setf start-of-class-name start
- end-of-class-name (point))
- ;; If filenames are to be displayed...
- (when ebrowse--show-file-names-flag
- (indent-to ebrowse-source-file-column)
- (setq start (point))
- (insert "("
- (or (ebrowse-cs-file class)
- "unknown")
- ")")
- (ebrowse-set-face start (point) 'ebrowse-file-name))
- (ebrowse-set-mark-props start-of-line (1+ start-of-line) tree)
- (add-text-properties
- start-of-class-name end-of-class-name
- `(mouse-face highlight ebrowse-what class-name
- ebrowse-tree ,tree
- help-echo "double-mouse-1: (un)expand tree; mouse-2: member functions, mouse-3: menu"))
- (insert "\n"))
- ;; Push subclasses, if any.
- (when (ebrowse-ts-subclasses tree)
- (setq stack2
- (nconc (copy-sequence (ebrowse-ts-subclasses tree)) stack2)
- stack1
- (nconc (make-list (length (ebrowse-ts-subclasses tree))
- (1+ level)) stack1)))))
+ (cl-loop while stack2
+ as level = (pop stack1)
+ as tree = (pop stack2)
+ as class = (ebrowse-ts-class tree) do
+ (let ((start-of-line (point))
+ start-of-class-name end-of-class-name)
+ ;; Insert mark
+ (insert (if (ebrowse-ts-mark tree) ">" " "))
+
+ ;; Indent and insert class name
+ (indent-to (+ (* level ebrowse--indentation)
+ ebrowse-tree-left-margin))
+ (setq start (point))
+ (insert (ebrowse-qualified-class-name class))
+
+ ;; If template class, add <>
+ (when (ebrowse-template-p class)
+ (insert "<>"))
+ (ebrowse-set-face start (point) (if (zerop level)
+ 'ebrowse-root-class
+ 'ebrowse-default))
+ (setf start-of-class-name start
+ end-of-class-name (point))
+ ;; If filenames are to be displayed...
+ (when ebrowse--show-file-names-flag
+ (indent-to ebrowse-source-file-column)
+ (setq start (point))
+ (insert "("
+ (or (ebrowse-cs-file class)
+ "unknown")
+ ")")
+ (ebrowse-set-face start (point) 'ebrowse-file-name))
+ (ebrowse-set-mark-props start-of-line (1+ start-of-line) tree)
+ (add-text-properties
+ start-of-class-name end-of-class-name
+ `(mouse-face highlight ebrowse-what class-name
+ ebrowse-tree ,tree
+ help-echo "double-mouse-1: (un)expand tree; mouse-2: member functions, mouse-3: menu"))
+ (insert "\n"))
+ ;; Push subclasses, if any.
+ (when (ebrowse-ts-subclasses tree)
+ (setq stack2
+ (nconc (copy-sequence (ebrowse-ts-subclasses tree)) stack2)
+ stack1
+ (nconc (make-list (length (ebrowse-ts-subclasses tree))
+ (1+ level)) stack1)))))
\f
"Read a browser buffer name from the minibuffer and return that buffer."
(let* ((buffers (ebrowse-known-class-trees-buffer-list)))
(if buffers
- (if (not (second buffers))
- (first buffers)
+ (if (not (cl-second buffers))
+ (cl-first buffers)
(or (ebrowse-electric-choose-tree) (error "No tree buffer")))
(let* ((insert-default-directory t)
(file (read-file-name "Find tree: " nil nil t)))
ebrowse--decl-column
ebrowse--column-width))
"): ")))))
- (when (plusp width)
+ (when (cl-plusp width)
(if ebrowse--long-display-flag
(setq ebrowse--decl-column width)
(setq ebrowse--column-width width))
(let ((index (ebrowse-position ebrowse--accessor
ebrowse-member-list-accessors)))
(setf ebrowse--accessor
- (cond ((plusp incr)
+ (cond ((cl-plusp incr)
(or (nth (1+ index)
ebrowse-member-list-accessors)
- (first ebrowse-member-list-accessors)))
- ((minusp incr)
- (or (and (>= (decf index) 0)
+ (cl-first ebrowse-member-list-accessors)))
+ ((cl-minusp incr)
+ (or (and (>= (cl-decf index) 0)
(nth index
ebrowse-member-list-accessors))
- (first (last ebrowse-member-list-accessors))))))
+ (cl-first (last ebrowse-member-list-accessors))))))
(ebrowse-display-member-list-for-accessor ebrowse--accessor)))
(ebrowse-view/find-member-declaration/definition prefix t))
-(defun* ebrowse-view/find-member-declaration/definition
+(cl-defun ebrowse-view/find-member-declaration/definition
(prefix view &optional definition info header tags-file)
"Find or view a member declaration or definition.
With PREFIX 4. find file in another window, with prefix 5
;; If not given as parameters, get the necessary information
;; out of the member buffer.
(if info
- (setq tree (first info)
- accessor (second info)
- member (third info))
- (multiple-value-setq (tree member on-class)
- (values-list (ebrowse-member-info-from-point)))
+ (setq tree (cl-first info)
+ accessor (cl-second info)
+ member (cl-third info))
+ (cl-multiple-value-setq (tree member on-class)
+ (cl-values-list (ebrowse-member-info-from-point)))
(setq accessor ebrowse--accessor))
;; View/find class if on a line containing a class name.
(when on-class
- (return-from ebrowse-view/find-member-declaration/definition
+ (cl-return-from ebrowse-view/find-member-declaration/definition
(ebrowse-view/find-file-and-search-pattern
(ebrowse-ts-class tree)
(list ebrowse--header (ebrowse-ts-class tree) nil)
mouse-face highlight
ebrowse-tree ,tree
help-echo "mouse-2: view definition; mouse-3: menu"))
- (incf i)
+ (cl-incf i)
(when (>= i ebrowse--n-columns)
(setf i 0)
(insert "\n")))))
- (when (plusp i)
+ (when (cl-plusp i)
(insert "\n"))
(goto-char (point-min))))
(error "Not found"))))
-(defun* ebrowse-move-point-to-member (name &optional count &aux member)
+(cl-defun ebrowse-move-point-to-member (name &optional count &aux member)
"Set point on member NAME in the member buffer
COUNT, if specified, says search the COUNT'th member with the same name."
(goto-char (point-min))
"Switch member buffer to a class read from the minibuffer.
Use TITLE as minibuffer prompt.
COMPL-LIST is a completion list to use."
- (let* ((initial (unless (second compl-list)
- (first (first compl-list))))
+ (let* ((initial (unless (cl-second compl-list)
+ (cl-first (cl-first compl-list))))
(class (or (ebrowse-completing-read-value title compl-list initial)
(error "Not found"))))
(setf ebrowse--displayed-class class
(interactive "P")
(let ((supers (or (ebrowse-direct-base-classes ebrowse--displayed-class)
(error "No base classes"))))
- (if (and arg (second supers))
- (let ((alist (loop for s in supers
- collect (cons (ebrowse-qualified-class-name
- (ebrowse-ts-class s))
- s))))
+ (if (and arg (cl-second supers))
+ (let ((alist (cl-loop for s in supers
+ collect (cons (ebrowse-qualified-class-name
+ (ebrowse-ts-class s))
+ s))))
(ebrowse-switch-member-buffer-to-other-class
"Goto base class: " alist))
- (setq ebrowse--displayed-class (first supers)
+ (setq ebrowse--displayed-class (cl-first supers)
ebrowse--member-list
(funcall ebrowse--accessor ebrowse--displayed-class))
(ebrowse-redisplay-member-buffer))))
index cls
(supers (ebrowse-direct-base-classes ebrowse--displayed-class)))
(cl-flet ((trees-alist (trees)
- (loop for tr in trees
- collect (cons (ebrowse-cs-name
- (ebrowse-ts-class tr)) tr))))
+ (cl-loop for tr in trees
+ collect (cons (ebrowse-cs-name
+ (ebrowse-ts-class tr))
+ tr))))
(when supers
- (let ((tree (if (second supers)
+ (let ((tree (if (cl-second supers)
(ebrowse-completing-read-value
"Relative to base class: "
(trees-alist supers) nil)
- (first supers))))
+ (cl-first supers))))
(unless tree (error "Not found"))
(setq containing-list (ebrowse-ts-subclasses tree)))))
(setq index (+ inc (ebrowse-position ebrowse--displayed-class
containing-list)))
- (cond ((minusp index) (message "No previous class"))
+ (cond ((cl-minusp index) (message "No previous class"))
((null (nth index containing-list)) (message "No next class")))
(setq index (max 0 (min index (1- (length containing-list)))))
(setq cls (nth index containing-list))
the first derived class."
(interactive "P")
(cl-flet ((ebrowse-tree-obarray-as-alist ()
- (loop for s in (ebrowse-ts-subclasses
- ebrowse--displayed-class)
- collect (cons (ebrowse-cs-name
- (ebrowse-ts-class s)) s))))
+ (cl-loop for s in (ebrowse-ts-subclasses
+ ebrowse--displayed-class)
+ collect (cons (ebrowse-cs-name
+ (ebrowse-ts-class s)) s))))
(let ((subs (or (ebrowse-ts-subclasses ebrowse--displayed-class)
(error "No derived classes"))))
- (if (and arg (second subs))
+ (if (and arg (cl-second subs))
(ebrowse-switch-member-buffer-to-other-class
"Goto derived class: " (ebrowse-tree-obarray-as-alist))
- (setq ebrowse--displayed-class (first subs)
+ (setq ebrowse--displayed-class (cl-first subs)
ebrowse--member-list
(funcall ebrowse--accessor ebrowse--displayed-class))
(ebrowse-redisplay-member-buffer)))))
EVENT is the mouse event."
(interactive "e")
(mouse-set-point event)
- (case (event-click-count event)
+ (pcase (event-click-count event)
(2 (ebrowse-find-member-definition))
- (1 (case (get-text-property (posn-point (event-start event))
- 'ebrowse-what)
- (member-name
+ (1 (pcase (get-text-property (posn-point (event-start event))
+ 'ebrowse-what)
+ (`member-name
(ebrowse-popup-menu ebrowse-member-name-object-menu event))
- (class-name
+ (`class-name
(ebrowse-popup-menu ebrowse-member-class-name-object-menu event))
- (t
+ (_
(ebrowse-popup-menu ebrowse-member-buffer-object-menu event))))))
EVENT is the mouse event."
(interactive "e")
(mouse-set-point event)
- (case (event-click-count event)
+ (pcase (event-click-count event)
(2 (ebrowse-find-member-definition))
- (1 (case (get-text-property (posn-point (event-start event))
+ (1 (pcase (get-text-property (posn-point (event-start event))
'ebrowse-what)
- (member-name
+ (`member-name
(ebrowse-view-member-definition 0))))))
alist)
(when name
(dolist (info (gethash name table) alist)
- (unless (memq (first info) known-classes)
- (setf alist (acons (ebrowse-qualified-class-name
- (ebrowse-ts-class (first info)))
- info alist)
- known-classes (cons (first info) known-classes)))))))
+ (unless (memq (cl-first info) known-classes)
+ (setf alist (cl-acons (ebrowse-qualified-class-name
+ (ebrowse-ts-class (cl-first info)))
+ info alist)
+ known-classes (cons (cl-first info) known-classes)))))))
(defun ebrowse-choose-tree ()
the class tree, HEADER the header structure of the tree, and BUFFER
being the tree or member buffer containing the tree."
(let* ((buffer (ebrowse-choose-from-browser-buffers)))
- (if buffer (list (ebrowse-value-in-buffer 'ebrowse--tree buffer)
- (ebrowse-value-in-buffer 'ebrowse--header buffer)
+ (if buffer (list (buffer-local-value 'ebrowse--tree buffer)
+ (buffer-local-value 'ebrowse--header buffer)
buffer))))
from point as default. Value is a list (CLASS-NAME MEMBER-NAME)."
(save-excursion
(let ((members (ebrowse-member-table header)))
- (multiple-value-bind (class-name member-name)
- (values-list (ebrowse-tags-read-member+class-name))
+ (cl-multiple-value-bind (class-name member-name)
+ (cl-values-list (ebrowse-tags-read-member+class-name))
(unless member-name
(error "No member name at point"))
(if members
(unless (gethash name members)
(if (y-or-n-p "No exact match found. Try substrings? ")
(setq name
- (or (first (ebrowse-list-of-matching-members
+ (or (cl-first (ebrowse-list-of-matching-members
members (regexp-quote name) name))
(error "Sorry, nothing found")))
(error "Canceled")))
(let ((alist (or (ebrowse-class-alist-for-member header name)
(error "No classes with member `%s' found" name))))
(ebrowse-ignoring-completion-case
- (if (null (second alist))
- (cdr (first alist))
+ (if (null (cl-second alist))
+ (cdr (cl-first alist))
(push ?\? unread-command-events)
(cdr (assoc (completing-read "In class: "
alist nil t initial-class-name)
alist))))))
-(defun* ebrowse-tags-view/find-member-decl/defn
+(cl-defun ebrowse-tags-view/find-member-decl/defn
(prefix &key view definition member-name)
"If VIEW is t, view, else find an occurrence of MEMBER-NAME.
the user choose the class to use. As a last step, a tags search
is performed that positions point on the member declaration or
definition."
- (multiple-value-bind
- (tree header tree-buffer) (values-list (ebrowse-choose-tree))
+ (cl-multiple-value-bind
+ (tree header tree-buffer) (cl-values-list (ebrowse-choose-tree))
(unless tree (error "No class tree"))
(let* ((marker (point-marker))
class-name
(name member-name)
info)
(unless name
- (multiple-value-setq (class-name name)
- (values-list
+ (cl-multiple-value-setq (class-name name)
+ (cl-values-list
(ebrowse-tags-read-name
header
(concat (if view "View" "Find") " member "
(ebrowse-view/find-member-declaration/definition
prefix view definition info
header
- (ebrowse-value-in-buffer 'ebrowse--tags-file-name tree-buffer))
+ (buffer-local-value 'ebrowse--tags-file-name tree-buffer))
;; Record position jumped to
(ebrowse-push-position (point-marker) info t))))
(cond ((null buffer)
(set-buffer tree-buffer)
(switch-to-buffer (ebrowse-display-member-buffer
- (second info) nil (first info))))
+ (cl-second info) nil (cl-first info))))
(t
(switch-to-buffer buffer)
- (setq ebrowse--displayed-class (first info)
- ebrowse--accessor (second info)
+ (setq ebrowse--displayed-class (cl-first info)
+ ebrowse--accessor (cl-second info)
ebrowse--member-list (funcall ebrowse--accessor ebrowse--displayed-class))
(ebrowse-redisplay-member-buffer)))
- (ebrowse-move-point-to-member (ebrowse-ms-name (third info)))))
+ (ebrowse-move-point-to-member (ebrowse-ms-name (cl-third info)))))
(defun ebrowse-tags-display-member-buffer (&optional fix-name)
FIX-NAME non-nil means display the buffer for that member.
Otherwise read a member name from point."
(interactive)
- (multiple-value-bind
- (tree header tree-buffer) (values-list (ebrowse-choose-tree))
+ (cl-multiple-value-bind
+ (tree header tree-buffer) (cl-values-list (ebrowse-choose-tree))
(unless tree (error "No class tree"))
(let* ((marker (point-marker)) class-name (name fix-name) info)
(unless name
- (multiple-value-setq (class-name name)
- (values-list
+ (cl-multiple-value-setq (class-name name)
+ (cl-values-list
(ebrowse-tags-read-name header
(concat "Find member list of: ")))))
(setq info (ebrowse-tags-choose-class tree header name class-name))
(interactive)
(let* ((buffer (or (ebrowse-choose-from-browser-buffers)
(error "No tree buffer")))
- (header (ebrowse-value-in-buffer 'ebrowse--header buffer))
+ (header (buffer-local-value 'ebrowse--header buffer))
(members (ebrowse-member-table header))
temp-buffer-setup-hook
(regexp (read-from-minibuffer "List members matching regexp: ")))
(set-buffer standard-output)
(erase-buffer)
(insert "Members matching `" regexp "'\n\n")
- (loop for s in (ebrowse-list-of-matching-members members regexp) do
- (loop for info in (gethash s members) do
- (ebrowse-draw-file-member-info info))))))
+ (cl-loop for s in (ebrowse-list-of-matching-members members regexp) do
+ (cl-loop for info in (gethash s members) do
+ (ebrowse-draw-file-member-info info))))))
(defun ebrowse-tags-list-members-in-file ()
(error "No tree buffer")))
(files (with-current-buffer buffer (ebrowse-files-table)))
(file (completing-read "List members in file: " files nil t))
- (header (ebrowse-value-in-buffer 'ebrowse--header buffer))
+ (header (buffer-local-value 'ebrowse--header buffer))
temp-buffer-setup-hook
(members (ebrowse-member-table header)))
(with-output-to-temp-buffer (concat "*Members in file " file "*")
(set-buffer standard-output)
(maphash
(lambda (_member-name list)
- (loop for info in list
- as member = (third info)
- as class = (ebrowse-ts-class (first info))
- when (or (and (null (ebrowse-ms-file member))
- (string= (ebrowse-cs-file class) file))
- (string= file (ebrowse-ms-file member)))
- do (ebrowse-draw-file-member-info info "decl.")
- when (or (and (null (ebrowse-ms-definition-file member))
- (string= (ebrowse-cs-source-file class) file))
- (string= file (ebrowse-ms-definition-file member)))
- do (ebrowse-draw-file-member-info info "defn.")))
+ (cl-loop for info in list
+ as member = (cl-third info)
+ as class = (ebrowse-ts-class (cl-first info))
+ when (or (and (null (ebrowse-ms-file member))
+ (string= (ebrowse-cs-file class) file))
+ (string= file (ebrowse-ms-file member)))
+ do (ebrowse-draw-file-member-info info "decl.")
+ when (or (and (null (ebrowse-ms-definition-file member))
+ (string= (ebrowse-cs-source-file class) file))
+ (string= file (ebrowse-ms-definition-file member)))
+ do (ebrowse-draw-file-member-info info "defn.")))
members))))
-(defun* ebrowse-draw-file-member-info (info &optional (kind ""))
+(cl-defun ebrowse-draw-file-member-info (info &optional (kind ""))
"Display a line in the members info buffer.
INFO describes the member. It has the form (TREE ACCESSOR MEMBER).
TREE is the class of the member to display.
ACCESSOR is the accessor symbol of its member list.
MEMBER is the member structure.
KIND is an additional string printed in the buffer."
- (let* ((tree (first info))
+ (let* ((tree (cl-first info))
(globals-p (ebrowse-globals-tree-p tree)))
(unless globals-p
(insert (ebrowse-cs-name (ebrowse-ts-class tree))))
- (insert "::" (ebrowse-ms-name (third info)))
+ (insert "::" (ebrowse-ms-name (cl-third info)))
(indent-to 40)
(insert kind)
(indent-to 50)
- (insert (case (second info)
- (ebrowse-ts-member-functions "member function")
- (ebrowse-ts-member-variables "member variable")
- (ebrowse-ts-static-functions "static function")
- (ebrowse-ts-static-variables "static variable")
- (ebrowse-ts-friends (if globals-p "define" "friend"))
- (ebrowse-ts-types "type")
- (t "unknown"))
+ (insert (pcase (cl-second info)
+ (`ebrowse-ts-member-functions "member function")
+ (`ebrowse-ts-member-variables "member variable")
+ (`ebrowse-ts-static-functions "static function")
+ (`ebrowse-ts-static-variables "static variable")
+ (`ebrowse-ts-friends (if globals-p "define" "friend"))
+ (`ebrowse-ts-types "type")
+ (_ "unknown"))
"\n")))
(defvar ebrowse-last-completion nil
If there's only one tree loaded, use that. Otherwise let the
use choose a tree."
(let* ((buffers (ebrowse-known-class-trees-buffer-list))
- (buffer (cond ((and (first buffers) (not (second buffers)))
- (first buffers))
+ (buffer (cond ((and (cl-first buffers) (not (cl-second buffers)))
+ (cl-first buffers))
(t (or (ebrowse-electric-choose-tree)
(error "No tree buffer")))))
- (header (ebrowse-value-in-buffer 'ebrowse--header buffer)))
+ (header (buffer-local-value 'ebrowse--header buffer)))
(ebrowse-member-table header)))
"Return the item following STRING in LIST.
If STRING is the last element, return the first element as successor."
(or (nth (1+ (ebrowse-position string list 'string=)) list)
- (first list)))
+ (cl-first list)))
\f
;;; Symbol completion
;;;###autoload
-(defun* ebrowse-tags-complete-symbol (prefix)
+(cl-defun ebrowse-tags-complete-symbol (prefix)
"Perform completion on the C++ symbol preceding point.
A second call of this function without changing point inserts the next match.
A call with prefix PREFIX reads the symbol to insert from the minibuffer with
;; buffer: Start new completion.
(t
(let* ((members (ebrowse-some-member-table))
- (completion (first (all-completions pattern members nil))))
+ (completion (cl-first (all-completions pattern members nil))))
(cond ((eq completion t))
((null completion)
(error "Can't find completion for `%s'" pattern))
looks like a function call to the member."
(interactive)
;; Choose the tree to use if there is more than one.
- (multiple-value-bind (tree header tree-buffer)
- (values-list (ebrowse-choose-tree))
+ (cl-multiple-value-bind (tree header tree-buffer)
+ (cl-values-list (ebrowse-choose-tree))
(unless tree
(error "No class tree"))
;; Get the member name NAME (class-name is ignored).
(let ((name fix-name) class-name regexp)
(unless name
- (multiple-value-setq (class-name name)
- (values-list (ebrowse-tags-read-name header "Find calls of: "))))
+ (cl-multiple-value-setq (class-name name)
+ (cl-values-list (ebrowse-tags-read-name header "Find calls of: "))))
;; Set tags loop form to search for member and begin loop.
(setq regexp (concat "\\<" name "[ \t]*(")
ebrowse-tags-loop-form (list 're-search-forward regexp nil t))
;;; Structures of this kind are the elements of the position stack.
-(defstruct (ebrowse-position (:type vector) :named)
+(cl-defstruct (ebrowse-position (:type vector) :named)
file-name ; in which file
point ; point in file
target ; t if target of a jump
The string is printed in the electric position list buffer."
(let ((info (ebrowse-position-info position)))
(concat (if (ebrowse-position-target position) "at " "to ")
- (ebrowse-cs-name (ebrowse-ts-class (first info)))
- "::" (ebrowse-ms-name (third info)))))
+ (ebrowse-cs-name (ebrowse-ts-class (cl-first info)))
+ "::" (ebrowse-ms-name (cl-third info)))))
(defun ebrowse-view/find-position (position &optional view)
(let ((too-much (- (length ebrowse-position-stack)
ebrowse-max-positions)))
;; Do not let the stack grow to infinity.
- (when (plusp too-much)
+ (when (cl-plusp too-much)
(setq ebrowse-position-stack
(butlast ebrowse-position-stack too-much)))
;; Push the position.
(let ((tree-file (buffer-file-name))
temp-buffer-setup-hook)
(with-output-to-temp-buffer "*Tree Statistics*"
- (multiple-value-bind (classes member-functions member-variables
+ (cl-multiple-value-bind (classes member-functions member-variables
static-functions static-variables)
- (values-list (ebrowse-gather-statistics))
+ (cl-values-list (ebrowse-gather-statistics))
(set-buffer standard-output)
(erase-buffer)
(insert "STATISTICS FOR TREE " (or tree-file "unknown") ":\n\n")
(let ((classes 0) (member-functions 0) (member-variables 0)
(static-functions 0) (static-variables 0))
(ebrowse-for-all-trees (tree ebrowse--tree-obarray)
- (incf classes)
- (incf member-functions (length (ebrowse-ts-member-functions tree)))
- (incf member-variables (length (ebrowse-ts-member-variables tree)))
- (incf static-functions (length (ebrowse-ts-static-functions tree)))
- (incf static-variables (length (ebrowse-ts-static-variables tree))))
+ (cl-incf classes)
+ (cl-incf member-functions (length (ebrowse-ts-member-functions tree)))
+ (cl-incf member-variables (length (ebrowse-ts-member-variables tree)))
+ (cl-incf static-functions (length (ebrowse-ts-static-functions tree)))
+ (cl-incf static-variables (length (ebrowse-ts-static-variables tree))))
(list classes member-functions member-variables
static-functions static-variables)))
(mouse-set-point event)
(let* ((where (posn-point (event-start event)))
(property (get-text-property where 'ebrowse-what)))
- (case (event-click-count event)
+ (pcase (event-click-count event)
(1
- (case property
- (class-name
+ (pcase property
+ (`class-name
(ebrowse-popup-menu ebrowse-tree-buffer-class-object-menu event))
- (t
+ (_
(ebrowse-popup-menu ebrowse-tree-buffer-object-menu event)))))))
(mouse-set-point event)
(let* ((where (posn-point (event-start event)))
(property (get-text-property where 'ebrowse-what)))
- (case (event-click-count event)
- (1 (case property
- (class-name
+ (pcase (event-click-count event)
+ (1 (pcase property
+ (`class-name
(ebrowse-tree-command:show-member-functions)))))))
(mouse-set-point event)
(let* ((where (posn-point (event-start event)))
(property (get-text-property where 'ebrowse-what)))
- (case (event-click-count event)
- (2 (case property
- (class-name
+ (pcase (event-click-count event)
+ (2 (pcase property
+ (`class-name
(let ((collapsed (save-excursion (skip-chars-forward "^\r\n")
(looking-at "\r"))))
(ebrowse-collapse-fn (not collapsed))))
- (mark
+ (`mark
(ebrowse-toggle-mark-at-point 1)))))))
;;; Code:
-(eval-when-compile
- (require 'cl))
(require 'ring)
(require 'button)
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(if (featurep 'xemacs) (require 'overlay))
(defvar flymake-is-running nil
(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)
(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))
;; 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)
(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
;;; Code:
-(eval-when-compile
- (require 'cl))
-
-
;;; User variables
;;; Code:
-(eval-when-compile (require 'cl)) ; for case macro
-
(require 'comint)
(defvar gdb-active-process)
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))
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
(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))
(require 'json nil t)
(eval-when-compile
- (require 'cl)
+ (require 'cl-lib)
(require 'comint)
(require 'ido))
")
(defconst js--available-frameworks
- (loop with available-frameworks
- for style in js--class-styles
- for framework = (plist-get style :framework)
- unless (memq framework available-frameworks)
- collect framework into available-frameworks
- finally return available-frameworks)
+ (cl-loop for style in js--class-styles
+ for framework = (plist-get style :framework)
+ unless (memq framework available-frameworks)
+ collect framework into available-frameworks
+ finally return available-frameworks)
"List of available JavaScript frameworks symbols.")
(defconst js--function-heading-1-re
;; (The exception for b-end and its caveats is described below.)
;;
-(defstruct (js--pitem (:type list))
+(cl-defstruct (js--pitem (:type list))
;; IMPORTANT: Do not alter the position of fields within the list.
;; Various bits of code depend on their positions, particularly
;; anything that manipulates the list of children.
(make-variable-buffer-local 'js--state-at-last-parse-pos)
(defun js--flatten-list (list)
- (loop for item in list
- nconc (cond ((consp item)
- (js--flatten-list item))
- (item (list item)))))
+ (cl-loop for item in list
+ nconc (cond ((consp item)
+ (js--flatten-list item))
+ (item (list item)))))
(defun js--maybe-join (prefix separator suffix &rest list)
"Helper function for `js--update-quick-match-re'.
"Move forward over a whole JavaScript expression.
This function doesn't move over expressions continued across
lines."
- (loop
+ (cl-loop
;; non-continued case; simplistic, but good enough?
- do (loop until (or (eolp)
- (progn
- (forward-comment most-positive-fixnum)
- (memq (char-after) '(?\, ?\; ?\] ?\) ?\}))))
- do (forward-sexp))
+ do (cl-loop until (or (eolp)
+ (progn
+ (forward-comment most-positive-fixnum)
+ (memq (char-after) '(?\, ?\; ?\] ?\) ?\}))))
+ do (forward-sexp))
while (and (eq (char-after) ?\n)
(save-excursion
If this is a syntactically-correct non-expression function,
return the name of the function, or t if the name could not be
determined. Otherwise, return nil."
- (assert (looking-at "\\_<function\\_>"))
+ (cl-assert (looking-at "\\_<function\\_>"))
(let ((name t))
(forward-word)
(forward-comment most-positive-fixnum)
"Helper function for `js--beginning-of-defun-nested'.
If PSTATE represents a non-empty top-level defun, return the
top-most pitem. Otherwise, return nil."
- (loop for pitem in pstate
- with func-depth = 0
- with func-pitem
- if (eq 'function (js--pitem-type pitem))
- do (incf func-depth)
- and do (setq func-pitem pitem)
- finally return (if (eq func-depth 1) func-pitem)))
+ (cl-loop for pitem in pstate
+ with func-depth = 0
+ with func-pitem
+ if (eq 'function (js--pitem-type pitem))
+ do (cl-incf func-depth)
+ and do (setq func-pitem pitem)
+ finally return (if (eq func-depth 1) func-pitem)))
(defun js--beginning-of-defun-nested ()
"Helper function for `js--beginning-of-defun'.
Return the pitem of the function we went to the beginning of."
(or
;; Look for the smallest function that encloses point...
- (loop for pitem in (js--parse-state-at-point)
- if (and (eq 'function (js--pitem-type pitem))
- (js--inside-pitem-p pitem))
- do (goto-char (js--pitem-h-begin pitem))
- and return pitem)
+ (cl-loop for pitem in (js--parse-state-at-point)
+ if (and (eq 'function (js--pitem-type pitem))
+ (js--inside-pitem-p pitem))
+ do (goto-char (js--pitem-h-begin pitem))
+ and return pitem)
;; ...and if that isn't found, look for the previous top-level
;; defun
- (loop for pstate = (js--backward-pstate)
- while pstate
- if (js--pstate-is-toplevel-defun pstate)
- do (goto-char (js--pitem-h-begin it))
- and return it)))
+ (cl-loop for pstate = (js--backward-pstate)
+ while pstate
+ if (js--pstate-is-toplevel-defun pstate)
+ do (goto-char (js--pitem-h-begin it))
+ and return it)))
(defun js--beginning-of-defun-flat ()
"Helper function for `js-beginning-of-defun'."
"Value of `beginning-of-defun-function' for `js-mode'."
(setq arg (or arg 1))
(while (and (not (eobp)) (< arg 0))
- (incf arg)
+ (cl-incf arg)
(when (and (not js-flat-functions)
(or (eq (js-syntactic-context) 'function)
(js--function-prologue-beginning)))
(goto-char (point-max))))
(while (> arg 0)
- (decf arg)
+ (cl-decf arg)
;; If we're just past the end of a function, the user probably wants
;; to go to the beginning of *that* function
(when (eq (char-before) ?})
(defun js--ensure-cache--pop-if-ended (open-items paren-depth)
(let ((top-item (car open-items)))
(when (<= paren-depth (js--pitem-paren-depth top-item))
- (assert (not (get-text-property (1- (point)) 'js-pend)))
+ (cl-assert (not (get-text-property (1- (point)) 'js-pend)))
(put-text-property (1- (point)) (point) 'js--pend top-item)
(setf (js--pitem-b-end top-item) (point))
(setq open-items
;; open-items must contain at least two items for this to
;; work, but because we push a dummy item to start with,
;; that assumption holds.
- (cons (js--pitem-add-child (second open-items) top-item)
+ (cons (js--pitem-add-child (cl-second open-items) top-item)
(cddr open-items)))))
open-items)
;; Make sure parse-partial-sexp doesn't stop because we *entered*
;; the given depth -- i.e., make sure we're deeper than the target
;; depth.
- (assert (> (nth 0 parse)
+ (cl-assert (> (nth 0 parse)
(js--pitem-paren-depth (car open-items))))
(setq parse (parse-partial-sexp
prev-parse-point goal-point
;; Figure out which class styles we need to look for
(setq filtered-class-styles
- (loop for style in js--class-styles
- if (memq (plist-get style :framework)
- js-enabled-frameworks)
- collect style))
+ (cl-loop for style in js--class-styles
+ if (memq (plist-get style :framework)
+ js-enabled-frameworks)
+ collect style))
(save-excursion
(save-restriction
(unless (bobp)
(setq open-items (get-text-property (1- (point))
'js--pstate))
- (assert open-items))))
+ (cl-assert open-items))))
(unless open-items
;; Make a placeholder for the top-level definition
(narrow-to-region (point-min) limit)
- (loop while (re-search-forward js--quick-match-re-func nil t)
- for orig-match-start = (goto-char (match-beginning 0))
- for orig-match-end = (match-end 0)
- do (js--ensure-cache--update-parse)
- for orig-depth = (nth 0 parse)
-
- ;; Each of these conditions should return non-nil if
- ;; we should add a new item and leave point at the end
- ;; of the new item's header (h-end in the
- ;; js--pitem diagram). This point is the one
- ;; after the last character we need to unambiguously
- ;; detect this construct. If one of these evaluates to
- ;; nil, the location of the point is ignored.
- if (cond
- ;; In comment or string
- ((nth 8 parse) nil)
-
- ;; Regular function declaration
- ((and (looking-at "\\_<function\\_>")
- (setq name (js--forward-function-decl)))
-
- (when (eq name t)
- (setq name (js--guess-function-name orig-match-end))
- (if name
- (when js--guess-function-name-start
- (setq orig-match-start
- js--guess-function-name-start))
-
- (setq name t)))
-
- (assert (eq (char-after) ?{))
- (forward-char)
- (make-js--pitem
- :paren-depth orig-depth
- :h-begin orig-match-start
- :type 'function
- :name (if (eq name t)
- name
- (js--split-name name))))
-
- ;; Macro
- ((looking-at js--macro-decl-re)
-
- ;; Macros often contain unbalanced parentheses.
- ;; Make sure that h-end is at the textual end of
- ;; the macro no matter what the parenthesis say.
- (c-end-of-macro)
- (js--ensure-cache--update-parse)
-
- (make-js--pitem
- :paren-depth (nth 0 parse)
- :h-begin orig-match-start
- :type 'macro
- :name (list (match-string-no-properties 1))))
-
- ;; "Prototype function" declaration
- ((looking-at js--plain-method-re)
- (goto-char (match-beginning 3))
- (when (save-match-data
- (js--forward-function-decl))
- (forward-char)
- (make-js--pitem
- :paren-depth orig-depth
- :h-begin orig-match-start
- :type 'function
- :name (nconc (js--split-name
- (match-string-no-properties 1))
- (list (match-string-no-properties 2))))))
-
- ;; Class definition
- ((loop with syntactic-context =
- (js--syntactic-context-from-pstate open-items)
- for class-style in filtered-class-styles
- if (and (memq syntactic-context
- (plist-get class-style :contexts))
- (looking-at (plist-get class-style
- :class-decl)))
- do (goto-char (match-end 0))
- and return
- (make-js--pitem
- :paren-depth orig-depth
- :h-begin orig-match-start
- :type class-style
- :name (js--split-name
- (match-string-no-properties 1))))))
-
- do (js--ensure-cache--update-parse)
- and do (push it open-items)
- and do (put-text-property
- (1- (point)) (point) 'js--pstate open-items)
- else do (goto-char orig-match-end))
+ (cl-loop while (re-search-forward js--quick-match-re-func nil t)
+ for orig-match-start = (goto-char (match-beginning 0))
+ for orig-match-end = (match-end 0)
+ do (js--ensure-cache--update-parse)
+ for orig-depth = (nth 0 parse)
+
+ ;; Each of these conditions should return non-nil if
+ ;; we should add a new item and leave point at the end
+ ;; of the new item's header (h-end in the
+ ;; js--pitem diagram). This point is the one
+ ;; after the last character we need to unambiguously
+ ;; detect this construct. If one of these evaluates to
+ ;; nil, the location of the point is ignored.
+ if (cond
+ ;; In comment or string
+ ((nth 8 parse) nil)
+
+ ;; Regular function declaration
+ ((and (looking-at "\\_<function\\_>")
+ (setq name (js--forward-function-decl)))
+
+ (when (eq name t)
+ (setq name (js--guess-function-name orig-match-end))
+ (if name
+ (when js--guess-function-name-start
+ (setq orig-match-start
+ js--guess-function-name-start))
+
+ (setq name t)))
+
+ (cl-assert (eq (char-after) ?{))
+ (forward-char)
+ (make-js--pitem
+ :paren-depth orig-depth
+ :h-begin orig-match-start
+ :type 'function
+ :name (if (eq name t)
+ name
+ (js--split-name name))))
+
+ ;; Macro
+ ((looking-at js--macro-decl-re)
+
+ ;; Macros often contain unbalanced parentheses.
+ ;; Make sure that h-end is at the textual end of
+ ;; the macro no matter what the parenthesis say.
+ (c-end-of-macro)
+ (js--ensure-cache--update-parse)
+
+ (make-js--pitem
+ :paren-depth (nth 0 parse)
+ :h-begin orig-match-start
+ :type 'macro
+ :name (list (match-string-no-properties 1))))
+
+ ;; "Prototype function" declaration
+ ((looking-at js--plain-method-re)
+ (goto-char (match-beginning 3))
+ (when (save-match-data
+ (js--forward-function-decl))
+ (forward-char)
+ (make-js--pitem
+ :paren-depth orig-depth
+ :h-begin orig-match-start
+ :type 'function
+ :name (nconc (js--split-name
+ (match-string-no-properties 1))
+ (list (match-string-no-properties 2))))))
+
+ ;; Class definition
+ ((cl-loop
+ with syntactic-context =
+ (js--syntactic-context-from-pstate open-items)
+ for class-style in filtered-class-styles
+ if (and (memq syntactic-context
+ (plist-get class-style :contexts))
+ (looking-at (plist-get class-style
+ :class-decl)))
+ do (goto-char (match-end 0))
+ and return
+ (make-js--pitem
+ :paren-depth orig-depth
+ :h-begin orig-match-start
+ :type class-style
+ :name (js--split-name
+ (match-string-no-properties 1))))))
+
+ do (js--ensure-cache--update-parse)
+ and do (push it open-items)
+ and do (put-text-property
+ (1- (point)) (point) 'js--pstate open-items)
+ else do (goto-char orig-match-end))
(goto-char limit)
(js--ensure-cache--update-parse)
(defun js--end-of-defun-flat ()
"Helper function for `js-end-of-defun'."
- (loop while (js--re-search-forward "}" nil t)
- do (js--ensure-cache)
- if (get-text-property (1- (point)) 'js--pend)
- if (eq 'function (js--pitem-type it))
- return t
- finally do (goto-char (point-max))))
+ (cl-loop while (js--re-search-forward "}" nil t)
+ do (js--ensure-cache)
+ if (get-text-property (1- (point)) 'js--pend)
+ if (eq 'function (js--pitem-type it))
+ return t
+ finally do (goto-char (point-max))))
(defun js--end-of-defun-nested ()
"Helper function for `js-end-of-defun'."
"Value of `end-of-defun-function' for `js-mode'."
(setq arg (or arg 1))
(while (and (not (bobp)) (< arg 0))
- (incf arg)
+ (cl-incf arg)
(js-beginning-of-defun)
(js-beginning-of-defun)
(unless (bobp)
(js-end-of-defun)))
(while (> arg 0)
- (decf arg)
+ (cl-decf arg)
;; look for function backward. if we're inside it, go to that
;; function's end. otherwise, search for the next function's end and
;; go there
If FUNC is supplied, call it with no arguments before every
variable name in the spec. Return true iff this was actually a
spec. FUNC must preserve the match data."
- (case (char-after)
+ (pcase (char-after)
(?\[
(forward-char)
(while
(defun js--inside-pitem-p (pitem)
"Return whether point is inside the given pitem's header or body."
(js--ensure-cache)
- (assert (js--pitem-h-begin pitem))
- (assert (js--pitem-paren-depth pitem))
+ (cl-assert (js--pitem-h-begin pitem))
+ (cl-assert (js--pitem-paren-depth pitem))
(and (> (point) (js--pitem-h-begin pitem))
(or (null (js--pitem-b-end pitem))
;; Loop until we either hit a pitem at BOB or pitem ends after
;; point (or at point if we're at eob)
- (loop for pitem = (car pstate)
- until (or (eq (js--pitem-type pitem)
- 'toplevel)
- (js--inside-pitem-p pitem))
- do (pop pstate))
+ (cl-loop for pitem = (car pstate)
+ until (or (eq (js--pitem-type pitem)
+ 'toplevel)
+ (js--inside-pitem-p pitem))
+ do (pop pstate))
pstate))))
(defun js--class-decl-matcher (limit)
"Font lock function used by `js-mode'.
This performs fontification according to `js--class-styles'."
- (loop initially (js--ensure-cache limit)
- while (re-search-forward js--quick-match-re limit t)
- for orig-end = (match-end 0)
- do (goto-char (match-beginning 0))
- if (loop for style in js--class-styles
- for decl-re = (plist-get style :class-decl)
- if (and (memq (plist-get style :framework)
- js-enabled-frameworks)
- (memq (js-syntactic-context)
- (plist-get style :contexts))
- decl-re
- (looking-at decl-re))
- do (goto-char (match-end 0))
- and return t)
- return t
- else do (goto-char orig-end)))
+ (cl-loop initially (js--ensure-cache limit)
+ while (re-search-forward js--quick-match-re limit t)
+ for orig-end = (match-end 0)
+ do (goto-char (match-beginning 0))
+ if (cl-loop for style in js--class-styles
+ for decl-re = (plist-get style :class-decl)
+ if (and (memq (plist-get style :framework)
+ js-enabled-frameworks)
+ (memq (js-syntactic-context)
+ (plist-get style :contexts))
+ decl-re
+ (looking-at decl-re))
+ do (goto-char (match-end 0))
+ and return t)
+ return t
+ else do (goto-char orig-end)))
(defconst js--font-lock-keywords
'(js--font-lock-keywords-3 js--font-lock-keywords-1
js-expr-indent-offset))
(t
(+ (current-column) js-indent-level
- (case (char-after (nth 1 parse-status))
+ (pcase (char-after (nth 1 parse-status))
(?\( js-paren-indent-offset)
(?\[ js-square-indent-offset)
(?\{ js-curly-indent-offset))))))
(defun js-c-fill-paragraph (&optional justify)
"Fill the paragraph with `c-fill-paragraph'."
(interactive "*P")
- (letf (((symbol-function 'c-forward-sws)
- (lambda (&optional limit)
- (js--forward-syntactic-ws limit)))
- ((symbol-function 'c-backward-sws)
- (lambda (&optional limit)
- (js--backward-syntactic-ws limit)))
- ((symbol-function 'c-beginning-of-macro)
- (lambda (&optional limit)
- (js--beginning-of-macro limit))))
+ ;; FIXME: Such redefinitions are bad style. We should try and use some other
+ ;; way to get the same result.
+ (cl-letf (((symbol-function 'c-forward-sws)
+ (lambda (&optional limit)
+ (js--forward-syntactic-ws limit)))
+ ((symbol-function 'c-backward-sws)
+ (lambda (&optional limit)
+ (js--backward-syntactic-ws limit)))
+ ((symbol-function 'c-beginning-of-macro)
+ (lambda (&optional limit)
+ (js--beginning-of-macro limit))))
(let ((fill-paragraph-function 'c-fill-paragraph))
(c-fill-paragraph justify))))
name-parts
(mapcar #'js--pitem-name items))
- (assert (stringp top-name))
- (assert (> (length top-name) 0))
+ (cl-assert (stringp top-name))
+ (cl-assert (> (length top-name) 0))
;; If top-name isn't found in items, then we build a copy of items
;; and throw it away. But that's okay, since most of the time, we
(defun js--pitem-add-child (pitem child)
"Copy `js--pitem' PITEM, and push CHILD onto its list of children."
- (assert (integerp (js--pitem-h-begin child)))
- (assert (if (consp (js--pitem-name child))
- (loop for part in (js--pitem-name child)
- always (stringp part))
+ (cl-assert (integerp (js--pitem-h-begin child)))
+ (cl-assert (if (consp (js--pitem-name child))
+ (cl-loop for part in (js--pitem-name child)
+ always (stringp part))
t))
;; This trick works because we know (based on our defstructs) that
;; name is a list here because down in
;; `js--ensure-cache', we made sure to only add
;; class entries with lists for :name
- (assert (consp name))
+ (cl-assert (consp name))
(js--splice-into-items (car pitem) child name))
(t
(setq pitem-name (js--pitem-strname pitem))
(when (eq pitem-name t)
(setq pitem-name (format "[unknown %s]"
- (incf (car unknown-ctr)))))
+ (cl-incf (car unknown-ctr)))))
(cond
((memq pitem-type '(function macro))
- (assert (integerp (js--pitem-h-begin pitem)))
+ (cl-assert (integerp (js--pitem-h-begin pitem)))
(push (cons pitem-name
(js--maybe-make-marker
(js--pitem-h-begin pitem)))
imenu-items))
((js--pitem-h-begin pitem)
- (assert (integerp (js--pitem-h-begin pitem)))
+ (cl-assert (integerp (js--pitem-h-begin pitem)))
(setq subitems (list
(cons "[empty]"
(js--maybe-make-marker
(widen)
(goto-char (point-max))
(js--ensure-cache)
- (assert (or (= (point-min) (point-max))
+ (cl-assert (or (= (point-min) (point-max))
(eq js--last-parse-pos (point))))
(when js--last-parse-pos
(let ((state js--state-at-last-parse-pos)
;; Make sure everything is closed
(while (cdr state)
(setq state
- (cons (js--pitem-add-child (second state) (car state))
+ (cons (js--pitem-add-child (cl-second state) (car state))
(cddr state))))
- (assert (= (length state) 1))
+ (cl-assert (= (length state) 1))
;; Convert the new-finalized state into what imenu expects
(js--pitems-to-imenu
(mapconcat #'identity parts "."))
(defun js--imenu-to-flat (items prefix symbols)
- (loop for item in items
- if (imenu--subalist-p item)
- do (js--imenu-to-flat
- (cdr item) (concat prefix (car item) ".")
- symbols)
- else
- do (let* ((name (concat prefix (car item)))
- (name2 name)
- (ctr 0))
+ (cl-loop for item in items
+ if (imenu--subalist-p item)
+ do (js--imenu-to-flat
+ (cdr item) (concat prefix (car item) ".")
+ symbols)
+ else
+ do (let* ((name (concat prefix (car item)))
+ (name2 name)
+ (ctr 0))
- (while (gethash name2 symbols)
- (setq name2 (format "%s<%d>" name (incf ctr))))
+ (while (gethash name2 symbols)
+ (setq name2 (format "%s<%d>" name (cl-incf ctr))))
- (puthash name2 (cdr item) symbols))))
+ (puthash name2 (cdr item) symbols))))
(defun js--get-all-known-symbols ()
"Return a hash table of all JavaScript symbols.
This searches all existing `js-mode' buffers. Each key is the
name of a symbol (possibly disambiguated with <N>, where N > 1),
and each value is a marker giving the location of that symbol."
- (loop with symbols = (make-hash-table :test 'equal)
- with imenu-use-markers = t
- for buffer being the buffers
- for imenu-index = (with-current-buffer buffer
- (when (derived-mode-p 'js-mode)
- (js--imenu-create-index)))
- do (js--imenu-to-flat imenu-index "" symbols)
- finally return symbols))
+ (cl-loop with symbols = (make-hash-table :test 'equal)
+ with imenu-use-markers = t
+ for buffer being the buffers
+ for imenu-index = (with-current-buffer buffer
+ (when (derived-mode-p 'js-mode)
+ (js--imenu-create-index)))
+ do (js--imenu-to-flat imenu-index "" symbols)
+ finally return symbols))
(defvar js--symbol-history nil
"History of entered JavaScript symbols.")
(let ((choice (ido-completing-read
prompt
- (loop for key being the hash-keys of symbols-table
- collect key)
+ (cl-loop for key being the hash-keys of symbols-table
+ collect key)
nil t initial-input 'js--symbol-history)))
(cons choice (gethash choice symbols-table))))
set. If START is non-nil, look for output starting from START.
Otherwise, use the current value of `process-mark'."
(with-current-buffer (process-buffer process)
- (loop with start-pos = (or start
- (marker-position (process-mark process)))
- with end-time = (+ (float-time) timeout)
- for time-left = (- end-time (float-time))
- do (goto-char (point-max))
- if (looking-back regexp start-pos) return t
- while (> time-left 0)
- do (accept-process-output process time-left nil t)
- do (goto-char (process-mark process))
- finally do (signal
- 'js-moz-bad-rpc
- (list (format "Timed out waiting for output matching %S" regexp))))))
-
-(defstruct js--js-handle
+ (cl-loop with start-pos = (or start
+ (marker-position (process-mark process)))
+ with end-time = (+ (float-time) timeout)
+ for time-left = (- end-time (float-time))
+ do (goto-char (point-max))
+ if (looking-back regexp start-pos) return t
+ while (> time-left 0)
+ do (accept-process-output process time-left nil t)
+ do (goto-char (process-mark process))
+ finally do (signal
+ 'js-moz-bad-rpc
+ (list (format "Timed out waiting for output matching %S" regexp))))))
+
+(cl-defstruct js--js-handle
;; Integer, mirrors the value we see in JS
(id nil :read-only t)
(inferior-moz-process) js--js-repl-prompt-regexp
js-js-timeout))
- (incf js--js-repl-depth)))
+ (cl-incf js--js-repl-depth)))
(defun js--js-leave-repl ()
- (assert (> js--js-repl-depth 0))
- (when (= 0 (decf js--js-repl-depth))
+ (cl-assert (> js--js-repl-depth 0))
+ (when (= 0 (cl-decf js--js-repl-depth))
(with-current-buffer inferior-moz-buffer
(goto-char (point-max))
(js--js-wait-for-eval-prompt)
(eval-and-compile
(defun js--optimize-arglist (arglist)
"Convert immediate js< and js! references to deferred ones."
- (loop for item in arglist
- if (eq (car-safe item) 'js<)
- collect (append (list 'list ''js--funcall
- '(list 'interactor "_getProp"))
- (js--optimize-arglist (cdr item)))
- else if (eq (car-safe item) 'js>)
- collect (append (list 'list ''js--funcall
- '(list 'interactor "_putProp"))
-
- (if (atom (cadr item))
- (list (cadr item))
- (list
- (append
- (list 'list ''js--funcall
- '(list 'interactor "_mkArray"))
- (js--optimize-arglist (cadr item)))))
- (js--optimize-arglist (cddr item)))
- else if (eq (car-safe item) 'js!)
- collect (destructuring-bind (ignored function &rest body) item
- (append (list 'list ''js--funcall
- (if (consp function)
- (cons 'list
- (js--optimize-arglist function))
- function))
- (js--optimize-arglist body)))
- else
- collect item)))
+ (cl-loop for item in arglist
+ if (eq (car-safe item) 'js<)
+ collect (append (list 'list ''js--funcall
+ '(list 'interactor "_getProp"))
+ (js--optimize-arglist (cdr item)))
+ else if (eq (car-safe item) 'js>)
+ collect (append (list 'list ''js--funcall
+ '(list 'interactor "_putProp"))
+
+ (if (atom (cadr item))
+ (list (cadr item))
+ (list
+ (append
+ (list 'list ''js--funcall
+ '(list 'interactor "_mkArray"))
+ (js--optimize-arglist (cadr item)))))
+ (js--optimize-arglist (cddr item)))
+ else if (eq (car-safe item) 'js!)
+ collect (pcase-let ((`(,_ ,function . ,body) item))
+ (append (list 'list ''js--funcall
+ (if (consp function)
+ (cons 'list
+ (js--optimize-arglist function))
+ function))
+ (js--optimize-arglist body)))
+ else
+ collect item)))
(defmacro js--js-get-service (class-name interface-name)
`(js! ("Components" "classes" ,class-name "getService")
`(progn
(js--js-enter-repl)
(unwind-protect
- (macrolet ((js? (&rest body) `(js--js-true ,@body))
- (js! (function &rest body)
- `(js--js-funcall
- ,(if (consp function)
- (cons 'list
- (js--optimize-arglist function))
- function)
- ,@(js--optimize-arglist body)))
-
- (js-new (function &rest body)
- `(js--js-new
+ (cl-macrolet ((js? (&rest body) `(js--js-true ,@body))
+ (js! (function &rest body)
+ `(js--js-funcall
,(if (consp function)
(cons 'list
(js--optimize-arglist function))
function)
- ,@body))
-
- (js-eval (thisobj js)
- `(js--js-eval
- ,@(js--optimize-arglist
- (list thisobj js))))
-
- (js-list (&rest args)
- `(js--js-list
- ,@(js--optimize-arglist args)))
-
- (js-get-service (&rest args)
- `(js--js-get-service
- ,@(js--optimize-arglist args)))
-
- (js-create-instance (&rest args)
- `(js--js-create-instance
- ,@(js--optimize-arglist args)))
-
- (js-qi (&rest args)
- `(js--js-qi
- ,@(js--optimize-arglist args)))
-
- (js< (&rest body) `(js--js-get
- ,@(js--optimize-arglist body)))
- (js> (props value)
- `(js--js-funcall
- '(interactor "_putProp")
- ,(if (consp props)
- (cons 'list
- (js--optimize-arglist props))
- props)
- ,@(js--optimize-arglist (list value))
- ))
- (js-handle? (arg) `(js--js-handle-p ,arg)))
+ ,@(js--optimize-arglist body)))
+
+ (js-new (function &rest body)
+ `(js--js-new
+ ,(if (consp function)
+ (cons 'list
+ (js--optimize-arglist function))
+ function)
+ ,@body))
+
+ (js-eval (thisobj js)
+ `(js--js-eval
+ ,@(js--optimize-arglist
+ (list thisobj js))))
+
+ (js-list (&rest args)
+ `(js--js-list
+ ,@(js--optimize-arglist args)))
+
+ (js-get-service (&rest args)
+ `(js--js-get-service
+ ,@(js--optimize-arglist args)))
+
+ (js-create-instance (&rest args)
+ `(js--js-create-instance
+ ,@(js--optimize-arglist args)))
+
+ (js-qi (&rest args)
+ `(js--js-qi
+ ,@(js--optimize-arglist args)))
+
+ (js< (&rest body) `(js--js-get
+ ,@(js--optimize-arglist body)))
+ (js> (props value)
+ `(js--js-funcall
+ '(interactor "_putProp")
+ ,(if (consp props)
+ (cons 'list
+ (js--optimize-arglist props))
+ props)
+ ,@(js--optimize-arglist (list value))
+ ))
+ (js-handle? (arg) `(js--js-handle-p ,arg)))
,@forms)
(js--js-leave-repl))))
If nil, the whole Array is treated as a JS symbol.")
(defun js--js-decode-retval (result)
- (ecase (intern (first result))
- (atom (second result))
- (special (intern (second result)))
- (array
- (mapcar #'js--js-decode-retval (second result)))
- (objid
- (or (gethash (second result)
- js--js-references)
- (puthash (second result)
- (make-js--js-handle
- :id (second result)
- :process (inferior-moz-process))
- js--js-references)))
-
- (error (signal 'js-js-error (list (second result))))))
+ (pcase (intern (cl-first result))
+ (`atom (cl-second result))
+ (`special (intern (cl-second result)))
+ (`array
+ (mapcar #'js--js-decode-retval (cl-second result)))
+ (`objid
+ (or (gethash (cl-second result)
+ js--js-references)
+ (puthash (cl-second result)
+ (make-js--js-handle
+ :id (cl-second result)
+ :process (inferior-moz-process))
+ js--js-references)))
+
+ (`error (signal 'js-js-error (list (cl-second result))))
+ (x (error "Unmatched case in js--js-decode-retval: %S" x))))
(defun js--js-funcall (function &rest arguments)
"Call the Mozilla function FUNCTION with arguments ARGUMENTS.
(looking-back js--js-prompt-regexp
(save-excursion (forward-line 0) (point))))))
- (setq keys (loop for x being the hash-keys
- of js--js-references
- collect x))
+ (setq keys (cl-loop for x being the hash-keys
+ of js--js-references
+ collect x))
(setq num (js--js-funcall '(repl "_jsGC") (or keys [])))
(setq js--js-last-gcs-done this-gcs-done)
(with-js
(let (windows)
- (loop with window-mediator = (js! ("Components" "classes"
- "@mozilla.org/appshell/window-mediator;1"
- "getService")
- (js< "Components" "interfaces"
- "nsIWindowMediator"))
- with enumerator = (js! (window-mediator "getEnumerator") nil)
-
- while (js? (js! (enumerator "hasMoreElements")))
- for window = (js! (enumerator "getNext"))
- for window-info = (js-list window
- (js< window "document" "title")
- (js! (window "location" "toString"))
- (js< window "closed")
- (js< window "windowState"))
-
- unless (or (js? (fourth window-info))
- (eq (fifth window-info) 2))
- do (push window-info windows))
-
- (loop for window-info in windows
- for window = (first window-info)
- collect (list (second window-info)
- (third window-info)
- window)
-
- for gbrowser = (js< window "gBrowser")
- if (js-handle? gbrowser)
- nconc (loop
- for x below (js< gbrowser "browsers" "length")
- collect (js-list (js< gbrowser
- "browsers"
- x
- "contentDocument"
- "title")
-
- (js! (gbrowser
- "browsers"
- x
- "contentWindow"
- "location"
- "toString"))
- (js< gbrowser
- "browsers"
- x)
-
- (js! (gbrowser
- "tabContainer"
- "childNodes"
- "item")
- x)
-
- gbrowser))))))
+ (cl-loop with window-mediator = (js! ("Components" "classes"
+ "@mozilla.org/appshell/window-mediator;1"
+ "getService")
+ (js< "Components" "interfaces"
+ "nsIWindowMediator"))
+ with enumerator = (js! (window-mediator "getEnumerator") nil)
+
+ while (js? (js! (enumerator "hasMoreElements")))
+ for window = (js! (enumerator "getNext"))
+ for window-info = (js-list window
+ (js< window "document" "title")
+ (js! (window "location" "toString"))
+ (js< window "closed")
+ (js< window "windowState"))
+
+ unless (or (js? (cl-fourth window-info))
+ (eq (cl-fifth window-info) 2))
+ do (push window-info windows))
+
+ (cl-loop for window-info in windows
+ for window = (cl-first window-info)
+ collect (list (cl-second window-info)
+ (cl-third window-info)
+ window)
+
+ for gbrowser = (js< window "gBrowser")
+ if (js-handle? gbrowser)
+ nconc (cl-loop
+ for x below (js< gbrowser "browsers" "length")
+ collect (js-list (js< gbrowser
+ "browsers"
+ x
+ "contentDocument"
+ "title")
+
+ (js! (gbrowser
+ "browsers"
+ x
+ "contentWindow"
+ "location"
+ "toString"))
+ (js< gbrowser
+ "browsers"
+ x)
+
+ (js! (gbrowser
+ "tabContainer"
+ "childNodes"
+ "item")
+ x)
+
+ gbrowser))))))
(defvar js-read-tab-history nil)
selected-tab prev-hitab)
;; Disambiguate names
- (setq tabs (loop with tab-names = (make-hash-table :test 'equal)
- for tab in tabs
- for cname = (format "%s (%s)" (second tab) (first tab))
- for num = (incf (gethash cname tab-names -1))
- if (> num 0)
- do (setq cname (format "%s <%d>" cname num))
- collect (cons cname tab)))
-
- (labels ((find-tab-by-cname
- (cname)
- (loop for tab in tabs
- if (equal (car tab) cname)
- return (cdr tab)))
-
- (mogrify-highlighting
- (hitab unhitab)
-
- ;; Hack to reduce the number of
- ;; round-trips to mozilla
- (let (cmds)
- (cond
- ;; Highlighting tab
- ((fourth hitab)
- (push '(js! ((fourth hitab) "setAttribute")
- "style"
- "color: red; font-weight: bold")
- cmds)
-
- ;; Highlight window proper
- (push '(js! ((third hitab)
- "setAttribute")
- "style"
- "border: 8px solid red")
- cmds)
-
- ;; Select tab, when appropriate
- (when js-js-switch-tabs
- (push
- '(js> ((fifth hitab) "selectedTab") (fourth hitab))
- cmds)))
-
- ;; Highlighting whole window
- ((third hitab)
- (push '(js! ((third hitab) "document"
- "documentElement" "setAttribute")
- "style"
- (concat "-moz-appearance: none;"
- "border: 8px solid red;"))
- cmds)))
-
- (cond
- ;; Unhighlighting tab
- ((fourth unhitab)
- (push '(js! ((fourth unhitab) "setAttribute") "style" "")
- cmds)
- (push '(js! ((third unhitab) "setAttribute") "style" "")
- cmds))
-
- ;; Unhighlighting window
- ((third unhitab)
- (push '(js! ((third unhitab) "document"
- "documentElement" "setAttribute")
- "style" "")
- cmds)))
-
- (eval (list 'with-js
- (cons 'js-list (nreverse cmds))))))
-
- (command-hook
- ()
- (let* ((tab (find-tab-by-cname (car ido-matches))))
- (mogrify-highlighting tab prev-hitab)
- (setq prev-hitab tab)))
-
- (setup-hook
- ()
- ;; Fiddle with the match list a bit: if our first match
- ;; is a tabbrowser window, rotate the match list until
- ;; the active tab comes up
- (let ((matched-tab (find-tab-by-cname (car ido-matches))))
- (when (and matched-tab
- (null (fourth matched-tab))
- (equal "navigator:browser"
- (js! ((third matched-tab)
- "document"
- "documentElement"
- "getAttribute")
- "windowtype")))
-
- (loop with tab-to-match = (js< (third matched-tab)
- "gBrowser"
- "selectedTab")
-
- for match in ido-matches
- for candidate-tab = (find-tab-by-cname match)
- if (eq (fourth candidate-tab) tab-to-match)
- do (setq ido-cur-list (ido-chop ido-cur-list match))
- and return t)))
-
- (add-hook 'post-command-hook #'command-hook t t)))
+ (setq tabs
+ (cl-loop with tab-names = (make-hash-table :test 'equal)
+ for tab in tabs
+ for cname = (format "%s (%s)"
+ (cl-second tab) (cl-first tab))
+ for num = (cl-incf (gethash cname tab-names -1))
+ if (> num 0)
+ do (setq cname (format "%s <%d>" cname num))
+ collect (cons cname tab)))
+
+ (cl-labels
+ ((find-tab-by-cname
+ (cname)
+ (cl-loop for tab in tabs
+ if (equal (car tab) cname)
+ return (cdr tab)))
+
+ (mogrify-highlighting
+ (hitab unhitab)
+
+ ;; Hack to reduce the number of
+ ;; round-trips to mozilla
+ (let (cmds)
+ (cond
+ ;; Highlighting tab
+ ((cl-fourth hitab)
+ (push '(js! ((cl-fourth hitab) "setAttribute")
+ "style"
+ "color: red; font-weight: bold")
+ cmds)
+
+ ;; Highlight window proper
+ (push '(js! ((cl-third hitab)
+ "setAttribute")
+ "style"
+ "border: 8px solid red")
+ cmds)
+
+ ;; Select tab, when appropriate
+ (when js-js-switch-tabs
+ (push
+ '(js> ((cl-fifth hitab) "selectedTab") (cl-fourth hitab))
+ cmds)))
+
+ ;; Highlighting whole window
+ ((cl-third hitab)
+ (push '(js! ((cl-third hitab) "document"
+ "documentElement" "setAttribute")
+ "style"
+ (concat "-moz-appearance: none;"
+ "border: 8px solid red;"))
+ cmds)))
+
+ (cond
+ ;; Unhighlighting tab
+ ((cl-fourth unhitab)
+ (push '(js! ((cl-fourth unhitab) "setAttribute") "style" "")
+ cmds)
+ (push '(js! ((cl-third unhitab) "setAttribute") "style" "")
+ cmds))
+
+ ;; Unhighlighting window
+ ((cl-third unhitab)
+ (push '(js! ((cl-third unhitab) "document"
+ "documentElement" "setAttribute")
+ "style" "")
+ cmds)))
+
+ (eval (list 'with-js
+ (cons 'js-list (nreverse cmds))))))
+
+ (command-hook
+ ()
+ (let* ((tab (find-tab-by-cname (car ido-matches))))
+ (mogrify-highlighting tab prev-hitab)
+ (setq prev-hitab tab)))
+
+ (setup-hook
+ ()
+ ;; Fiddle with the match list a bit: if our first match
+ ;; is a tabbrowser window, rotate the match list until
+ ;; the active tab comes up
+ (let ((matched-tab (find-tab-by-cname (car ido-matches))))
+ (when (and matched-tab
+ (null (cl-fourth matched-tab))
+ (equal "navigator:browser"
+ (js! ((cl-third matched-tab)
+ "document"
+ "documentElement"
+ "getAttribute")
+ "windowtype")))
+
+ (cl-loop with tab-to-match = (js< (cl-third matched-tab)
+ "gBrowser"
+ "selectedTab")
+
+ for match in ido-matches
+ for candidate-tab = (find-tab-by-cname match)
+ if (eq (cl-fourth candidate-tab) tab-to-match)
+ do (setq ido-cur-list
+ (ido-chop ido-cur-list match))
+ and return t)))
+
+ (add-hook 'post-command-hook #'command-hook t t)))
(unwind-protect
(add-to-history 'js-read-tab-history selected-tab-cname)
- (setq selected-tab (loop for tab in tabs
- if (equal (car tab) selected-tab-cname)
- return (cdr tab)))
+ (setq selected-tab (cl-loop for tab in tabs
+ if (equal (car tab) selected-tab-cname)
+ return (cdr tab)))
- (if (fourth selected-tab)
- (cons 'browser (third selected-tab))
- (cons 'window (third selected-tab)))))))
+ (cons (if (cl-fourth selected-tab) 'browser 'window)
+ (cl-third selected-tab))))))
(defun js--guess-eval-defun-info (pstate)
"Helper function for `js-eval-defun'.
strings making up the class name and NAME is the name of the
function part."
(cond ((and (= (length pstate) 3)
- (eq (js--pitem-type (first pstate)) 'function)
- (= (length (js--pitem-name (first pstate))) 1)
- (consp (js--pitem-type (second pstate))))
+ (eq (js--pitem-type (cl-first pstate)) 'function)
+ (= (length (js--pitem-name (cl-first pstate))) 1)
+ (consp (js--pitem-type (cl-second pstate))))
- (append (js--pitem-name (second pstate))
- (list (first (js--pitem-name (first pstate))))))
+ (append (js--pitem-name (cl-second pstate))
+ (list (cl-first (js--pitem-name (cl-first pstate))))))
((and (= (length pstate) 2)
- (eq (js--pitem-type (first pstate)) 'function))
+ (eq (js--pitem-type (cl-first pstate)) 'function))
(append
- (butlast (js--pitem-name (first pstate)))
- (list (car (last (js--pitem-name (first pstate)))))))
+ (butlast (js--pitem-name (cl-first pstate)))
+ (list (car (last (js--pitem-name (cl-first pstate)))))))
(t (error "Function not a toplevel defun or class member"))))
(with-js
(when (or (null js--js-context)
(js--js-handle-expired-p (cdr js--js-context))
- (ecase (car js--js-context)
- (window (js? (js< (cdr js--js-context) "closed")))
- (browser (not (js? (js< (cdr js--js-context)
- "contentDocument"))))))
+ (pcase (car js--js-context)
+ (`window (js? (js< (cdr js--js-context) "closed")))
+ (`browser (not (js? (js< (cdr js--js-context)
+ "contentDocument"))))
+ (x (error "Unmatched case in js--get-js-context: %S" x))))
(setq js--js-context (js--read-tab "Javascript Context: ")))
js--js-context))
(defun js--js-content-window (context)
(with-js
- (ecase (car context)
- (window (cdr context))
- (browser (js< (cdr context)
- "contentWindow" "wrappedJSObject")))))
+ (pcase (car context)
+ (`window (cdr context))
+ (`browser (js< (cdr context)
+ "contentWindow" "wrappedJSObject"))
+ (x (error "Unmatched case in js--js-content-window: %S" x)))))
(defun js--make-nsilocalfile (path)
(with-js
(path-uri (js! (io-service "newFileURI") path-file)))
(js! (res-prot "setSubstitution") alias path-uri))))
-(defun* js-eval-defun ()
+(cl-defun js-eval-defun ()
"Update a Mozilla tab using the JavaScript defun at point."
(interactive)
(unless (y-or-n-p (format "Send %s to Mozilla? "
(mapconcat #'identity defun-info ".")))
(message "") ; question message lingers until next command
- (return-from js-eval-defun))
+ (cl-return-from js-eval-defun))
(delete-overlay overlay)))
(setq defun-body (buffer-substring-no-properties begin end))
\f
;;; Code:
-(eval-when-compile (require 'cl))
(defgroup pascal nil
"Major mode for editing Pascal source in Emacs."
;;; Code:
-(eval-when-compile (require 'cl))
(defvar font-lock-comment-face)
(defvar font-lock-doc-face)
;; * 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)
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(defgroup server nil
"Emacs running as a server process."
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)
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")
(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.
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))
(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
(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;
;; 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))
;; 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
;;; Code:
(require 'unsafep)
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
;;----------------------------------------------------------------------------
(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
(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 '(> <)))
(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."
;;; Code:
-(eval-when-compile (require 'cl))
(require 'comint)
(require 'pcomplete)
(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)
;;; Requirements and provisions...
(autoload 'mail-position-on-field "sendmail")
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
;;; Constants...
(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...
(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.
(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
(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)
;; (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))))
(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)))
;; 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
(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))))
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(defgroup tar nil
"Simple editing of tar files."
;; 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)))
\f
;;; down to business.
-(defstruct (tar-header
+(cl-defstruct (tar-header
(:constructor nil)
(:type vector)
:named
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.
(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)
(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))
(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
(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.
;; 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)
(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
(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)
;;; Code:
-(eval-when-compile (require 'cl))
-
(defvar tvi970-terminal-map
(let ((map (make-sparse-keymap)))
"Cascading Style Sheets (CSS) editing mode."
:group 'languages)
-(eval-when-compile (require 'cl))
(defun css-extract-keyword-list (res)
(with-temp-buffer
;;; Code:
-(eval-when-compile (require 'cl))
-
(defgroup refill nil
"Refilling paragraphs on changes."
:group 'fill)
"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
;; 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
(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)))
(eval-when-compile
(require 'skeleton)
(require 'outline)
- (require 'cl))
+ (require 'cl-lib))
(defgroup sgml nil
"SGML editing mode."
\f
;; Parsing
-(defstruct (sgml-tag
+(cl-defstruct (sgml-tag
(:constructor sgml-make-tag (type start end name)))
type start end name)
(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
(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)))
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)
(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))
(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))
(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")
(goto-char (1+ (cdr lcon)))
(+ (current-column) sgml-basic-offset)))
- (text
+ (`text
(while (looking-at "</")
(forward-sexp 1)
(skip-chars-forward " \t"))
(+ (current-column)
(* sgml-basic-offset (length context)))))))
- (otherwise
+ (_
(error "Unrecognized context %s" (car lcon)))
))
;; Pacify the byte-compiler
(eval-when-compile
(require 'compare-w)
- (require 'cl)
+ (require 'cl-lib)
(require 'skeleton))
(defvar font-lock-comment-face)
(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)
(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
(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)))
;;; Code:
-(eval-when-compile (require 'tex-mode) (require 'cl))
+(eval-when-compile (require 'tex-mode))
(defvar outline-heading-alist)
(defgroup texinfo nil
;;
;;; Code:
-(eval-when-compile (require 'cl))
(require 'wid-edit)
\f
;;; Customization
+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):
(require 'url-parse)
(require 'url-domsuf)
-(eval-when-compile (require 'cl)) ; defstruct
+(eval-when-compile (require 'cl-lib))
(defgroup url-cookie nil
"URL cookies."
;; 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)
;;; Code:
-(eval-when-compile
- (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'xml)
(require 'url-util)
(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)
"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))
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
(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")
(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))
"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)
(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)
(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
nil)
(507 ; Insufficient storage
nil)
- (otherwise
+ (_
nil)))
(kill-buffer buffer)))
result))
(setq failed t)))
(if failed
(setq searching nil)
- (incf n)))
+ (cl-incf n)))
(substring (car matches) 0 n))))))
(defun url-dav-register-handler (op)
(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
;;; Code:
-(eval-when-compile (require 'cl))
(require 'mailcap)
(require 'url-vars)
(require 'url-parse)
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
;;; 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))
;;; Code:
-(eval-when-compile (require 'cl))
(require 'url-vars)
;; Fixme: support SSH explicitly or via a url-gateway-rlogin-program?
;; 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
;; 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)))
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
+
+(defvar url-callback-arguments)
+(defvar url-callback-function)
+(defvar url-current-object)
+(defvar url-http-after-change-function)
+(defvar url-http-chunked-counter)
+(defvar url-http-chunked-length)
+(defvar url-http-chunked-start)
+(defvar url-http-connection-opened)
+(defvar url-http-content-length)
+(defvar url-http-content-type)
+(defvar url-http-data)
+(defvar url-http-end-of-headers)
(defvar url-http-extra-headers)
-(defvar url-http-target-url)
+(defvar url-http-method)
(defvar url-http-no-retry)
+(defvar url-http-process)
(defvar url-http-proxy)
-(defvar url-http-connection-opened)
+(defvar url-http-response-status)
+(defvar url-http-response-version)
+(defvar url-http-target-url)
+(defvar url-http-transfer-encoding)
+(defvar url-http-end-of-headers)
+(defvar url-show-status)
+
(require 'url-gw)
(require 'url-util)
(require 'url-parse)
(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)))
"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
(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))
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)
(when (url-use-cookies url-http-target-url)
(url-http-handle-cookies))
- (case class
+ (pcase class
;; Classes of response codes
;;
;; 5xx = Server Error
;; 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)
;; 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
;; 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
;; 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
;; 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
;; 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
;; 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
;; `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.
;; 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
;; 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
(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)
;; 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)
(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)
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%%)"
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)
(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)
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
;; 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))
;; 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)
;;; 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)
(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)))))
;;; Code:
-(eval-when-compile (require 'cl))
(require 'url-vars)
(require 'url-parse)
(autoload 'Info-goto-node "info" "" t)
(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)))))
;;; Code:
-(eval-when-compile (require 'cl))
(require 'url-parse)
(require 'url-file)
(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 "")))
(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
(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.
;;; Code:
-(eval-when-compile (require 'cl))
(require 'url-vars)
(defun url-device-type (&optional device)
((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
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'browse-url)
(require 'url-parse)
(defvar url-queue nil)
-(defstruct url-queue
+(cl-defstruct url-queue
url callback cbargs silentp
buffer start-time pre-triggered
inhibit-cookiesp)
(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
(dolist (entry url-queue)
(cond
((url-queue-start-time entry)
- (incf running))
+ (cl-incf running))
((not waiting)
(setq waiting entry))))
(when (and waiting
(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")
;;; Code:
-(eval-when-compile (require 'cl))
(require 'mailcap)
(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."
(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))
;;; Code:
-(eval-when-compile (require 'vc) (require 'cl))
+(eval-when-compile (require 'vc))
;;; Properties of the backend
(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)))
;;; Code:
(eval-when-compile
- (require 'cl)
+ (require 'cl-lib)
(require 'vc) ;; for vc-exec-after
(require 'vc-dir))
`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)
`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
(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->))
;;; 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.
((= 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)))))
(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'.
;; 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
(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
;; - find-file-hook () NOT NEEDED
(eval-when-compile
- (require 'cl)
+ (require 'cl-lib)
(require 'vc)
(require 'vc-dir)
(require 'grep))
(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)
(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))
(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))
"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 ""))))
"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))
(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"
(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
;;; Code:
(eval-when-compile
- (require 'cl)
+ (require 'cl-lib)
(require 'vc)
(require 'vc-dir))
(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->))
(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)))))
;;; Code:
-(eval-when-compile
- (require 'cl))
+(eval-when-compile (require 'cl-lib))
;; Customization Variables (the rest is in vc.el)
(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)
(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)))))))
;;; Code:
-(eval-when-compile (require 'cl) (require 'vc))
+(eval-when-compile (require 'vc))
(defgroup vc-mtn nil
"VC Monotone (mtn) backend."
(if (string-match (car rule) branch)
(setq branch (replace-match (cdr rule) t nil branch))))
(format "Mtn%c%s"
- (case (vc-state file)
- ((up-to-date needs-update) ?-)
- (added ?@)
- (t ?:))
+ (pcase (vc-state file)
+ ((or `up-to-date `needs-update) ?-)
+ (`added ?@)
+ (_ ?:))
branch)))
(defun vc-mtn-register (files &optional _rev _comment)
;;;
(eval-when-compile
- (require 'cl)
+ (require 'cl-lib)
(require 'vc))
(defgroup vc-rcs nil
(goto-char (point-min))
(forward-line (1- (pop insn)))
(setq p (point))
- (case (pop insn)
- (k (setq s (buffer-substring-no-properties
- p (progn (forward-line (car insn))
- (point))))
- (when prda
- (push `(,p . ,(propertize s :vc-rcs-r/d/a prda)) path))
- (delete-region p (point)))
- (i (setq s (car insn))
- (when prda
- (push `(,p . ,(length s)) path))
- (insert s)))))
+ (pcase (pop insn)
+ (`k (setq s (buffer-substring-no-properties
+ p (progn (forward-line (car insn))
+ (point))))
+ (when prda
+ (push `(,p . ,(propertize s :vc-rcs-r/d/a prda)) path))
+ (delete-region p (point)))
+ (`i (setq s (car insn))
+ (when prda
+ (push `(,p . ,(length s)) path))
+ (insert s)))))
;; For the initial revision, setting `:vc-rcs-r/d/a' directly is
;; equivalent to pushing an insert instruction (of the entire buffer
;; contents) onto `path' then erasing the buffer, but less wasteful.
(dolist (insn (cdr (assq :insn meta)))
(goto-char (point-min))
(forward-line (1- (pop insn)))
- (case (pop insn)
- (k (delete-region
- (point) (progn (forward-line (car insn))
- (point))))
- (i (insert (propertize
- (car insn)
- :vc-rcs-r/d/a
- (or prda (setq prda (r/d/a))))))))
+ (pcase (pop insn)
+ (`k (delete-region
+ (point) (progn (forward-line (car insn))
+ (point))))
+ (`i (insert (propertize
+ (car insn)
+ :vc-rcs-r/d/a
+ (or prda (setq prda (r/d/a))))))))
(prog1 (not (string= (if nbls (caar nbls) revision) pre))
(setq pre (cdr (assq 'next meta)))))))))
;; Lastly, for each line, insert at bol nicely-formatted history info.
start (read (current-buffer))
act (read (current-buffer)))
(forward-char 1)
- (push (case cmd
+ (push (pcase cmd
(?d
;; `d' means "delete lines".
;; For Emacs spirit, we use `k' for "kill".
`(,(1+ start) i
,(funcall sub (point) (progn (forward-line act)
(point)))))
- (t (error "Bad command `%c' in `text' for rev `%s'"
+ (_ (error "Bad command `%c' in `text' for rev `%s'"
cmd context)))
acc))
(goto-char (1+ e))
(declare-function diff-setup-whitespace "diff-mode" ())
(eval-when-compile
- (require 'cl)
(require 'dired))
(unless (assoc 'vc-parent-buffer minor-mode-alist)
(defvar dired-backup-overwrite) ; Only in Emacs 20.x this is a custom var
-(eval-when-compile (require 'cl))
(require 'dired)
(autoload 'dired-do-create-files-regexp "dired-aux")
(require 'easymenu)
(require 'custom)
(require 'wid-edit)
-(eval-when-compile (require 'cl))
(defgroup widget-browse nil
"Customization support for browsing widgets."
;;; Code:
-(eval-when-compile
- (require 'cl))
-
-
-(defmacro winner-active-region ()
+(eval-when-compile (require 'cl-lib))
+
+(defun winner-active-region ()
+ (declare (gv-setter (lambda (store)
+ (if (featurep 'xemacs)
+ `(if ,store (zmacs-activate-region)
+ (zmacs-deactivate-region))
+ `(setq mark-active ,store)))))
(if (boundp 'mark-active)
- 'mark-active
- '(region-active-p)))
-
-(defsetf winner-active-region () (store)
- (if (featurep 'xemacs)
- `(if ,store (zmacs-activate-region)
- (zmacs-deactivate-region))
- `(setq mark-active ,store)))
+ mark-active
+ (region-active-p)))
(defalias 'winner-edges
(if (featurep 'xemacs) 'window-pixel-edges 'window-edges))
(defun winner-sorted-window-list ()
(sort (winner-window-list)
(lambda (x y)
- (loop for a in (winner-edges x)
- for b in (winner-edges y)
- while (= a b)
- finally return (< a b)))))
+ (cl-loop for a in (winner-edges x)
+ for b in (winner-edges y)
+ while (= a b)
+ finally return (< a b)))))
(defun winner-win-data ()
;; Essential properties of the windows in the selected frame.
- (loop for win in (winner-sorted-window-list)
- collect (cons (winner-edges win) (window-buffer win))))
+ (cl-loop for win in (winner-sorted-window-list)
+ collect (cons (winner-edges win) (window-buffer win))))
;; This variable is updated with the current window configuration
;; every time it changes.
(let* ((miniwin (minibuffer-window))
(chosen (selected-window))
(minisize (window-height miniwin)))
- (letf (((window-buffer miniwin))
- ((window-point miniwin)))
+ (cl-letf (((window-buffer miniwin))
+ ((window-point miniwin)))
(set-window-configuration winconf))
(cond
((window-live-p chosen) (select-window chosen))
(defun winner-make-point-alist ()
(save-current-buffer
- (loop with alist
- for win in (winner-window-list)
- for entry =
- (or (assq (window-buffer win) alist)
- (car (push (list (set-buffer (window-buffer win))
- (cons (mark t) (winner-active-region)))
- alist)))
- do (push (cons win (window-point win))
- (cddr entry))
- finally return alist)))
+ (cl-loop with alist
+ for win in (winner-window-list)
+ for entry =
+ (or (assq (window-buffer win) alist)
+ (car (push (list (set-buffer (window-buffer win))
+ (cons (mark t) (winner-active-region)))
+ alist)))
+ do (push (cons win (window-point win))
+ (cddr entry))
+ finally return alist)))
(defun winner-get-point (buf win)
;; Consult (and possibly extend) `winner-point-alist'.
(let* ((buffers nil)
(alive
;; Possibly update `winner-point-alist'
- (loop for buf in (mapcar 'cdr (cdr conf))
- for pos = (winner-get-point buf nil)
- if (and pos (not (memq buf buffers)))
- do (push buf buffers)
- collect pos)))
+ (cl-loop for buf in (mapcar 'cdr (cdr conf))
+ for pos = (winner-get-point buf nil)
+ if (and pos (not (memq buf buffers)))
+ do (push buf buffers)
+ collect pos)))
(winner-set-conf (car conf))
(let (xwins) ; to be deleted
;; Restore marks
(save-current-buffer
- (loop for buf in buffers
- for entry = (cadr (assq buf winner-point-alist))
- do (progn (set-buffer buf)
- (set-mark (car entry))
- (setf (winner-active-region) (cdr entry)))))
+ (cl-loop for buf in buffers
+ for entry = (cadr (assq buf winner-point-alist))
+ do (progn (set-buffer buf)
+ (set-mark (car entry))
+ (setf (winner-active-region) (cdr entry)))))
;; Delete windows, whose buffers are dead or boring.
;; Return t if this is still a possible configuration.
(or (null xwins)
(setq winner-pending-undo-ring (winner-ring (selected-frame)))
(setq winner-undo-counter 0)
(setq winner-undone-data (list (winner-win-data))))
- (incf winner-undo-counter) ; starting at 1
+ (cl-incf winner-undo-counter) ; starting at 1
(when (and (winner-undo-this)
(not (window-minibuffer-p (selected-window))))
(message "Winner undo (%d / %d)"
\f
(defun winner-undo-this () ; The heart of winner undo.
- (loop
+ (cl-loop
(cond
((>= winner-undo-counter (ring-length winner-pending-undo-ring))
(message "No further window configuration undo information")
- (return nil))
+ (cl-return nil))
((and ; If possible configuration
(winner-set (ring-ref winner-pending-undo-ring
(let ((data (winner-win-data)))
(and (not (member data winner-undone-data))
(push data winner-undone-data))))
- (return t)) ; .. then everything is fine.
+ (cl-return t)) ; .. then everything is fine.
(t ;; Otherwise, discharge it (and try the next one).
(ring-remove winner-pending-undo-ring winner-undo-counter)))))
(eval-when-compile ; to avoid compiler warnings
(require 'dired)
- (require 'cl)
+ (require 'cl-lib)
(require 'apropos))
(defun woman-mapcan (fn x)
(defun woman2-process-escapes (to &optional numeric)
"Process remaining escape sequences up to marker TO, preserving point.
Optional argument NUMERIC, if non-nil, means the argument is numeric."
- (assert (and (markerp to) (marker-insertion-type to)))
+ (cl-assert (and (markerp to) (marker-insertion-type to)))
;; The first two cases below could be merged (maybe)!
(let ((from (point)))
;; Discard zero width filler character used to hide leading dots
+2012-07-11 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * eshell.el: Use cl-lib.
+
2012-07-03 Chong Yidong <cyd@gnu.org>
* automated/xml-parse-tests.el (xml-parse-tests--bad-data): New.
2012-07-02 Chong Yidong <cyd@gnu.org>
- * automated/xml-parse-tests.el (xml-parse-tests--data): More
- testcases.
+ * automated/xml-parse-tests.el (xml-parse-tests--data):
+ More testcases.
2012-07-01 Chong Yidong <cyd@gnu.org>
;;; Code:
(eval-when-compile
- (require 'cl) ; assert
+ (require 'cl-lib)
(require 'eshell)
(require 'esh-util))
(require 'esh-mode)
(eshell-deftest banner banner-displayed
"Startup banner is displayed at point-min"
- (assert eshell-banner-message)
+ (cl-assert eshell-banner-message)
(let ((msg (eval eshell-banner-message)))
- (assert msg)
+ (cl-assert msg)
(goto-char (point-min))
(looking-at msg)))
projects / emacs.git / commitdiff