((nil . ((tab-width . 8)
(sentence-end-double-space . t)
- (fill-column . 70)
+ (fill-column . 79)
(bug-reference-url-format . "https://debbugs.gnu.org/%s")))
(c-mode . ((c-file-style . "GNU")
(c-noise-macro-names . ("INLINE" "ATTRIBUTE_NO_SANITIZE_UNDEFINED" "UNINIT" "CALLBACK" "ALIGN_STACK"))
# Version control and locks.
*.orig
-*.rej
*.swp
*~
.#*
EMACSOPT = -batch --no-site-file --no-site-lisp
# Extra flags to pass to the byte compiler
-BYTE_COMPILE_EXTRA_FLAGS =
+BYTE_COMPILE_EXTRA_FLAGS = --eval '(setq byte-compile-force-lexical-warnings t)'
+
# For example to not display the undefined function warnings you can use this:
# BYTE_COMPILE_EXTRA_FLAGS = --eval '(setq byte-compile-warnings (quote (not unresolved)))'
# The example above is just for developers, it should not be used by default.
# Set load-prefer-newer for the benefit of the non-bootstrappers.
BYTE_COMPILE_FLAGS = \
- --eval '(setq load-prefer-newer t)' $(BYTE_COMPILE_EXTRA_FLAGS)
+ --eval '(setq load-prefer-newer t byte-compile-force-lexical-warnings t)' $(BYTE_COMPILE_EXTRA_FLAGS)
# Files to compile before others during a bootstrap. This is done to
# speed up the bootstrap process. They're ordered by size, so we use
# Compile all the Elisp files that need it. Beware: it approximates
# 'no-byte-compile', so watch out for false-positives!
compile-main: gen-lisp compile-clean
- @(cd $(lisp) && \
+ @(cd $(lisp) && \
els=`echo "${SUBDIRS_REL} " | sed -e 's|/\./|/|g' -e 's|/\. | |g' -e 's| |/*.el |g'`; \
for el in ${MAIN_FIRST} $$els; do \
test -f $$el || continue; \
;; to treat the distinction between a single table and a list of tables.
(cond
((consp tables) tables)
- ((vectorp tables) (list tables))
+ ((abbrev-table-p tables) (list tables))
+ (tables (signal 'wrong-type-argument (list 'abbrev-table-p tables)))
(t
(let ((tables (if (listp local-abbrev-table)
(append local-abbrev-table
(require 'calc-macs)
-;;; Find out how many 9s in 9.9999... will give distinct Emacs floats,
-;;; then back off by one.
-
+;; Find out how many 9s in 9.9999... will give distinct Emacs floats,
+;; then back off by one.
(defvar math-emacs-precision
(let* ((n 1)
(x 9)
(1- n))
"The number of digits in an Emacs float.")
-;;; Find the largest power of 10 which is an Emacs float,
-;;; then back off by one so that any float d.dddd...eN
-;;; is an Emacs float, for acceptable d.dddd....
+;; Find the largest power of 10 which is an Emacs float,
+;; then back off by one so that any float d.dddd...eN
+;; is an Emacs float, for acceptable d.dddd....
(defvar math-largest-emacs-expt
(let ((x 1)
(message "Angles measured in radians")))
-;;; Compute the integer square-root floor(sqrt(A)). A > 0. [I I] [Public]
-;;; This method takes advantage of the fact that Newton's method starting
-;;; with an overestimate always works, even using truncating integer division!
+;; Compute the integer square-root floor(sqrt(A)). A > 0. [I I] [Public]
+;; This method takes advantage of the fact that Newton's method starting
+;; with an overestimate always works, even using truncating integer division!
(defun math-isqrt (a)
(cond ((Math-zerop a) a)
((not (natnump a))
(let ((overflow-error '(error "Specified time is not representable")))
(if (equal err overflow-error)
(signal (car err) (cdr err))
- (condition-case err
+ (condition-case-unless-debug err
(encode-time (parse-time-string
- (timezone-make-date-arpa-standard date)))
+ (timezone-make-date-arpa-standard date)))
(error
(if (equal err overflow-error)
(signal (car err) (cdr err))
(defun completion-before-command ()
(funcall (or (and (symbolp this-command)
(get this-command 'completion-function))
- 'use-completion-under-or-before-point)))
+ #'use-completion-under-or-before-point)))
\f
;; Lisp mode diffs.
-;;; composite.el --- support character composition
+;;; composite.el --- support character composition -*- lexical-binding:t -*-
;; Copyright (C) 2001-2019 Free Software Foundation, Inc.
(as (lglyph-ascent glyph))
(de (lglyph-descent glyph))
(ce (/ (+ lb rb) 2))
- (w (lglyph-width glyph))
xoff yoff)
(cond
((and class (>= class 200) (<= class 240))
(defun compose-gstring-for-dotted-circle (gstring direction)
(let* ((dc (lgstring-glyph gstring 0)) ; glyph of dotted-circle
- (dc-id (lglyph-code dc))
(fc (lgstring-glyph gstring 1)) ; glyph of the following char
- (fc-id (lglyph-code fc))
(gstr (and nil (font-shape-gstring gstring direction))))
(if (and gstr
(or (= (lgstring-glyph-len gstr) 1)
(goto-char pos)
(funcall electric-pair-inhibit-predicate
last-command-event)))))
- (save-excursion (electric-pair--insert pair)))))
+ (let ((electric-indent--destination (point-marker)))
+ (save-excursion (electric-pair--insert pair))))))
(_
(when (and (if (functionp electric-pair-open-newline-between-pairs)
(funcall electric-pair-open-newline-between-pairs)
not try to reindent lines. It is normally better to make the major
mode set `electric-indent-inhibit', but this can be used as a workaround.")
+(defun electric-indent--inhibited-p ()
+ (or electric-indent-inhibit
+ (memq indent-line-function
+ electric-indent-functions-without-reindent)))
+
+(defvar electric-indent--destination nil
+ "If non-nil, position to which point will be later restored.")
+
(defun electric-indent-post-self-insert-function ()
"Function that `electric-indent-mode' adds to `post-self-insert-hook'.
This indents if the hook `electric-indent-functions' returns non-nil,
(when at-newline
(let ((before (copy-marker (1- pos) t)))
(save-excursion
- (unless
- (or (memq indent-line-function
- electric-indent-functions-without-reindent)
- electric-indent-inhibit)
+ (unless (electric-indent--inhibited-p)
;; Don't reindent the previous line if the
;; indentation function is not a real one.
(goto-char before)
(condition-case-unless-debug ()
(indent-according-to-mode)
- (error (throw 'indent-error nil)))
- ;; The goal here will be to remove the trailing
- ;; whitespace after reindentation of the previous line
- ;; because that may have (re)introduced it.
- (goto-char before)
- ;; We were at EOL in marker `before' before the call
- ;; to `indent-according-to-mode' but after we may
- ;; not be (Bug#15767).
- (when (and (eolp))
- (delete-horizontal-space t))))))
- (unless (and electric-indent-inhibit
+ (error (throw 'indent-error nil))))
+ ;; The goal here will be to remove the trailing
+ ;; whitespace after reindentation of the previous line
+ ;; because that may have (re)introduced it.
+ (goto-char before)
+ ;; We were at EOL in marker `before' before the call
+ ;; to `indent-according-to-mode' but after we may
+ ;; not be (Bug#15767).
+ (when (and (eolp)
+ ;; Don't delete "trailing space" before point!
+ (not (and electric-indent--destination
+ (= (point) electric-indent--destination))))
+ (delete-horizontal-space t)))))
+ (unless (and (electric-indent--inhibited-p)
(not at-newline))
(condition-case-unless-debug ()
(indent-according-to-mode)
lexenv reserved-csts)
;; OUTPUT-TYPE advises about how form is expected to be used:
;; 'eval or nil -> a single form,
- ;; 'progn or t -> a list of forms,
+ ;; t -> a list of forms,
;; 'lambda -> body of a lambda,
;; 'file -> used at file-level.
(let ((byte-compile--for-effect for-effect)
;; a single atom, but that causes confusion if the docstring
;; uses the (file . pos) syntax. Besides, now that we have
;; the Lisp_Compiled type, the compiled form is faster.
- ;; eval -> atom, quote or (function atom atom atom)
- ;; progn -> as <<same-as-eval>> or (progn <<same-as-eval>> atom)
+ ;; eval/nil-> atom, quote or (function atom atom atom)
+ ;; t -> as <<same-as-eval>> or (progn <<same-as-eval>> atom)
;; file -> as progn, but takes both quotes and atoms, and longer forms.
- (let (rest
- (maycall (not (eq output-type 'lambda))) ; t if we may make a funcall.
- tmp body)
+ (let (body tmp)
(cond
;; #### This should be split out into byte-compile-nontrivial-function-p.
((or (eq output-type 'lambda)
(nthcdr (if (eq output-type 'file) 50 8) byte-compile-output)
(assq 'TAG byte-compile-output) ; Not necessary, but speeds up a bit.
(not (setq tmp (assq 'byte-return byte-compile-output)))
- (progn
- (setq rest (nreverse
- (cdr (memq tmp (reverse byte-compile-output)))))
+ (let ((maycall t) ; t if we may make a funcall.
+ (rest (nreverse
+ (cdr (memq tmp (reverse byte-compile-output))))))
(while
(cond
((memq (car (car rest)) '(byte-varref byte-constant))
(or (consp tmp)
(and (symbolp tmp)
(not (macroexp--const-symbol-p tmp)))))
- (if maycall
+ (if maycall ;;Why? --Stef
(setq body (cons (list 'quote tmp) body)))
(setq body (cons tmp body))))
((and maycall
(null (nthcdr 3 rest))
(setq tmp (get (car (car rest)) 'byte-opcode-invert))
(or (null (cdr rest))
- (and (memq output-type '(file progn t))
+ (and (memq output-type '(file t))
(cdr (cdr rest))
(eq (car (nth 1 rest)) 'byte-discard)
(progn (setq rest (cdr rest)) t))))
(cond
((characterp end) (setq end (char-to-string end)))
((zerop (length end)) (setq end "\n")))
- (push (cons start end) normalized)))
+ (push (list start end) normalized)))
(nreverse normalized)))
-(defun generic-set-comment-syntax (st comment-list)
- "Set up comment functionality for generic mode."
- (let ((chars nil)
- (comstyles)
- (comstyle "")
- (comment-start nil))
-
- ;; Go through all the comments.
- (pcase-dolist (`(,start . ,end) comment-list)
- (let ((comstyle
- ;; Reuse comstyles if necessary.
- (or (cdr (assoc start comstyles))
- (cdr (assoc end comstyles))
- ;; Otherwise, use a style not yet in use.
- (if (not (rassoc "" comstyles)) "")
- (if (not (rassoc "b" comstyles)) "b")
- "c")))
- (push (cons start comstyle) comstyles)
- (push (cons end comstyle) comstyles)
-
- ;; Setup the syntax table.
- (if (= (length start) 1)
- (modify-syntax-entry (aref start 0)
- (concat "< " comstyle) st)
- (let ((c0 (aref start 0)) (c1 (aref start 1)))
- ;; Store the relevant info but don't update yet.
- (push (cons c0 (concat (cdr (assoc c0 chars)) "1")) chars)
- (push (cons c1 (concat (cdr (assoc c1 chars))
- (concat "2" comstyle))) chars)))
- (if (= (length end) 1)
- (modify-syntax-entry (aref end 0)
- (concat ">" comstyle) st)
- (let ((c0 (aref end 0)) (c1 (aref end 1)))
- ;; Store the relevant info but don't update yet.
- (push (cons c0 (concat (cdr (assoc c0 chars))
- (concat "3" comstyle))) chars)
- (push (cons c1 (concat (cdr (assoc c1 chars)) "4")) chars)))))
-
- ;; Process the chars that were part of a 2-char comment marker
- (with-syntax-table st ;For `char-syntax'.
- (dolist (cs (nreverse chars))
- (modify-syntax-entry (car cs)
- (concat (char-to-string (char-syntax (car cs)))
- " " (cdr cs))
- st)))))
-
-(defun generic-set-comment-vars (comment-list)
- (when comment-list
- (setq-local comment-start (caar comment-list))
- (setq-local comment-end
- (let ((end (cdar comment-list)))
- (if (string-equal end "\n") "" end)))
- (setq-local comment-start-skip
- (concat (regexp-opt (mapcar #'car comment-list))
- "+[ \t]*"))
- (setq-local comment-end-skip
- (concat "[ \t]*" (regexp-opt (mapcar #'cdr comment-list))))))
-
(defun generic-mode-set-comments (comment-list)
"Set up comment functionality for generic mode."
- (let ((st (make-syntax-table))
- (comment-list (generic--normalize-comments comment-list)))
- (generic-set-comment-syntax st comment-list)
- (generic-set-comment-vars comment-list)
+ (let ((st (make-syntax-table)))
+ (comment-set-syntax st comment-list)
(set-syntax-table st)))
(defun generic-bracket-support ()
(eval-when-compile
(concat "(\\(" lisp-mode-symbol-regexp "\\)\\_>"))
limit t)
+ ;; FIXME: If it's indented like `defun' then highlight the first arg!
(let ((sym (intern-soft (match-string 1))))
(when (or (special-form-p sym)
(and (macrop sym)
(insert (format "Error while verifying signature %s:\n" sig-file)))
(insert "\nCommand output:\n" (epg-context-error-output context))))))
-(defmacro package--with-work-buffer (location file &rest body)
- "Run BODY in a buffer containing the contents of FILE at LOCATION.
-LOCATION is the base location of a package archive, and should be
-one of the URLs (or file names) specified in `package-archives'.
-FILE is the name of a file relative to that base location.
-
-This macro retrieves FILE from LOCATION into a temporary buffer,
-and evaluates BODY while that buffer is current. This work
-buffer is killed afterwards. Return the last value in BODY."
- (declare (indent 2) (debug t)
- (obsolete package--with-response-buffer "25.1"))
- `(with-temp-buffer
- (if (string-match-p "\\`https?:" ,location)
- (url-insert-file-contents (concat ,location ,file))
- (unless (file-name-absolute-p ,location)
- (error "Archive location %s is not an absolute file name"
- ,location))
- (insert-file-contents (expand-file-name ,file ,location)))
- ,@body))
-
(cl-defmacro package--with-response-buffer (url &rest body &key async file error-form noerror &allow-other-keys)
"Access URL and run BODY in a buffer containing the response.
Point is after the headers when BODY runs.
(declare-function get-edebug-spec "edebug" (symbol))
(declare-function edebug-match "edebug" (cursor specs))
+(defun pcase--get-macroexpander (s)
+ "Return the macroexpander for pcase pattern head S, or nil"
+ (let ((em (assoc s (assq :pcase-macroexpander macroexpand-all-environment))))
+ (if em (cdr em)
+ (get s 'pcase-macroexpander))))
+
+(defmacro pcase-macrolet (bindings &rest body)
+ (let ((new-macros (if (consp (car-safe bindings))
+ (mapcar (lambda (binding)
+ (cons (car binding)
+ (eval (if (cddr binding)
+ `(lambda ,(cadr binding)
+ ,@(cddr binding))
+ (cadr binding))
+ lexical-binding)))
+ bindings)
+ (eval bindings lexical-binding)))
+ (old-pme (assq :pcase-macroexpander macroexpand-all-environment)))
+ (macroexpand-all (macroexp-progn body)
+ (cons (cons :pcase-macroexpander
+ (append new-macros old-pme))
+ macroexpand-all-environment))))
+
(defun pcase--edebug-match-macro (cursor)
(let (specs)
(mapatoms
(lambda (s)
- (let ((m (get s 'pcase-macroexpander)))
+ (let ((m (pcase--get-macroexpander s)))
(when (and m (get-edebug-spec m))
(push (cons (symbol-name s) (get-edebug-spec m))
specs)))))
(let (more)
;; Collect all the extensions.
(mapatoms (lambda (symbol)
- (let ((me (get symbol 'pcase-macroexpander)))
+ (let ((me (pcase--get-macroexpander symbol)))
(when me
(push (cons symbol me)
more)))))
((eq head 'let) `(let ,(pcase--macroexpand (cadr pat)) ,@(cddr pat)))
((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat))))
(t
- (let* ((expander (get head 'pcase-macroexpander))
+ (let* ((expander (pcase--get-macroexpander head))
(npat (if expander (apply expander (cdr pat)))))
(if (null npat)
(error (if expander
(completion-regexp-list nil)
(open (cond ((stringp paren) paren) (paren "\\(")))
(sorted-strings (delete-dups
- (sort (copy-sequence strings) 'string-lessp)))
+ (sort (copy-sequence strings) #'string-lessp)))
(re
(cond
;; No strings: return an unmatchable regexp.
;; (exp (exp (or "+" "*" "=" ..) exp)).
;; Basically, make it EBNF (except for the specification of a separator in
;; the repetition, maybe).
- (let* ((nts (mapcar 'car bnf)) ;Non-terminals.
+ (let* ((nts (mapcar #'car bnf)) ;Non-terminals.
(first-ops-table ())
(last-ops-table ())
(first-nts-table ())
(push resolver precs))
(t (error "Unknown resolver %S" resolver))))
(apply #'smie-merge-prec2s over
- (mapcar 'smie-precs->prec2 precs))))
+ (mapcar #'smie-precs->prec2 precs))))
again)
(dolist (rules bnf)
(let ((nt (car rules))
res))
cycle)))
(mapconcat
- (lambda (elems) (mapconcat 'identity elems "="))
+ (lambda (elems) (mapconcat #'identity elems "="))
(append names (list (car names)))
" < ")))
;; Then eliminate trivial constraints iteratively.
(let ((i 0))
(while csts
- (let ((rhvs (mapcar 'cdr csts))
+ (let ((rhvs (mapcar #'cdr csts))
(progress nil))
(dolist (cst csts)
(unless (memq (car cst) rhvs)
;; desirable that viper-pre-command-sentinel is the last hook and
;; viper-post-command-sentinel is the first hook.
- (remove-hook 'post-command-hook 'viper-post-command-sentinel)
- (add-hook 'post-command-hook 'viper-post-command-sentinel)
- (remove-hook 'pre-command-hook 'viper-pre-command-sentinel)
- (add-hook 'pre-command-hook 'viper-pre-command-sentinel t)
+ (remove-hook 'post-command-hook #'viper-post-command-sentinel)
+ (add-hook 'post-command-hook #'viper-post-command-sentinel)
+ (remove-hook 'pre-command-hook #'viper-pre-command-sentinel)
+ (add-hook 'pre-command-hook #'viper-pre-command-sentinel t)
;; These hooks will be added back if switching to insert/replace mode
(remove-hook 'viper-post-command-hooks
- 'viper-insert-state-post-command-sentinel 'local)
+ #'viper-insert-state-post-command-sentinel 'local)
(remove-hook 'viper-pre-command-hooks
- 'viper-insert-state-pre-command-sentinel 'local)
+ #'viper-insert-state-pre-command-sentinel 'local)
(setq viper-intermediate-command nil)
(cond ((eq new-state 'vi-state)
(cond ((member viper-current-state '(insert-state replace-state))
(viper-move-marker-locally
'viper-last-posn-while-in-insert-state (point))
(add-hook 'viper-post-command-hooks
- 'viper-insert-state-post-command-sentinel t 'local)
+ #'viper-insert-state-post-command-sentinel t 'local)
(add-hook 'viper-pre-command-hooks
- 'viper-insert-state-pre-command-sentinel t 'local))
+ #'viper-insert-state-pre-command-sentinel t 'local))
) ; outermost cond
;; Nothing needs to be done to switch to emacs mode! Just set some
;; it is an error.
(progn
;; new com is (CHAR . OLDCOM)
- (if (viper-memq-char char '(?# ?\")) (user-error viper-ViperBell))
+ (if (viper-memq-char char '(?# ?\")) (viper--user-error))
(setq com (cons char com))
(setq cont nil))
;; If com is nil we set com as char, and read more. Again, if char is
(let ((reg (read-char)))
(if (viper-valid-register reg)
(setq viper-use-register reg)
- (user-error viper-ViperBell))
+ (viper--user-error))
(setq char (read-char))))
(t
(setq com char)
(viper-regsuffix-command-p char)
(viper= char ?!) ; bang command
(viper= char ?g) ; the gg command (like G0)
- (user-error viper-ViperBell))
+ (viper--user-error))
(setq cmd-to-exec-at-end
(viper-exec-form-in-vi
`(key-binding (char-to-string ,char)))))
((equal com '(?= . ?=)) (viper-line (cons value ?=)))
;; gg acts as G0
((equal (car com) ?g) (viper-goto-line 0))
- (t (user-error viper-ViperBell)))))
+ (t (viper--user-error)))))
(if cmd-to-exec-at-end
(progn
(setq viper-intermediate-command 'viper-exec-buffer-search)
(viper-search viper-s-string viper-s-forward 1))
-(defvar viper-exec-array (make-vector 128 nil))
+(defvar viper-exec-array
+ (let ((a (make-vector 128 nil)))
-;; Using a dispatch array allows adding functions like buffer search
-;; without affecting other functions. Buffer search can now be bound
-;; to any character.
+ ;; Using a dispatch array allows adding functions like buffer search
+ ;; without affecting other functions. Buffer search can now be bound
+ ;; to any character.
-(aset viper-exec-array ?c 'viper-exec-change)
-(aset viper-exec-array ?C 'viper-exec-Change)
-(aset viper-exec-array ?d 'viper-exec-delete)
-(aset viper-exec-array ?D 'viper-exec-Delete)
-(aset viper-exec-array ?y 'viper-exec-yank)
-(aset viper-exec-array ?Y 'viper-exec-Yank)
-(aset viper-exec-array ?r 'viper-exec-dummy)
-(aset viper-exec-array ?! 'viper-exec-bang)
-(aset viper-exec-array ?< 'viper-exec-shift)
-(aset viper-exec-array ?> 'viper-exec-shift)
-(aset viper-exec-array ?= 'viper-exec-equals)
+ (aset a ?c 'viper-exec-change)
+ (aset a ?C 'viper-exec-Change)
+ (aset a ?d 'viper-exec-delete)
+ (aset a ?D 'viper-exec-Delete)
+ (aset a ?y 'viper-exec-yank)
+ (aset a ?Y 'viper-exec-Yank)
+ (aset a ?r 'viper-exec-dummy)
+ (aset a ?! 'viper-exec-bang)
+ (aset a ?< 'viper-exec-shift)
+ (aset a ?> 'viper-exec-shift)
+ (aset a ?= 'viper-exec-equals)
+ a))
(defun viper-undo-sentinel (beg end length)
(run-hook-with-args 'viper-undo-functions beg end length))
-(add-hook 'after-change-functions 'viper-undo-sentinel)
+(add-hook 'after-change-functions #'viper-undo-sentinel)
;; Hook used in viper-undo
(defun viper-after-change-undo-hook (beg end _len)
;; some other hooks may be changing various text properties in
;; the buffer in response to 'undo'; so remove this hook to avoid
;; its repeated invocation
- (remove-hook 'viper-undo-functions 'viper-after-change-undo-hook 'local)
+ (remove-hook 'viper-undo-functions #'viper-after-change-undo-hook 'local)
))
(defun viper-undo ()
undo-beg-posn undo-end-posn)
;; the viper-after-change-undo-hook removes itself after the 1st invocation
- (add-hook 'viper-undo-functions 'viper-after-change-undo-hook nil 'local)
+ (add-hook 'viper-undo-functions #'viper-after-change-undo-hook nil 'local)
(undo-start)
(undo-more 2)
;;; Minibuffer business
(defsubst viper-set-minibuffer-style ()
- (add-hook 'minibuffer-setup-hook 'viper-minibuffer-setup-sentinel)
- (add-hook 'post-command-hook 'viper-minibuffer-post-command-hook))
+ (add-hook 'minibuffer-setup-hook #'viper-minibuffer-setup-sentinel)
+ (add-hook 'post-command-hook #'viper-minibuffer-post-command-hook))
(defun viper-minibuffer-setup-sentinel ()
viper-sitting-in-replace t
viper-replace-chars-to-delete 0)
(add-hook
- 'viper-after-change-functions 'viper-replace-mode-spy-after t 'local)
+ 'viper-after-change-functions #'viper-replace-mode-spy-after t 'local)
(add-hook
- 'viper-before-change-functions 'viper-replace-mode-spy-before t 'local)
+ 'viper-before-change-functions #'viper-replace-mode-spy-before t 'local)
;; this will get added repeatedly, but no harm
- (add-hook 'after-change-functions 'viper-after-change-sentinel t)
- (add-hook 'before-change-functions 'viper-before-change-sentinel t)
+ (add-hook 'after-change-functions #'viper-after-change-sentinel t)
+ (add-hook 'before-change-functions #'viper-before-change-sentinel t)
(viper-move-marker-locally
'viper-last-posn-in-replace-region (viper-replace-start))
(add-hook
- 'viper-post-command-hooks 'viper-replace-state-post-command-sentinel
+ 'viper-post-command-hooks #'viper-replace-state-post-command-sentinel
t 'local)
(add-hook
- 'viper-pre-command-hooks 'viper-replace-state-pre-command-sentinel t 'local)
+ 'viper-pre-command-hooks #'viper-replace-state-pre-command-sentinel t 'local)
;; guard against a smarty who switched from R-replace to normal replace
(remove-hook
- 'viper-post-command-hooks 'viper-R-state-post-command-sentinel 'local)
+ 'viper-post-command-hooks #'viper-R-state-post-command-sentinel 'local)
(if overwrite-mode (overwrite-mode -1))
)
;; Don't delete anything if current point is past the end of the overlay.
(defun viper-finish-change ()
(remove-hook
- 'viper-after-change-functions 'viper-replace-mode-spy-after 'local)
+ 'viper-after-change-functions #'viper-replace-mode-spy-after 'local)
(remove-hook
- 'viper-before-change-functions 'viper-replace-mode-spy-before 'local)
+ 'viper-before-change-functions #'viper-replace-mode-spy-before 'local)
(remove-hook
- 'viper-post-command-hooks 'viper-replace-state-post-command-sentinel 'local)
+ 'viper-post-command-hooks #'viper-replace-state-post-command-sentinel 'local)
(remove-hook
- 'viper-pre-command-hooks 'viper-replace-state-pre-command-sentinel 'local)
+ 'viper-pre-command-hooks #'viper-replace-state-pre-command-sentinel 'local)
(viper-restore-cursor-color 'after-replace-mode)
(setq viper-sitting-in-replace nil) ; just in case we'll need to know it
(save-excursion
(defun viper-finish-R-mode ()
(remove-hook
- 'viper-post-command-hooks 'viper-R-state-post-command-sentinel 'local)
+ 'viper-post-command-hooks #'viper-R-state-post-command-sentinel 'local)
(remove-hook
- 'viper-pre-command-hooks 'viper-replace-state-pre-command-sentinel 'local)
+ 'viper-pre-command-hooks #'viper-replace-state-pre-command-sentinel 'local)
(viper-downgrade-to-insert))
(defun viper-start-R-mode ()
;; Leave arg as 1, not t: XEmacs insists that it must be a pos number
(overwrite-mode 1)
(add-hook
- 'viper-post-command-hooks 'viper-R-state-post-command-sentinel t 'local)
+ 'viper-post-command-hooks #'viper-R-state-post-command-sentinel t 'local)
(add-hook
- 'viper-pre-command-hooks 'viper-replace-state-pre-command-sentinel t 'local)
+ 'viper-pre-command-hooks #'viper-replace-state-pre-command-sentinel t 'local)
;; guard against a smarty who switched from R-replace to normal replace
(remove-hook
- 'viper-post-command-hooks 'viper-replace-state-post-command-sentinel 'local)
+ 'viper-post-command-hooks #'viper-replace-state-post-command-sentinel 'local)
)
;; the forward motion before the 'viper-execute-com', but, of
;; course, 'dl' doesn't work on an empty line, so we have to
;; catch that condition before 'viper-execute-com'
- (if (and (eolp) (bolp)) (user-error viper-ViperBell) (forward-char val))
+ (if (and (eolp) (bolp)) (viper--user-error) (forward-char val))
(if com (viper-execute-com 'viper-forward-char val com))
- (if (eolp) (progn (backward-char 1) (user-error viper-ViperBell))))
+ (if (eolp) (progn (backward-char 1) (viper--user-error))))
(forward-char val)
(if com (viper-execute-com 'viper-forward-char val com)))))
(if com (viper-move-marker-locally 'viper-com-point (point)))
(if viper-ex-style-motion
(progn
- (if (bolp) (user-error viper-ViperBell) (backward-char val))
+ (if (bolp) (viper--user-error) (backward-char val))
(if com (viper-execute-com 'viper-backward-char val com)))
(backward-char val)
(if com (viper-execute-com 'viper-backward-char val com)))))
(if com (viper-execute-com 'viper-goto-col val com))
(save-excursion
(end-of-line)
- (if (> val (current-column)) (user-error viper-ViperBell)))
+ (if (> val (current-column)) (viper--user-error)))
))
;; If FORWARD then search is forward, otherwise backward. OFFSET is used to
;; adjust point after search.
(defun viper-find-char (arg char forward offset)
- (or (char-or-string-p char) (user-error viper-ViperBell))
+ (or (char-or-string-p char) (viper--user-error))
(let ((arg (if forward arg (- arg)))
(cmd (if (eq viper-intermediate-command 'viper-repeat)
(nth 5 viper-d-com)
(if com (viper-move-marker-locally 'viper-com-point (point)))
(backward-sexp 1)
(if com (viper-execute-com 'viper-paren-match nil com)))
- (t (user-error viper-ViperBell))))))
+ (t (viper--user-error))))))
(defun viper-toggle-parse-sexp-ignore-comments ()
(interactive)
(let ((reg viper-use-register))
(setq viper-use-register nil)
(error viper-EmptyRegister reg))
- (user-error viper-ViperBell)))
+ (viper--user-error)))
(setq viper-use-register nil)
(if (viper-end-with-a-newline-p text)
(progn
(let ((reg viper-use-register))
(setq viper-use-register nil)
(error viper-EmptyRegister reg))
- (user-error viper-ViperBell)))
+ (viper--user-error)))
(setq viper-use-register nil)
(if (viper-end-with-a-newline-p text) (beginning-of-line))
(viper-set-destructive-command
(> val (viper-chars-in-region (point) (viper-line-pos 'end))))
(setq val (viper-chars-in-region (point) (viper-line-pos 'end))))
(if (and viper-ex-style-motion (eolp))
- (if (bolp) (user-error viper-ViperBell) (setq val 0))) ; not bol---simply back 1 ch
+ (if (bolp) (viper--user-error) (setq val 0))) ; not bol---simply back 1 ch
(save-excursion
(viper-forward-char-carefully val)
(setq end-del-pos (point)))
((viper= char ?,) (viper-cycle-through-mark-ring))
((viper= char ?^) (push-mark viper-saved-mark t t))
((viper= char ?D) (mark-defun))
- (t (user-error viper-ViperBell))
+ (t (viper--user-error))
)))
;; Algorithm: If first invocation of this command save mark on ring, goto
(switch-to-buffer buff)
(goto-char viper-com-point)
(viper-change-state-to-vi)
- (user-error viper-ViperBell)))))
+ (viper--user-error)))))
((and (not skip-white) (viper= char ?`))
(if com (viper-move-marker-locally 'viper-com-point (point)))
(if (and (viper-same-line (point) viper-last-jump)
(read-string "[Hit return to confirm] ")
(quit
(save-excursion (kill-buffer " *delete text*"))
- (user-error viper-ViperBell)))
+ (viper--user-error)))
(save-excursion (kill-buffer " *delete text*")))
(if ex-buffer
(cond ((viper-valid-register ex-buffer '(Letter))
(define-obsolete-function-alias 'viper-iconify
'iconify-or-deiconify-frame "27.1")
+(defun viper--user-error () (user-error "Viper bell"))
+(defun viper--user-error () (user-error "Viper bell"))
;; CHAR is supposed to be a char or an integer (positive or negative)
;; LIST is a list of chars, nil, and negative numbers
((when (boundp 'erc-track-when-inactive)
(if erc-track-when-inactive
(progn
- (add-hook 'window-configuration-change-hook 'erc-user-is-active)
- (add-hook 'erc-send-completed-hook 'erc-user-is-active)
- (add-hook 'erc-server-001-functions 'erc-user-is-active))
+ (add-hook 'window-configuration-change-hook #'erc-user-is-active)
+ (add-hook 'erc-send-completed-hook #'erc-user-is-active)
+ (add-hook 'erc-server-001-functions #'erc-user-is-active))
(erc-track-add-to-mode-line erc-track-position-in-mode-line)
(erc-update-mode-line)
(add-hook 'window-configuration-change-hook
- 'erc-window-configuration-change)
- (add-hook 'erc-insert-post-hook 'erc-track-modified-channels)
- (add-hook 'erc-disconnected-hook 'erc-modified-channels-update))
+ #'erc-window-configuration-change)
+ (add-hook 'erc-insert-post-hook #'erc-track-modified-channels)
+ (add-hook 'erc-disconnected-hook #'erc-modified-channels-update))
;; enable the tracking keybindings
- (add-hook 'erc-connect-pre-hook 'erc-track-minor-mode-maybe)
+ (add-hook 'erc-connect-pre-hook #'erc-track-minor-mode-maybe)
(erc-track-minor-mode-maybe)))
;; Disable:
((when (boundp 'erc-track-when-inactive)
(if erc-track-when-inactive
(progn
(remove-hook 'window-configuration-change-hook
- 'erc-user-is-active)
- (remove-hook 'erc-send-completed-hook 'erc-user-is-active)
- (remove-hook 'erc-server-001-functions 'erc-user-is-active)
- (remove-hook 'erc-timer-hook 'erc-user-is-active))
+ #'erc-user-is-active)
+ (remove-hook 'erc-send-completed-hook #'erc-user-is-active)
+ (remove-hook 'erc-server-001-functions #'erc-user-is-active)
+ ;; FIXME: Never added!?
+ (remove-hook 'erc-timer-hook #'erc-user-is-active))
(remove-hook 'window-configuration-change-hook
- 'erc-window-configuration-change)
- (remove-hook 'erc-disconnected-hook 'erc-modified-channels-update)
- (remove-hook 'erc-insert-post-hook 'erc-track-modified-channels))
+ #'erc-window-configuration-change)
+ (remove-hook 'erc-disconnected-hook #'erc-modified-channels-update)
+ (remove-hook 'erc-insert-post-hook #'erc-track-modified-channels))
;; disable the tracking keybindings
(remove-hook 'erc-connect-pre-hook 'erc-track-minor-mode-maybe)
(when erc-track-minor-mode
;; obsolete, and when it's finally removed, this binding should
;; also be removed.
(with-suppressed-warnings ((lexical str))
- (defvar str))
+ (defvar str)) ;FIXME: Obey the "erc-" prefix convention.
(let ((str input)
(erc-insert-this t)
(erc-send-this t)
(setq m (cdr m))))
l)
(define-obsolete-function-alias
- 'eshell-uniqify-list
- 'eshell-uniquify-list "27.1")
+ 'eshell-uniqify-list #'eshell-uniquify-list "27.1")
(defun eshell-stringify (object)
"Convert OBJECT into a string value."
(defsubst eshell-stringify-list (args)
"Convert each element of ARGS into a string value."
- (mapcar 'eshell-stringify args))
+ (mapcar #'eshell-stringify args))
(defsubst eshell-flatten-and-stringify (&rest args)
"Flatten and stringify all of the ARGS into a single string."
- (mapconcat 'eshell-stringify (flatten-tree args) " "))
+ (mapconcat #'eshell-stringify (flatten-tree args) " "))
(defsubst eshell-directory-files (regexp &optional directory)
"Return a list of files in the given DIRECTORY matching REGEXP."
(defsubst eshell-copy-environment ()
"Return an unrelated copy of `process-environment'."
- (mapcar 'concat process-environment))
+ (mapcar #'concat process-environment))
(defun eshell-subgroups (groupsym)
"Return all of the subgroups of GROUPSYM."
;; `follow-mode'.
;;
;; Example:
-;; (add-hook 'follow-mode-hook 'my-follow-mode-hook)
+;; (add-hook 'follow-mode-hook #'my-follow-mode-hook)
;;
;; (defun my-follow-mode-hook ()
;; (define-key follow-mode-map "\C-ca" 'your-favorite-function)
:group 'follow
:set (lambda (symbol value)
(if value
- (add-hook 'find-file-hook 'follow-find-file-hook t)
- (remove-hook 'find-file-hook 'follow-find-file-hook))
+ (add-hook 'find-file-hook #'follow-find-file-hook t)
+ (remove-hook 'find-file-hook #'follow-find-file-hook))
(set-default symbol value)))
(defcustom follow-hide-ghost-cursors t ; Maybe this should be nil.
(defsubst follow-debug-message (&rest args)
"Like `message', but only active when `follow-debug' is non-nil."
(if (and (boundp 'follow-debug) follow-debug)
- (apply 'message args)))
+ (apply #'message args)))
;;; Cache
:keymap follow-mode-map
(if follow-mode
(progn
- (add-hook 'compilation-filter-hook 'follow-align-compilation-windows t t)
- (add-function :before pre-redisplay-function 'follow-pre-redisplay-function)
- (add-hook 'window-size-change-functions 'follow-window-size-change t)
- (add-hook 'after-change-functions 'follow-after-change nil t)
- (add-hook 'isearch-update-post-hook 'follow-post-command-hook nil t)
- (add-hook 'replace-update-post-hook 'follow-post-command-hook nil t)
- (add-hook 'ispell-update-post-hook 'follow-post-command-hook nil t)
+ (add-hook 'compilation-filter-hook
+ #'follow-align-compilation-windows t t)
+ (add-function :before pre-redisplay-function #'follow-pre-redisplay-function)
+ (add-hook 'window-size-change-functions #'follow-window-size-change t)
+ (add-hook 'after-change-functions #'follow-after-change nil t)
+ (add-hook 'isearch-update-post-hook #'follow-post-command-hook nil t)
+ (add-hook 'replace-update-post-hook #'follow-post-command-hook nil t)
+ (add-hook 'ispell-update-post-hook #'follow-post-command-hook nil t)
(when isearch-lazy-highlight
(setq-local isearch-lazy-highlight 'all-windows))
(when follow-hide-ghost-cursors
(setq-local cursor-in-non-selected-windows nil))
- (setq window-group-start-function 'follow-window-start)
- (setq window-group-end-function 'follow-window-end)
- (setq set-window-group-start-function 'follow-set-window-start)
- (setq recenter-window-group-function 'follow-recenter)
+ (setq window-group-start-function #'follow-window-start)
+ (setq window-group-end-function #'follow-window-end)
+ (setq set-window-group-start-function #'follow-set-window-start)
+ (setq recenter-window-group-function #'follow-recenter)
(setq pos-visible-in-window-group-p-function
- 'follow-pos-visible-in-window-p)
- (setq selected-window-group-function 'follow-all-followers)
- (setq move-to-window-group-line-function 'follow-move-to-window-line))
+ #'follow-pos-visible-in-window-p)
+ (setq selected-window-group-function #'follow-all-followers)
+ (setq move-to-window-group-line-function #'follow-move-to-window-line))
;; Remove globally-installed hook functions only if there is no
;; other Follow mode buffer.
(setq following (buffer-local-value 'follow-mode (car buffers))
buffers (cdr buffers)))
(unless following
- (remove-function pre-redisplay-function 'follow-pre-redisplay-function)
- (remove-hook 'window-size-change-functions 'follow-window-size-change)))
+ (remove-function pre-redisplay-function #'follow-pre-redisplay-function)
+ (remove-hook 'window-size-change-functions #'follow-window-size-change)))
(kill-local-variable 'move-to-window-group-line-function)
(kill-local-variable 'selected-window-group-function)
(kill-local-variable 'cursor-in-non-selected-windows)
- (remove-hook 'ispell-update-post-hook 'follow-post-command-hook t)
- (remove-hook 'replace-update-post-hook 'follow-post-command-hook t)
- (remove-hook 'isearch-update-post-hook 'follow-post-command-hook t)
- (remove-hook 'after-change-functions 'follow-after-change t)
- (remove-hook 'compilation-filter-hook 'follow-align-compilation-windows t)))
+ (remove-hook 'ispell-update-post-hook #'follow-post-command-hook t)
+ (remove-hook 'replace-update-post-hook #'follow-post-command-hook t)
+ (remove-hook 'isearch-update-post-hook #'follow-post-command-hook t)
+ (remove-hook 'after-change-functions #'follow-after-change t)
+ (remove-hook 'compilation-filter-hook #'follow-align-compilation-windows t)))
(defun follow-find-file-hook ()
"Find-file hook for Follow mode. See the variable `follow-auto'."
(defun follow-select-if-visible (dest win-start-end)
"Select and return a window, if DEST is visible in it.
Return the selected window."
- (let (win wse)
+ (let (win)
(while (and (not win) win-start-end)
;; Don't select a window that was just moved. This makes it
;; possible to later select the last window after a
;; `end-of-buffer' command.
- (setq wse (car win-start-end))
- (when (follow-pos-visible dest (car wse) win-start-end)
- (setq win (car wse))
- (select-window win))
- (setq win-start-end (cdr win-start-end)))
+ (let ((wse (car win-start-end)))
+ (when (follow-pos-visible dest (car wse) win-start-end)
+ (setq win (car wse))
+ (select-window win))
+ (setq win-start-end (cdr win-start-end))))
win))
;; Lets select a window showing the end. Make sure we only select it if
(setq win (or win (selected-window)))
(setq start (or start (window-start win)))
(save-excursion
- (let (done win-start res opoint)
- ;; Always calculate what happens when no line is displayed in the first
- ;; window. (The `previous' res is needed below!)
- (goto-char guess)
- (vertical-motion 0 (car windows))
- (setq res (point))
+ ;; Always calculate what happens when no line is displayed in the first
+ ;; window. (The `previous' res is needed below!)
+ (goto-char guess)
+ (vertical-motion 0 (car windows))
+ (let ((res (point))
+ done)
(while (not done)
- (setq opoint (point))
- (if (not (= (vertical-motion -1 (car windows)) -1))
- ;; Hit roof!
- (setq done t res (point-min))
- (setq win-start (follow-calc-win-start windows (point) win))
- (cond ((>= (point) opoint)
- ;; In some pathological cases, vertical-motion may
- ;; return -1 even though point has not decreased. In
- ;; that case, avoid looping forever.
- (setq done t res (point)))
- ((= win-start start) ; Perfect match, use this value
- (setq done t res (point)))
- ((< win-start start) ; Walked to far, use previous result
- (setq done t))
- (t ; Store result for next iteration
- (setq res (point))))))
+ (let ((opoint (point)))
+ (if (not (= (vertical-motion -1 (car windows)) -1))
+ ;; Hit roof!
+ (setq done t res (point-min))
+ (let ((win-start (follow-calc-win-start windows (point) win)))
+ (cond ((>= (point) opoint)
+ ;; In some pathological cases, vertical-motion may
+ ;; return -1 even though point has not decreased. In
+ ;; that case, avoid looping forever.
+ (setq done t res (point)))
+ ((= win-start start) ; Perfect match, use this value
+ (setq done t res (point)))
+ ((< win-start start) ; Walked to far, use previous result
+ (setq done t))
+ (t ; Store result for next iteration
+ (setq res (point))))))))
res)))
;;; Avoid tail recenter
;; Work in the selected window, not in the current buffer.
(with-current-buffer (window-buffer win)
(unless (and (symbolp this-command)
+ ;; FIXME: Why not compare buffer-modified-tick and
+ ;; selected-window to their old value, instead?
(get this-command 'follow-mode-use-cache))
(setq follow-windows-start-end-cache nil))
(follow-adjust-window win)))))
;; NOTE: to debug follow-mode with edebug, it is helpful to add
;; `follow-post-command-hook' to `post-command-hook' temporarily. Do
;; this locally to the target buffer with, say,:
-;; M-: (add-hook 'post-command-hook 'follow-post-command-hook t t)
+;; M-: (add-hook 'post-command-hook #'follow-post-command-hook t t)
;; .
(defun follow-adjust-window (win)
"Make a highlighted region stretching multiple windows look good."
(let* ((all (follow-split-followers windows win))
(pred (car all))
- (succ (cdr all))
- data)
- (while pred
- (setq data (assq (car pred) win-start-end))
- (set-window-point (car pred) (max (nth 1 data) (- (nth 2 data) 1)))
- (setq pred (cdr pred)))
- (while succ
- (set-window-point (car succ) (nth 1 (assq (car succ) win-start-end)))
- (setq succ (cdr succ)))))
+ (succ (cdr all)))
+ (dolist (w pred)
+ (let ((data (assq w win-start-end)))
+ (set-window-point w (max (nth 1 data) (- (nth 2 data) 1)))))
+ (dolist (w succ)
+ (set-window-point w (nth 1 (assq w win-start-end))))))
;;; Scroll bar
(select-window picked-window 'norecord)))
(select-frame orig-frame)))))
-(add-hook 'window-scroll-functions 'follow-avoid-tail-recenter t)
+(add-hook 'window-scroll-functions #'follow-avoid-tail-recenter t)
;;; Low level window start and end.
omitted if the character after POS is fully visible; otherwise, RTOP
and RBOT are the number of pixels off-window at the top and bottom of
the screen line (\"row\") containing POS, ROWH is the visible height
-of that row, and VPOS is the row number \(zero-based)."
- (let* ((windows (follow-all-followers window))
- (last (car (last windows))))
+of that row, and VPOS is the row number (zero-based)."
+ (let* ((windows (follow-all-followers window)))
(when follow-start-end-invalid
(follow-redisplay windows (car windows)))
(let* ((cache (follow-windows-start-end windows))
last-elt
(setq our-pos (or pos (point)))
(catch 'element
- (while cache
- (when (< our-pos (nth 2 (car cache)))
- (throw 'element (car cache)))
- (setq cache (cdr cache)))
+ (dolist (ce cache)
+ (when (< our-pos (nth 2 ce))
+ (throw 'element ce)))
last-elt)))
(pos-visible-in-window-p our-pos (car pertinent-elt) partially))))
(start-end (follow-windows-start-end windows))
(rev-start-end (reverse start-end))
(lines 0)
- middle-window elt count)
+ elt count)
(select-window
(cond
((null arg)
-;;; format-spec.el --- functions for formatting arbitrary formatting strings
+;;; format-spec.el --- functions for formatting arbitrary formatting strings -*- lexical-binding:t -*-
;; Copyright (C) 1999-2019 Free Software Foundation, Inc.
;;; Code:
(eval-when-compile (require 'cl-lib))
+(eval-when-compile (require 'subr-x)) ;For string-trim-right
(cl-defgeneric frame-creation-function (params)
"Method for window-system dependent functions to create a new frame.
(when (and (> blink-cursor-blinks 0)
(<= (* 2 blink-cursor-blinks) blink-cursor-blinks-done))
(blink-cursor-suspend)
- (add-hook 'post-command-hook 'blink-cursor-check)))
+ (add-hook 'post-command-hook #'blink-cursor-check))
+ ;; FIXME: Under TTYs, apparently redisplay only obeys internal-show-cursor
+ ;; when there is something else to update on the screen. This is arguably
+ ;; a bug, but in the meantime we can circumvent it here by causing an
+ ;; artificial update which thus "forces" a cursor update.
+ (when (null window-system)
+ (let* ((message-log-max nil)
+ (msg (current-message))
+ ;; Construct a dummy temp message different from the current one.
+ ;; This message usually flashes by too quickly to be visible, but
+ ;; occasionally it can be noticed, so make it "inconspicuous".
+ ;; Not too "inconspicuous", tho: just adding or removing a SPC at the
+ ;; end doesn't cause an update, for example.
+ (dummymsg (concat (if (> (length msg) 40)
+ (let ((msg (string-trim-right msg)))
+ (if (> (length msg) 2)
+ (substring msg 0 -2)
+ msg))
+ msg) "-")))
+ (message "%s" dummymsg)
+ (if msg (message "%s" msg) (message nil)))))
(defun blink-cursor-end ()
"Stop cursor blinking.
This is installed as a pre-command hook by `blink-cursor-start'.
When run, it cancels the timer `blink-cursor-timer' and removes
itself as a pre-command hook."
- (remove-hook 'pre-command-hook 'blink-cursor-end)
+ (remove-hook 'pre-command-hook #'blink-cursor-end)
(internal-show-cursor nil t)
(when blink-cursor-timer
(cancel-timer blink-cursor-timer)
(defun blink-cursor--should-blink ()
"Determine whether we should be blinking.
Returns whether we have any focused non-TTY frame."
- (and blink-cursor-mode
- (let ((frame-list (frame-list))
- (any-graphical-focused nil))
- (while frame-list
- (let ((frame (pop frame-list)))
- (when (and (display-graphic-p frame) (frame-focus-state frame))
- (setf any-graphical-focused t)
- (setf frame-list nil))))
- any-graphical-focused)))
+ blink-cursor-mode)
(defun blink-cursor-check ()
"Check if cursor blinking shall be restarted.
`blink-cursor--should-blink' and returns its result."
(let ((should-blink (blink-cursor--should-blink)))
(when (and should-blink (not blink-cursor-idle-timer))
- (remove-hook 'post-command-hook 'blink-cursor-check)
+ (remove-hook 'post-command-hook #'blink-cursor-check)
(blink-cursor--start-idle-timer))
should-blink))
:group 'gnus-article
:type 'boolean)
-(defcustom gnus-blocked-images 'gnus-block-private-groups
+(defcustom gnus-blocked-images #'gnus-block-private-groups
"Images that have URLs matching this regexp will be blocked.
Note that the main reason external images are included in HTML
emails (these days) is to allow tracking whether you've read the
"Format an HTML article."
(interactive)
(let ((handles nil)
- (buffer-read-only nil))
+ (inhibit-read-only t))
(when (gnus-buffer-live-p gnus-original-article-buffer)
(with-current-buffer gnus-original-article-buffer
(setq handles (mm-dissect-buffer t t))))
(canlock-verify gnus-original-article-buffer)))
(eval-and-compile
- (mapc
- (lambda (func)
- (let (afunc gfunc)
- (if (consp func)
- (setq afunc (car func)
- gfunc (cdr func))
- (setq afunc func
- gfunc (intern (format "gnus-%s" func))))
- (defalias gfunc
- (when (fboundp afunc)
- `(lambda (&optional interactive &rest args)
- ,(documentation afunc t)
- (interactive (list t))
- (with-current-buffer gnus-article-buffer
- (if interactive
- (call-interactively ',afunc)
- (apply #',afunc args))))))))
- '(article-hide-headers
- article-verify-x-pgp-sig
- article-verify-cancel-lock
- article-hide-boring-headers
- article-treat-overstrike
- article-treat-ansi-sequences
- article-fill-long-lines
- article-capitalize-sentences
- article-remove-cr
- article-remove-leading-whitespace
- article-display-x-face
- article-display-face
- article-de-quoted-unreadable
- article-de-base64-unreadable
- article-decode-HZ
- article-wash-html
- article-unsplit-urls
- article-hide-list-identifiers
- article-strip-banner
- article-babel
- article-hide-pem
- article-hide-signature
- article-strip-headers-in-body
- article-remove-trailing-blank-lines
- article-strip-leading-blank-lines
- article-strip-multiple-blank-lines
- article-strip-leading-space
- article-strip-trailing-space
- article-strip-blank-lines
- article-strip-all-blank-lines
- article-date-local
- article-date-english
- article-date-iso8601
- article-date-original
- article-treat-date
- article-date-ut
- article-decode-mime-words
- article-decode-charset
- article-decode-encoded-words
- article-date-user
- article-date-lapsed
- article-date-combined-lapsed
- article-emphasize
- article-treat-dumbquotes
- article-treat-non-ascii
- article-normalize-headers
- ;;(article-show-all . gnus-article-show-all-headers)
- )))
+ (defmacro gnus-art-defun (gnus-fun &optional article-fun)
+ "Define GNUS-FUN as a function that runs ARTICLE-FUN in the article buffer."
+ (unless article-fun
+ (if (not (string-match "\\`gnus-" (symbol-name gnus-fun)))
+ (error "Can't guess article-fun argument")
+ (setq article-fun (intern (substring (symbol-name gnus-fun)
+ (match-end 0))))))
+ `(defun ,gnus-fun (&optional interactive &rest args)
+ ,(format "Run `%s' in the article buffer." article-fun)
+ (interactive (list t))
+ (with-current-buffer gnus-article-buffer
+ (if interactive
+ (call-interactively ',article-fun)
+ (apply #',article-fun args))))))
+(gnus-art-defun gnus-article-hide-headers)
+(gnus-art-defun gnus-article-verify-x-pgp-sig)
+(gnus-art-defun gnus-article-verify-cancel-lock)
+(gnus-art-defun gnus-article-hide-boring-headers)
+(gnus-art-defun gnus-article-treat-overstrike)
+(gnus-art-defun gnus-article-treat-ansi-sequences)
+(gnus-art-defun gnus-article-fill-long-lines)
+(gnus-art-defun gnus-article-capitalize-sentences)
+(gnus-art-defun gnus-article-remove-cr)
+(gnus-art-defun gnus-article-remove-leading-whitespace)
+(gnus-art-defun gnus-article-display-x-face)
+(gnus-art-defun gnus-article-display-face)
+(gnus-art-defun gnus-article-de-quoted-unreadable)
+(gnus-art-defun gnus-article-de-base64-unreadable)
+(gnus-art-defun gnus-article-decode-HZ)
+(gnus-art-defun gnus-article-wash-html)
+(gnus-art-defun gnus-article-unsplit-urls)
+(gnus-art-defun gnus-article-hide-list-identifiers)
+(gnus-art-defun gnus-article-strip-banner)
+(gnus-art-defun gnus-article-babel)
+(gnus-art-defun gnus-article-hide-pem)
+(gnus-art-defun gnus-article-hide-signature)
+(gnus-art-defun gnus-article-strip-headers-in-body)
+(gnus-art-defun gnus-article-remove-trailing-blank-lines)
+(gnus-art-defun gnus-article-strip-leading-blank-lines)
+(gnus-art-defun gnus-article-strip-multiple-blank-lines)
+(gnus-art-defun gnus-article-strip-leading-space)
+(gnus-art-defun gnus-article-strip-trailing-space)
+(gnus-art-defun gnus-article-strip-blank-lines)
+(gnus-art-defun gnus-article-strip-all-blank-lines)
+(gnus-art-defun gnus-article-date-local)
+(gnus-art-defun gnus-article-date-english)
+(gnus-art-defun gnus-article-date-iso8601)
+(gnus-art-defun gnus-article-date-original)
+(gnus-art-defun gnus-article-treat-date)
+(gnus-art-defun gnus-article-date-ut)
+(gnus-art-defun gnus-article-decode-mime-words)
+(gnus-art-defun gnus-article-decode-charset)
+(gnus-art-defun gnus-article-decode-encoded-words)
+(gnus-art-defun gnus-article-date-user)
+(gnus-art-defun gnus-article-date-lapsed)
+(gnus-art-defun gnus-article-date-combined-lapsed)
+(gnus-art-defun gnus-article-emphasize)
+(gnus-art-defun gnus-article-treat-dumbquotes)
+(gnus-art-defun gnus-article-treat-non-ascii)
+(gnus-art-defun gnus-article-normalize-headers)
+;;(gnus-art-defun gnus-article-show-all-headers article-show-all)
\f
;;;
;;; Gnus article mode
(defvar gnus-mime-button-map
(let ((map (make-sparse-keymap)))
(define-key map [mouse-2] 'gnus-article-push-button)
- (define-key map [down-mouse-3] 'gnus-mime-button-menu)
(dolist (c gnus-mime-button-commands)
(define-key map (cadr c) (car c)))
- map))
-(easy-menu-define
- gnus-mime-button-menu gnus-mime-button-map "MIME button menu."
- `("MIME Part"
- ,@(mapcar (lambda (c)
- (vector (caddr c) (car c) :active t))
- gnus-mime-button-commands)))
+ (easy-menu-define gnus-mime-button-menu map "MIME button menu."
+ `("MIME Part"
+ ,@(mapcar (lambda (c)
+ (vector (caddr c) (car c) :active t))
+ gnus-mime-button-commands)))
+
+ (define-key map [down-mouse-3]
+ (easy-menu-binding gnus-mime-button-menu))
+ map))
(defvar gnus-url-button-commands
'((gnus-article-copy-string "u" "Copy URL to kill ring")))
(setq mm-w3m-safe-url-regexp nil)))
,@body))
-(defun gnus-mime-button-menu (event prefix)
- "Construct a context-sensitive menu of MIME commands."
- (interactive "e\nP")
- (save-window-excursion
- (let ((pos (event-start event)))
- (select-window (posn-window pos))
- (goto-char (posn-point pos))
- (gnus-article-check-buffer)
- (popup-menu gnus-mime-button-menu nil prefix))))
-
(defun gnus-mime-view-all-parts (&optional handles)
"View all the MIME parts."
(interactive)
nil nil)))
(gnus-mime-save-part-and-strip file))
-(defun gnus-mime-save-part-and-strip (&optional file)
+(defun gnus-mime-save-part-and-strip (&optional file event)
"Save the MIME part under point then replace it with an external body.
If FILE is given, use it for the external part."
- (interactive)
+ (interactive (list nil last-nonmenu-event))
+ (save-excursion
+ (mouse-set-point event)
(gnus-article-check-buffer)
(when (gnus-group-read-only-p)
(error "The current group does not support deleting of parts"))
(access-type . "LOCAL-FILE")
(name . ,file)))))
;; (set-buffer gnus-summary-buffer)
- (gnus-article-edit-part handles id))))
+ (gnus-article-edit-part handles id)))))
;; A function like `gnus-summary-save-parts' (`X m', `<MIME> <Extract all
;; parts...>') but with stripping would be nice.
-(defun gnus-mime-delete-part ()
+(defun gnus-mime-delete-part (&optional event)
"Delete the MIME part under point.
Replace it with some information about the removed part."
- (interactive)
+ (interactive (list last-nonmenu-event))
+ (mouse-set-point event)
(gnus-article-check-buffer)
(when (gnus-group-read-only-p)
(error "The current group does not support deleting of parts"))
;; (set-buffer gnus-summary-buffer)
(gnus-article-edit-part handles id))))
-(defun gnus-mime-save-part ()
+(defun gnus-mime-save-part (&optional event)
"Save the MIME part under point."
- (interactive)
+ (interactive (list last-nonmenu-event))
+ (mouse-set-point event)
(gnus-article-check-buffer)
(let ((data (get-text-property (point) 'gnus-data)))
(when data
(mm-save-part data))))
-(defun gnus-mime-pipe-part (&optional cmd)
- "Pipe the MIME part under point to a process.
-Use CMD as the process."
- (interactive)
+(defun gnus-mime-pipe-part (&optional cmd event)
+ "Pipe the MIME part under point to a process."
+ (interactive (list nil last-nonmenu-event))
+ (mouse-set-point event)
(gnus-article-check-buffer)
(let ((data (get-text-property (point) 'gnus-data)))
(when data
(mm-pipe-part data cmd))))
-(defun gnus-mime-view-part ()
+(defun gnus-mime-view-part (&optional event)
"Interactively choose a viewing method for the MIME part under point."
- (interactive)
- (gnus-article-check-buffer)
- (let ((data (get-text-property (point) 'gnus-data)))
- (when data
- (setq gnus-article-mime-handles
- (mm-merge-handles
- gnus-article-mime-handles (setq data (copy-sequence data))))
- (mm-interactively-view-part data))))
+ (interactive (list last-nonmenu-event))
+ (save-excursion
+ (mouse-set-point event)
+ (gnus-article-check-buffer)
+ (let ((data (get-text-property (point) 'gnus-data)))
+ (when data
+ (setq gnus-article-mime-handles
+ (mm-merge-handles
+ gnus-article-mime-handles (setq data (copy-sequence data))))
+ (mm-interactively-view-part data)))))
(defun gnus-mime-view-part-as-type-internal ()
(gnus-article-check-buffer)
'("text/plain" . 0))
'("application/octet-stream" . 0))))
-(defun gnus-mime-view-part-as-type (&optional mime-type pred)
+(defun gnus-mime-view-part-as-type (&optional mime-type pred event)
"Choose a MIME media type, and view the part as such.
If non-nil, PRED is a predicate to use during completion to limit the
available media-types."
- (interactive)
+ (interactive (list nil nil last-nonmenu-event))
+ (save-excursion
+ (if event (mouse-set-point event))
(unless mime-type
(setq mime-type
(let ((default (gnus-mime-view-part-as-type-internal)))
(mm-merge-handles gnus-article-mime-handles handle))
(when (mm-handle-displayed-p handle)
(mm-remove-part handle))
- (gnus-mm-display-part handle))))
+ (gnus-mm-display-part handle)))))
-(defun gnus-mime-copy-part (&optional handle arg)
+(defun gnus-mime-copy-part (&optional handle arg event)
"Put the MIME part under point into a new buffer.
If `auto-compression-mode' is enabled, compressed files like .gz and .bz2
are decompressed."
- (interactive (list nil current-prefix-arg))
+ (interactive (list nil current-prefix-arg last-nonmenu-event))
+ (mouse-set-point event)
(gnus-article-check-buffer)
(unless handle
(setq handle (get-text-property (point) 'gnus-data)))
(setq buffer-file-name nil))
(goto-char (point-min)))))
-(defun gnus-mime-print-part (&optional handle filename)
+(defun gnus-mime-print-part (&optional handle filename event)
"Print the MIME part under point."
- (interactive (list nil (ps-print-preprint current-prefix-arg)))
+ (interactive
+ (list nil (ps-print-preprint current-prefix-arg) last-nonmenu-event))
+ (save-excursion
+ (mouse-set-point event)
(gnus-article-check-buffer)
(let* ((handle (or handle (get-text-property (point) 'gnus-data)))
(contents (and handle (mm-get-part handle)))
(with-temp-buffer
(insert contents)
(gnus-print-buffer))
- (ps-despool filename)))))
+ (ps-despool filename))))))
-(defun gnus-mime-inline-part (&optional handle arg)
+(defun gnus-mime-inline-part (&optional handle arg event)
"Insert the MIME part under point into the current buffer.
Compressed files like .gz and .bz2 are decompressed."
- (interactive (list nil current-prefix-arg))
+ (interactive (list nil current-prefix-arg last-nonmenu-event))
+ (if event (mouse-set-point event))
(gnus-article-check-buffer)
(let* ((inhibit-read-only t)
(b (point))
(setcdr param charset)
(setcdr type (cons (cons 'charset charset) (cdr type)))))))
-(defun gnus-mime-view-part-as-charset (&optional handle arg)
+(defun gnus-mime-view-part-as-charset (&optional handle arg event)
"Insert the MIME part under point into the current buffer using the
specified charset."
- (interactive (list nil current-prefix-arg))
+ (interactive (list nil current-prefix-arg last-nonmenu-event))
+ (save-excursion
+ (mouse-set-point event)
(gnus-article-check-buffer)
(let ((handle (or handle (get-text-property (point) 'gnus-data)))
(fun (get-text-property (point) 'gnus-callback))
(setcar (cddr form)
(list 'quote (or (cadr (member preferred parts))
(car parts)))))
- (funcall fun handle)))))
+ (funcall fun handle))))))
-(defun gnus-mime-view-part-externally (&optional handle)
+(defun gnus-mime-view-part-externally (&optional handle event)
"View the MIME part under point with an external viewer."
- (interactive)
+ (interactive (list nil last-nonmenu-event))
+ (save-excursion
+ (mouse-set-point event)
(gnus-article-check-buffer)
(let* ((handle (or handle (get-text-property (point) 'gnus-data)))
(mm-inlined-types nil)
(gnus-mime-view-part-as-type
nil (lambda (type) (stringp (mailcap-mime-info type))))
(when handle
- (mm-display-part handle nil t)))))
+ (mm-display-part handle nil t))))))
-(defun gnus-mime-view-part-internally (&optional handle)
+(defun gnus-mime-view-part-internally (&optional handle event)
"View the MIME part under point with an internal viewer.
If no internal viewer is available, use an external viewer."
- (interactive)
+ (interactive (list nil last-nonmenu-event))
+ (save-excursion
+ (mouse-set-point event)
(gnus-article-check-buffer)
(let* ((handle (or handle (get-text-property (point) 'gnus-data)))
(mm-inlined-types '(".*"))
(gnus-mime-view-part-as-type
nil (lambda (type) (mm-inlinable-p handle type)))
(when handle
- (gnus-bind-mm-vars (mm-display-part handle nil t))))))
+ (gnus-bind-mm-vars (mm-display-part handle nil t)))))))
(defun gnus-mime-action-on-part (&optional action)
"Do something with the MIME attachment at (point)."
(widget-convert-button
'link b e
:mime-handle handle
- :action 'gnus-widget-press-button
+ :action #'gnus-widget-press-button
:button-keymap gnus-mime-button-map
:help-echo
(lambda (widget)
article-type multipart
rear-nonsticky t))
(widget-convert-button 'link from (point)
- :action 'gnus-widget-press-button)
+ :action #'gnus-widget-press-button)
;; Do the handles
(while (setq handle (pop handles))
(add-text-properties
gnus-data ,handle
rear-nonsticky t))
(widget-convert-button 'link from (point)
- :action 'gnus-widget-press-button)
+ :action #'gnus-widget-press-button)
(insert " "))
(insert "\n\n"))
(when preferred
(when (and do-update-line
(or (numberp article)
(stringp article)))
- (let ((buf (current-buffer)))
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
(gnus-summary-update-article do-update-line sparse-header)
(gnus-summary-goto-subject do-update-line nil t)
(set-window-point (gnus-get-buffer-window (current-buffer) t)
- (point))
- (set-buffer buf))))))
+ (point)))))))
(defun gnus-block-private-groups (group)
"Allows images in newsgroups to be shown, blocks images in all
(gnus-article-mode)
(set-window-configuration winconf)
;; Tippy-toe some to make sure that point remains where it was.
- (save-current-buffer
- (set-buffer curbuf)
+ (with-current-buffer curbuf
(set-window-start (get-buffer-window (current-buffer)) window-start)
(goto-char p))))
(gnus-summary-show-article)))
(when fun
(funcall fun data))))
-(defun gnus-article-press-button ()
+(defun gnus-article-press-button (&optional event)
"Check text at point for a callback function.
If the text at point has a `gnus-callback' property,
call it with the value of the `gnus-data' text property."
- (interactive)
- (let ((data (get-text-property (point) 'gnus-data))
- (fun (get-text-property (point) 'gnus-callback)))
- (when fun
- (funcall fun data))))
+ (interactive (list last-nonmenu-event))
+ (save-excursion
+ (mouse-set-point event)
+ (let ((fun (get-text-property (point) 'gnus-callback)))
+ (when fun
+ (funcall fun (get-text-property (point) 'gnus-data))))))
(defun gnus-article-highlight (&optional force)
"Highlight current article.
(list 'mouse-face gnus-article-mouse-face))
(list 'gnus-callback fun)
(and data (list 'gnus-data data))))
- (widget-convert-button 'link from to :action 'gnus-widget-press-button
+ (widget-convert-button 'link from to :action #'gnus-widget-press-button
:help-echo (or text "Follow the link")
:keymap gnus-url-button-map))
-;;; gnus-cloud.el --- storing and retrieving data via IMAP
+;;; gnus-cloud.el --- storing and retrieving data via IMAP -*- lexical-binding:t -*-
;; Copyright (C) 2014-2019 Free Software Foundation, Inc.
The latter should have a :directory element whose value is a string,
and a :match element whose value is a regular expression to match
against the basename of files in said directory."
- :group 'gnus-cloud
:type '(repeat (choice (string :tag "File")
(plist :tag "Property list"))))
(defcustom gnus-cloud-storage-method (if (featurep 'epg) 'epg 'base64-gzip)
"Storage method for cloud data, defaults to EPG if that's available."
:version "26.1"
- :group 'gnus-cloud
:type '(radio (const :tag "No encoding" nil)
(const :tag "Base64" base64)
(const :tag "Base64+gzip" base64-gzip)
(defcustom gnus-cloud-interactive t
"Whether Gnus Cloud changes should be confirmed."
:version "26.1"
- :group 'gnus-cloud
:type 'boolean)
(defvar gnus-cloud-group-name "Emacs-Cloud")
"The IMAP select method used to store the cloud data.
See also `gnus-server-set-cloud-method-server' for an
easy interactive way to set this from the Server buffer."
- :group 'gnus-cloud
:type '(radio (const :tag "Not set" nil)
(string :tag "A Gnus server name as a string")))
(base64-encode-region (point-min) (point-max)))
((eq gnus-cloud-storage-method 'epg)
- (let ((context (epg-make-context 'OpenPGP))
- cipher)
+ (let ((context (epg-make-context 'OpenPGP)))
(setf (epg-context-armor context) t)
(setf (epg-context-textmode context) t)
(let ((data (epg-encrypt-string context
(group &optional previous method))
(defun gnus-cloud-ensure-cloud-group ()
+ ;; FIXME: `method' is not used!?
(let ((method (if (stringp gnus-cloud-method)
(gnus-server-to-method gnus-cloud-method)
gnus-cloud-method)))
(add-text-properties
(point)
(prog1 (1+ (point))
- (eval gnus-topic-line-format-spec))
+ (eval gnus-topic-line-format-spec
+ `((indentation . ,indentation)
+ (visible . ,visible)
+ (name . ,name)
+ (level . ,level)
+ (number-of-groups . ,number-of-groups)
+ (total-number-of-articles . ,total-number-of-articles)
+ (entries . ,entries))))
(list 'gnus-topic name
'gnus-topic-level level
'gnus-topic-unread unread
(require 'time-date)
(require 'text-property-search)
-(defcustom gnus-completing-read-function 'gnus-emacs-completing-read
+(defcustom gnus-completing-read-function #'gnus-emacs-completing-read
"Function use to do completing read."
:version "24.1"
:group 'gnus-meta
(defmacro gnus-eval-in-buffer-window (buffer &rest forms)
"Pop to BUFFER, evaluate FORMS, and then return to the original window."
+ (declare (indent 1) (debug (form body)))
(let ((tempvar (make-symbol "GnusStartBufferWindow"))
(w (make-symbol "w"))
(buf (make-symbol "buf")))
,@forms)
(select-window ,tempvar)))))
-(put 'gnus-eval-in-buffer-window 'lisp-indent-function 1)
-(put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body))
-
(defsubst gnus-goto-char (point)
(and point (goto-char point)))
(defmacro gnus-local-set-keys (&rest plist)
"Set the keys in PLIST in the current keymap."
+ (declare (indent 1))
`(gnus-define-keys-1 (current-local-map) ',plist))
(defmacro gnus-define-keys (keymap &rest plist)
"Define all keys in PLIST in KEYMAP."
+ (declare (indent 1))
`(gnus-define-keys-1 (quote ,keymap) (quote ,plist)))
(defmacro gnus-define-keys-safe (keymap &rest plist)
"Define all keys in PLIST in KEYMAP without overwriting previous definitions."
+ (declare (indent 1))
`(gnus-define-keys-1 (quote ,keymap) (quote ,plist) t))
-(put 'gnus-define-keys 'lisp-indent-function 1)
-(put 'gnus-define-keys-safe 'lisp-indent-function 1)
-(put 'gnus-local-set-keys 'lisp-indent-function 1)
-
(defmacro gnus-define-keymap (keymap &rest plist)
"Define all keys in PLIST in KEYMAP."
+ (declare (indent 1))
`(gnus-define-keys-1 ,keymap (quote ,plist)))
-(put 'gnus-define-keymap 'lisp-indent-function 1)
-
(defun gnus-define-keys-1 (keymap plist &optional safe)
(when (null keymap)
(error "Can't set keys in a null keymap"))
`(let (str time)
(cond ((eq gnus-add-timestamp-to-message 'log)
(setq str (let (message-log-max)
- (apply 'message ,format-string ,args)))
+ (apply #'message ,format-string ,args)))
(when (and message-log-max
(> message-log-max 0)
(/= (length str) 0))
(gnus-add-timestamp-to-message
(if (or (and (null ,format-string) (null ,args))
(progn
- (setq str (apply 'format ,format-string ,args))
+ (setq str (apply #'format ,format-string ,args))
(zerop (length str))))
(prog1
(and ,format-string str)
(message "%s" (concat ,timestamp str))
str))
(t
- (apply 'message ,format-string ,args)))))))
+ (apply #'message ,format-string ,args)))))))
(defvar gnus-action-message-log nil)
inside loops."
(if (<= level gnus-verbose)
(let ((message
- (if gnus-add-timestamp-to-message
- (apply 'gnus-message-with-timestamp args)
- (apply 'message args))))
+ (apply (if gnus-add-timestamp-to-message
+ #'gnus-message-with-timestamp
+ #'message)
+ args)))
(when (and (consp gnus-action-message-log)
(<= level 3))
(push message gnus-action-message-log))
;; We have to do this format thingy here even if the result isn't
;; shown - the return value has to be the same as the return value
;; from `message'.
- (apply 'format args)))
+ (apply #'format args)))
(defun gnus-final-warning ()
(when (and (consp gnus-action-message-log)
"Beep an error if LEVEL is equal to or less than `gnus-verbose'.
ARGS are passed to `message'."
(when (<= (floor level) gnus-verbose)
- (apply 'message args)
+ (apply #'message args)
(ding)
(let (duration)
(when (and (floatp level)
to t, and `print-escape-multibyte', `print-escape-newlines',
`print-escape-nonascii', `print-length', `print-level' and
`print-string-length' to nil."
- `(let ((print-quoted t)
- (print-readably t)
- ;;print-circle
- ;;print-continuous-numbering
- print-escape-multibyte
- print-escape-newlines
- print-escape-nonascii
- ;;print-gensym
- print-length
- print-level
- print-string-length)
- ,@forms))
+ `(progn
+ (defvar print-string-length) (defvar print-readably)
+ (let ((print-quoted t)
+ (print-readably t)
+ ;;print-circle
+ ;;print-continuous-numbering
+ print-escape-multibyte
+ print-escape-newlines
+ print-escape-nonascii
+ ;;print-gensym
+ print-length
+ print-level
+ print-string-length)
+ ,@forms)))
(defun gnus-prin1 (form)
"Use `prin1' on FORM in the current buffer.
operations are performed by FORMS. If you wish to assign many
complicated values atomically, compute the results into temporary
variables and then do only the assignment atomically."
+ (declare (indent 0))
`(let ((inhibit-quit gnus-atomic-be-safe))
,@forms))
-(put 'gnus-atomic-progn 'lisp-indent-function 0)
-
(defmacro gnus-atomic-progn-assign (protect &rest forms)
"Evaluate FORMS, but ensure that the variables listed in PROTECT
are not changed if anything in FORMS signals an error or otherwise
Note that if any of the symbols in PROTECT were unbound, they will be
set to nil on a successful assignment. In case of an error or other
non-local exit, it will still be unbound."
+ (declare (indent 1)) ;;(debug (sexp body))
(let* ((temp-sym-map (mapcar (lambda (x) (list (make-symbol
(concat (symbol-name x)
"-tmp"))
,(cadr x))))
temp-sym-map))
(sym-temp-let sym-temp-map)
- (temp-sym-assign (apply 'append temp-sym-map))
- (sym-temp-assign (apply 'append sym-temp-map))
+ (temp-sym-assign (apply #'append temp-sym-map))
+ (sym-temp-assign (apply #'append sym-temp-map))
(result (make-symbol "result-tmp")))
`(let (,@temp-sym-let
,result)
(setq ,@sym-temp-assign))
,result)))
-(put 'gnus-atomic-progn-assign 'lisp-indent-function 1)
-;(put 'gnus-atomic-progn-assign 'edebug-form-spec '(sexp body))
-
(defmacro gnus-atomic-setq (&rest pairs)
"Similar to setq, except that the real symbols are only assigned when
there are no errors. And when the real symbols are assigned, they are
(defun gnus-run-hooks (&rest funcs)
"Does the same as `run-hooks', but saves the current buffer."
(save-current-buffer
- (apply 'run-hooks funcs)))
+ (apply #'run-hooks funcs)))
(defun gnus-run-hook-with-args (hook &rest args)
"Does the same as `run-hook-with-args', but saves the current buffer."
(save-current-buffer
- (apply 'run-hook-with-args hook args)))
+ (apply #'run-hook-with-args hook args)))
(defun gnus-run-mode-hooks (&rest funcs)
"Run `run-mode-hooks', saving the current buffer."
- (save-current-buffer (apply 'run-mode-hooks funcs)))
+ (save-current-buffer (apply #'run-mode-hooks funcs)))
;;; Various
;; Fixme: Why not use `with-output-to-temp-buffer'?
(defmacro gnus-with-output-to-file (file &rest body)
+ (declare (indent 1) (debug (form body)))
(let ((buffer (make-symbol "output-buffer"))
(size (make-symbol "output-buffer-size"))
(leng (make-symbol "output-buffer-length"))
(write-region (substring ,buffer 0 ,leng) nil ,file
,append 'no-msg))))))
-(put 'gnus-with-output-to-file 'lisp-indent-function 1)
-(put 'gnus-with-output-to-file 'edebug-form-spec '(form body))
-
(defun gnus-add-text-properties-when
(property value start end properties &optional object)
"Like `add-text-properties', only applied on where PROPERTY is VALUE."
(setq gnus-info-buffer (current-buffer))
(gnus-configure-windows 'info)))
-(defun gnus-not-ignore (&rest args)
+(defun gnus-not-ignore (&rest _)
t)
(defvar gnus-directory-sep-char-regexp "/"
`(,spec elem))
((listp spec)
(if (memq (car spec) '(or and not))
- `(,(car spec) ,@(mapcar 'gnus-make-predicate-1 (cdr spec)))
+ `(,(car spec) ,@(mapcar #'gnus-make-predicate-1 (cdr spec)))
(error "Invalid predicate specifier: %s" spec)))))
(defun gnus-completing-read (prompt collection &optional require-match
;; Make sure iswitchb is loaded before we let-bind its variables.
;; If it is loaded inside the let, variables can become unbound afterwards.
(require 'iswitchb)
+ (declare-function iswitchb-minibuffer-setup "iswitchb" ())
+ (defvar iswitchb-make-buflist-hook)
(let ((iswitchb-make-buflist-hook
(lambda ()
(setq iswitchb-temp-buflist
(unwind-protect
(progn
(or iswitchb-mode
- (add-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup))
+ (add-hook 'minibuffer-setup-hook #'iswitchb-minibuffer-setup))
(iswitchb-read-buffer prompt def require-match))
(or iswitchb-mode
- (remove-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup)))))
-
-(put 'gnus-parse-without-error 'lisp-indent-function 0)
-(put 'gnus-parse-without-error 'edebug-form-spec '(body))
+ (remove-hook 'minibuffer-setup-hook #'iswitchb-minibuffer-setup)))))
(defmacro gnus-parse-without-error (&rest body)
"Allow continuing onto the next line even if an error occurs."
+ (declare (indent 0) (debug (body)))
`(while (not (eobp))
(condition-case ()
(progn
(defvar tool-bar-mode)
-(defun gnus-tool-bar-update (&rest ignore)
+(defun gnus-tool-bar-update (&rest _)
"Update the tool bar."
- (when (and (boundp 'tool-bar-mode)
- tool-bar-mode)
+ (when (bound-and-true-p tool-bar-mode)
(let* ((args nil)
(func (cond ((fboundp 'tool-bar-update)
- 'tool-bar-update)
+ #'tool-bar-update)
((fboundp 'force-window-update)
- 'force-window-update)
+ #'force-window-update)
((fboundp 'redraw-frame)
(setq args (list (selected-frame)))
- 'redraw-frame)
+ #'redraw-frame)
(t 'ignore))))
(apply func args))))
(if seqs2_n
(let* ((seqs (cons seq1 seqs2_n))
(cnt 0)
- (heads (mapcar (lambda (seq)
+ (heads (mapcar (lambda (_seq)
(make-symbol (concat "head"
(int-to-string
(setq cnt (1+ cnt))))))
system-configuration)
((memq 'type lst)
(symbol-name system-type))
- (t nil)))
- codename)
+ (t nil))))
(cond
((not (memq 'emacs lst))
nil)
empty directories from OLD-PATH."
(when (file-exists-p old-path)
(let* ((old-dir (file-name-directory old-path))
- (old-name (file-name-nondirectory old-path))
(new-dir (file-name-directory new-path))
- (new-name (file-name-nondirectory new-path))
temp)
(gnus-make-directory new-dir)
(rename-file old-path new-path t)
(setq props (plist-put props :foreground (face-foreground face)))
(setq props (plist-put props :background (face-background face))))
(ignore-errors
- (apply 'create-image file type data-p props))))
+ (apply #'create-image file type data-p props))))
(defun gnus-put-image (glyph &optional string category)
(let ((point (point)))
-;;; nnimap.el --- IMAP interface for Gnus
+;;; nnimap.el --- IMAP interface for Gnus -*- lexical-binding:t -*-
;; Copyright (C) 2010-2019 Free Software Foundation, Inc.
;; of the *packages* in which the function is defined.
(let* ((name (symbol-name symbol))
(re (concat "\\_<" (regexp-quote name) "\\_>"))
- (news (directory-files data-directory t "\\`NEWS.[1-9]"))
+ (news (directory-files data-directory t "\\`NEWS"))
(place nil)
(first nil))
(with-temp-buffer
;; Almost all entries are of the form "* ... in Emacs NN.MM."
;; but there are also a few in the form "* Emacs NN.MM is a bug
;; fix release ...".
- (if (not (re-search-backward "^\\*.* Emacs \\([0-9.]+[0-9]\\)"
+ (if (not (re-search-backward "^\\* .* Emacs \\([0-9.]+[0-9]\\)"
nil t))
(message "Ref found in non-versioned section in %S"
(file-name-nondirectory f))
(setq place (list f pos))
(setq first version)))))))))
(when first
- (make-text-button first nil 'type 'help-news 'help-args place))
- first))
+ (make-text-button first nil 'type 'help-news 'help-args place))))
(add-hook 'help-fns-describe-function-functions
#'help-fns--mention-first-release)
(quail-terminate-translation))
(defun quail-update-translation (control-flag)
-"Update the current translation status according to CONTROL-FLAG.
+ "Update the current translation status according to CONTROL-FLAG.
If CONTROL-FLAG is integer value, it is the number of keys in the
head `quail-current-key' which can be translated. The remaining keys
are put back to `unread-command-events' to be handled again. If
(let ((folder mh-current-folder)
(window-config mh-previous-window-config))
(mh-set-folder-modified-p t) ; lock folder to kill it
- (mh-exec-cmd-daemon "rmf" 'mh-rmf-daemon folder)
+ (mh-exec-cmd-daemon "rmf" #'mh-rmf-daemon folder)
(when (boundp 'mh-speed-folder-map)
(mh-speed-invalidate-map folder))
(mh-remove-from-sub-folders-cache folder)
(message "Folder %s removed" folder))
(message "Folder not removed")))
-(defun mh-rmf-daemon (process output)
+(defun mh-rmf-daemon (_process output)
"The rmf PROCESS puts OUTPUT in temporary buffer.
Display the results only if something went wrong."
(set-buffer (get-buffer-create mh-temp-buffer))
(if (eq (car bounds) base) md-at-point
(completion-metadata (substring string 0 base) table pred))))
+(defun completion-score-sort (completions)
+ (sort completions
+ (lambda (x y)
+ (> (or (get-text-property 0 'completion-score x) 0)
+ (or (get-text-property 0 'completion-score y) 0)))))
+
+(defun completion-sort (all &optional prefer-regular table-sort-fun)
+ "Sort ALL, which is the list of all the completion strings we found.
+If PREFER-REGULAR, then give a bit more importance to returning
+an ordering that is easy to scan quickly (e.g. lexicographic) rather
+then trying to minimize the expected position of the completion
+actually desired.
+TABLE-SORT-FUN is the sorting function specified by the completion table,
+if applicable.
+The sort is performed in a destructive way."
+ (cond
+ (table-sort-fun
+ ;; I feel like we should slowly deprecate table-sort-fun (probably
+ ;; replacing it with a way for the completion table to provide scores),
+ ;; so let's not try to be clever here.
+ (funcall table-sort-fun all))
+ (t
+ ;; Prefer shorter completions, by default.
+ (if prefer-regular
+ (setq all (sort all #'string-lessp))
+ (setq all (sort all (lambda (c1 c2) (< (length c1) (length c2)))))
+ (if (minibufferp)
+ ;; Prefer recently used completions and put the default, if
+ ;; it exists, on top.
+ (let ((hist (symbol-value minibuffer-history-variable)))
+ (setq all (sort all
+ (lambda (c1 c2)
+ (cond ((equal c1 minibuffer-default) t)
+ ((equal c2 minibuffer-default) nil)
+ (t (> (length (member c1 hist))
+ (length (member c2 hist)))))))))))
+ (setq all (completion-score-sort all))
+ all)))
+
(defun completion-all-sorted-completions (&optional start end)
(or completion-all-sorted-completions
(let* ((start (or start (minibuffer-prompt-end)))
(setq all (delete-dups all))
(setq last (last all))
- (cond
- (sort-fun
- (setq all (funcall sort-fun all)))
- (t
- ;; Prefer shorter completions, by default.
- (setq all (sort all (lambda (c1 c2) (< (length c1) (length c2)))))
- (if (minibufferp)
- ;; Prefer recently used completions and put the default, if
- ;; it exists, on top.
- (let ((hist (symbol-value minibuffer-history-variable)))
- (setq all
- (sort all
- (lambda (c1 c2)
- (cond ((equal c1 minibuffer-default) t)
- ((equal c2 minibuffer-default) nil)
- (t (> (length (member c1 hist))
- (length (member c2 hist))))))))))))
+ (setq all (completion-sort all nil sort-fun))
;; Cache the result. This is not just for speed, but also so that
;; repeated calls to minibuffer-force-complete can cycle through
;; all possibilities.
;; not always.
(let ((sort-fun (completion-metadata-get
all-md 'display-sort-function)))
- (if sort-fun
- (funcall sort-fun completions)
- (sort completions 'string-lessp))))
+ (completion-sort completions 'prefer-regular sort-fun)))
(when afun
(setq completions
(mapcar (lambda (s)
'point
(substring afterpoint 0 (cdr bounds)))))
(all (completion-pcm--all-completions prefix pattern table pred)))
- (completion-hilit-commonality all point (car bounds))))
+ (when all
+ (nconc (completion-pcm--hilit-commonality pattern all)
+ (car bounds)))))
;;; Partial-completion-mode style completion.
(when (string-match-p regex c) (push c poss)))
(nreverse poss))))))
-(defvar flex-score-match-tightness 100
- "Controls how the `flex' completion style scores its matches.
+(defvar completion-score-match-tightness 100
+ "Controls how the completion style scores its matches.
Value is a positive number. Values smaller than one make the
scoring formula value matches scattered along the string, while
;; For the numerator, we use the number of +, i.e. the
;; length of the pattern. For the denominator, it
;; sums (1+ (/ (grouplen - 1)
- ;; flex-score-match-tightness)) across all groups of
+ ;; completion-score-match-tightness)) across all groups of
;; -, sums one to that total, and then multiples by
;; the length of the string.
(score-numerator 0)
score-denominator (+ score-denominator
1
(/ (- a last-b 1)
- flex-score-match-tightness
+ completion-score-match-tightness
1.0))))
(setq
last-b b))))
-;;; ldap.el --- client interface to LDAP for Emacs
+;;; ldap.el --- client interface to LDAP for Emacs -*- lexical-binding:t -*-
;; Copyright (C) 1998-2019 Free Software Foundation, Inc.
(encode-coding-string str ldap-coding-system))
(defun ldap-decode-address (str)
- (mapconcat 'ldap-decode-string
+ (mapconcat #'ldap-decode-string
(split-string str "\\$")
"\n"))
(defun ldap-encode-address (str)
- (mapconcat 'ldap-encode-string
+ (mapconcat #'ldap-encode-string
(split-string str "\n")
"$"))
The function returns a list of matching entries. Each entry is itself
an alist of attribute/value pairs."
(let* ((buf (get-buffer-create " *ldap-search*"))
- (bufval (get-buffer-create " *ldap-value*"))
- (host (or (plist-get search-plist 'host)
- ldap-default-host))
+ (bufval (get-buffer-create " *ldap-value*"))
+ (host (or (plist-get search-plist 'host)
+ ldap-default-host))
;; find entries with port "ldap" that match the requested host if any
(asfound (when (plist-get search-plist 'auth-source)
(nth 0 (auth-source-search :host (or host t)
(base (or (plist-get search-plist 'base)
(plist-get asfound :base)
ldap-default-base))
- (filter (plist-get search-plist 'filter))
- (attributes (plist-get search-plist 'attributes))
- (attrsonly (plist-get search-plist 'attrsonly))
- (scope (plist-get search-plist 'scope))
- (auth (plist-get search-plist 'auth))
- (deref (plist-get search-plist 'deref))
- (timelimit (plist-get search-plist 'timelimit))
- (sizelimit (plist-get search-plist 'sizelimit))
- (withdn (plist-get search-plist 'withdn))
- (numres 0)
- arglist dn name value record result proc)
+ (filter (plist-get search-plist 'filter))
+ (attributes (plist-get search-plist 'attributes))
+ (attrsonly (plist-get search-plist 'attrsonly))
+ (scope (plist-get search-plist 'scope))
+ (auth (plist-get search-plist 'auth))
+ (deref (plist-get search-plist 'deref))
+ (timelimit (plist-get search-plist 'timelimit))
+ (sizelimit (plist-get search-plist 'sizelimit))
+ (withdn (plist-get search-plist 'withdn))
+ (numres 0)
+ (arglist
+ (append
+ (if (and host
+ (not (equal "" host)))
+ (list (format
+ ;; Use -H if host is a new-style LDAP URI.
+ (if (string-match "\\`[a-zA-Z]+://" host)
+ "-H%s"
+ "-h%s")
+ host)))
+ (if (and attrsonly
+ (not (equal "" attrsonly)))
+ (list "-A"))
+ (if (and base
+ (not (equal "" base)))
+ (list (format "-b%s" base)))
+ (if (and scope
+ (not (equal "" scope)))
+ (list (format "-s%s" scope)))
+ (if (and binddn
+ (not (equal "" binddn)))
+ (list (format "-D%s" binddn)))
+ (if (and auth
+ (equal 'simple auth))
+ (list "-x"))
+ ;; Allow passwd to be set to "", representing a blank password.
+ (if passwd
+ (list "-W"))
+ (if (and deref
+ (not (equal "" deref)))
+ (list (format "-a%s" deref)))
+ (if (and timelimit
+ (not (equal "" timelimit)))
+ (list (format "-l%s" timelimit)))
+ (if (and sizelimit
+ (not (equal "" sizelimit)))
+ (list (format "-z%s" sizelimit)))))
+ dn name value record result)
(if (or (null filter)
(equal "" filter))
(error "No search filter"))
(setq filter (cons filter attributes))
(with-current-buffer buf
(erase-buffer)
- (if (and host
- (not (equal "" host)))
- (setq arglist (nconc arglist
- (list (format
- ;; Use -H if host is a new-style LDAP URI.
- (if (string-match "^[a-zA-Z]+://" host)
- "-H%s"
- "-h%s")
- host)))))
- (if (and attrsonly
- (not (equal "" attrsonly)))
- (setq arglist (nconc arglist (list "-A"))))
- (if (and base
- (not (equal "" base)))
- (setq arglist (nconc arglist (list (format "-b%s" base)))))
- (if (and scope
- (not (equal "" scope)))
- (setq arglist (nconc arglist (list (format "-s%s" scope)))))
- (if (and binddn
- (not (equal "" binddn)))
- (setq arglist (nconc arglist (list (format "-D%s" binddn)))))
- (if (and auth
- (equal 'simple auth))
- (setq arglist (nconc arglist (list "-x"))))
- ;; Allow passwd to be set to "", representing a blank password.
- (if passwd
- (setq arglist (nconc arglist (list "-W"))))
- (if (and deref
- (not (equal "" deref)))
- (setq arglist (nconc arglist (list (format "-a%s" deref)))))
- (if (and timelimit
- (not (equal "" timelimit)))
- (setq arglist (nconc arglist (list (format "-l%s" timelimit)))))
- (if (and sizelimit
- (not (equal "" sizelimit)))
- (setq arglist (nconc arglist (list (format "-z%s" sizelimit)))))
(if passwd
;; Leave process-connection-type at its default value. See
;; discussion in Bug#33050.
" bind distinguished name (binddn)"))
(error "Failed ldapsearch invocation: %s \"%s\""
ldap-ldapsearch-prog
- (mapconcat 'identity proc-args "\" \""))))))
+ (mapconcat #'identity proc-args "\" \""))))))
(apply #'call-process ldap-ldapsearch-prog
;; Ignore stderr, which can corrupt results
nil (list buf nil) nil
(setq global-mode-string
(append global-mode-string '(rcirc-activity-string))))
(add-hook 'window-configuration-change-hook
- 'rcirc-window-configuration-change))
+ #'rcirc-window-configuration-change))
(setq global-mode-string
(delete 'rcirc-activity-string global-mode-string))
(remove-hook 'window-configuration-change-hook
- 'rcirc-window-configuration-change)))
+ #'rcirc-window-configuration-change)))
(or (assq 'rcirc-ignore-buffer-activity-flag minor-mode-alist)
(setq minor-mode-alist
(const :tag "EOL-terminated" eol))
:group 'comment)
+;;;; Setup syntax from "high-level" description of comment syntax
+
+;; This defines `comment-set-syntax' so a major mode can just call
+;; this one function to setup the comment syntax both in the syntax-table
+;; and in the various comment-* variables.
+
+(defvar comment--set-table
+ ;; We want to associate extra properties with syntax-table, but syntax-tables
+ ;; don't have "properties", so we use an eq-hash-table indexed by
+ ;; syntax-tables instead.
+ (make-hash-table :test #'eq))
+
+(defun comment--set-comment-syntax (st comment-list)
+ "Set up comment functionality for generic mode."
+ (let ((chars nil)
+ (comstyles)
+ (comment-start nil))
+
+ ;; Go through all the comments.
+ (pcase-dolist (`(,start ,end . ,props) comment-list)
+ (let ((nested (if (plist-get props :nested) "n"))
+ (comstyle
+ ;; Reuse comstyles if necessary.
+ (or (cdr (assoc start comstyles))
+ (cdr (assoc end comstyles))
+ ;; Otherwise, use a style not yet in use.
+ (if (not (rassoc "" comstyles)) "")
+ (if (not (rassoc "b" comstyles)) "b")
+ "c")))
+ (push (cons start comstyle) comstyles)
+ (push (cons end comstyle) comstyles)
+
+ ;; Setup the syntax table.
+ (if (= (length start) 1)
+ (modify-syntax-entry (aref start 0)
+ (concat "< " comstyle nested) st)
+ (let ((c0 (aref start 0)) (c1 (aref start 1)))
+ ;; Store the relevant info but don't update yet.
+ (push (cons c0 (concat (cdr (assoc c0 chars)) "1")) chars)
+ (push (cons c1 (concat (cdr (assoc c1 chars))
+ (concat "2" comstyle)))
+ chars)))
+ (if (= (length end) 1)
+ (modify-syntax-entry (aref end 0)
+ (concat "> " comstyle nested) st)
+ (let ((c0 (aref end 0)) (c1 (aref end 1)))
+ ;; Store the relevant info but don't update yet.
+ (push (cons c0 (concat (cdr (assoc c0 chars))
+ (concat "3" comstyle)))
+ chars)
+ (push (cons c1 (concat (cdr (assoc c1 chars)) "4")) chars)))))
+
+ ;; Process the chars that were part of a 2-char comment marker
+ (with-syntax-table st ;For `char-syntax'.
+ (dolist (cs (nreverse chars))
+ (modify-syntax-entry (car cs)
+ (concat (char-to-string (char-syntax (car cs)))
+ " " (cdr cs))
+ st)))))
+
+(defun comment--set-comment-vars (comment-list)
+ (when comment-list
+ (let ((first (car comment-list)))
+ (setq-local comment-start (car first))
+ (setq-local comment-end
+ (let ((end (cadr first)))
+ (if (string-equal end "\n") "" end))))
+ (unless comment-start-skip ;Don't override manual setup.
+ (setq-local comment-start-skip
+ (concat (regexp-opt (mapcar #'car comment-list))
+ "+[ \t]*")))
+ (unless comment-end-skip ;Don't override manual setup.
+ (setq-local comment-end-skip
+ (concat "[ \t]*"
+ (regexp-opt (mapcar #'cadr comment-list)))))))
+
+(defun comment-set-syntax (st comment-list)
+ (comment--set-comment-syntax st comment-list)
+ (setf (gethash st comment--set-table) comment-list))
+
+(defun comment-get-syntax (&optional st)
+ (unless st (setq st (syntax-table)))
+ (or (gethash st comment--set-table)
+ (let ((parent (char-table-parent st)))
+ (when parent (comment-get-syntax parent)))))
+
;;;;
;;;; Helpers
;;;;
function should first call this function explicitly."
(unless (and (not comment-start) noerror)
(unless comment-start
- (let ((cs (read-string "No comment syntax is defined. Use: ")))
- (if (zerop (length cs))
- (error "No comment syntax defined")
- (set (make-local-variable 'comment-start) cs)
- (set (make-local-variable 'comment-start-skip) cs))))
+ (let ((comment-list (comment-get-syntax)))
+ (if comment-list
+ (comment--set-comment-vars comment-list)
+ (let ((cs (read-string "No comment syntax is defined. Use: ")))
+ (if (zerop (length cs))
+ (error "No comment syntax defined")
+ (set (make-local-variable 'comment-start) cs)
+ (set (make-local-variable 'comment-start-skip) cs))))))
;; comment-use-syntax
(when (eq comment-use-syntax 'undecided)
(set (make-local-variable 'comment-use-syntax)
(cond ((not scheme)
(unless pattern
(rng-uri-error "URI `%s' does not have a scheme" uri)))
- ((not (string= (downcase scheme) "file"))
- (rng-uri-error "URI `%s' does not use the `file:' scheme" uri)))
- (when (not (member authority
- (cons (system-name) '(nil "" "localhost"))))
+ ((not (member (downcase scheme) '("file" "http")))
+ (rng-uri-error "URI `%s' does not use the `file:' or `http:' scheme" uri)))
+ (when (and (equal (downcase scheme) "file")
+ (not (member authority
+ (cons (system-name) '(nil "" "localhost")))))
(rng-uri-error "URI `%s' does not start with `file:///' or `file://localhost/'"
uri))
(when query
(comment
(xmltok+ (xmltok-g markup-declaration "!")
(xmltok-g comment-first-dash "-"
- (xmltok-g comment-open "-") opt) opt))
+ (xmltok-g comment-open "-") opt)
+ opt))
(cdata-section
(xmltok+ "!"
(xmltok-g marked-section-open "\\[")
"%" (xmltok-g param-entity-ref
ncname
(xmltok-g param-entity-ref-close
- ";") opt) opt))
+ ";")
+ opt)
+ opt))
(starts-with-nmtoken-not-name
(xmltok-g nmtoken
(xmltok-p name-continue-not-start-char or ":")
"!" (xmltok-p (xmltok-g comment-first-dash "-"
(xmltok-g comment-open "-") opt)
or (xmltok-g named-markup-declaration
- ncname)) opt))
+ ncname))
+ opt))
(after-lt
(xmltok+ markup-declaration
or (xmltok-g processing-instruction-question
(org-defkey map [(right)] 'org-goto-right)
(org-defkey map [(control ?g)] 'org-goto-quit)
(org-defkey map "\C-i" 'org-cycle)
- (org-defkey map [(tab)] 'org-cycle)
(org-defkey map [(down)] 'outline-next-visible-heading)
(org-defkey map [(up)] 'outline-previous-visible-heading)
(if org-goto-auto-isearch
(and (= c ?q) (not (rassoc c fulltable))))
(setq quit-flag t))
((= c ?\ ) nil)
- ((setq e (rassoc c fulltable) tg (car e))
- tg)
+ ((car (rassoc c fulltable)))
(t (setq quit-flag t)))))))
(defun org-entry-is-todo-p ()
(setq current (delete tg current))
(push tg current)))
(when exit-after-next (setq exit-after-next 'now)))
- ((setq e (rassoc c todo-table) tg (car e))
+ ((setq tg (car (rassoc c todo-table)))
(with-current-buffer buf
(save-excursion (org-todo tg)))
(when exit-after-next (setq exit-after-next 'now)))
- ((setq e (rassoc c ntable) tg (car e))
+ ((setq tg (car (rassoc c ntable)))
(if (member tg current)
(setq current (delete tg current))
(cl-loop for g in groups do
(defun org-diary-sexp-entry (sexp entry d)
"Process a SEXP diary ENTRY for date D."
+ ;; FIXME: Consolidate with diary-sexp-entry!
(require 'diary-lib)
;; `org-anniversary' and alike expect ENTRY and DATE to be bound
;; dynamically.
- (let* ((sexp `(let ((entry ,entry)
- (date ',d))
- ,(car (read-from-string sexp))))
+ (let* ((user-sexp (car (read-from-string sexp)))
+ (sexp `(let ((entry ,entry) (date ',d)) ,user-sexp))
(result (if calendar-debug-sexp (eval sexp)
- (condition-case nil
+ (condition-case err
(eval sexp)
(error
(beep)
- (message "Bad sexp at line %d in %s: %s"
+ (message "Bad sexp at line %d in %s: %S\nError: %S"
(org-current-line)
- (buffer-file-name) sexp)
+ (buffer-file-name) user-sexp err)
(sleep-for 2))))))
(cond ((stringp result) (split-string result "; "))
((and (consp result)
(not (consp (cdr result)))
- (stringp (cdr result))) (cdr result))
- ((and (consp result)
- (stringp (car result))) result)
+ (stringp (cdr result)))
+ (cdr result))
+ ((and (consp result) (stringp (car result)))
+ result)
(result entry))))
(defun org-diary-to-ical-string (frombuf)
(if (looking-at "\\s-*$") (delete-region (point) (point-at-eol))
(open-line 1))
(org-indent-line)
- (insert "# ")))
+ (insert comment-start)))
(defvar comment-empty-lines) ; From newcomment.el.
(defun org-comment-or-uncomment-region (beg end &rest _)
;; To use pcomplete with shell-mode, for example, you will need the
;; following in your init file:
;;
-;; (add-hook 'shell-mode-hook 'pcomplete-shell-setup)
+;; (add-hook 'shell-mode-hook #'pcomplete-shell-setup)
;;
;; Most of the code below simply provides support mechanisms for
;; writing completion functions. Completion functions themselves are
(defcustom pcomplete-file-ignore nil
"A regexp of filenames to be disregarded during file completion."
- :type '(choice regexp (const :tag "None" nil))
- :group 'pcomplete)
+ :type '(choice regexp (const :tag "None" nil)))
(defcustom pcomplete-dir-ignore nil
"A regexp of names to be disregarded during directory completion."
- :type '(choice regexp (const :tag "None" nil))
- :group 'pcomplete)
+ :type '(choice regexp (const :tag "None" nil)))
(defcustom pcomplete-ignore-case (memq system-type '(ms-dos windows-nt cygwin))
;; FIXME: the doc mentions file-name completion, but the code
;; seems to apply it to all completions.
"If non-nil, ignore case when doing filename completion."
- :type 'boolean
- :group 'pcomplete)
+ :type 'boolean)
(defcustom pcomplete-autolist nil
"If non-nil, automatically list possibilities on partial completion.
This mirrors the optional behavior of tcsh."
- :type 'boolean
- :group 'pcomplete)
+ :type 'boolean)
(defcustom pcomplete-suffix-list (list ?/ ?:)
"A list of characters which constitute a proper suffix."
- :type '(repeat character)
- :group 'pcomplete)
+ :type '(repeat character))
(make-obsolete-variable 'pcomplete-suffix-list nil "24.1")
(defcustom pcomplete-recexact nil
This mirrors the optional behavior of tcsh.
A non-nil value is useful if `pcomplete-autolist' is non-nil too."
- :type 'boolean
- :group 'pcomplete)
+ :type 'boolean)
(define-obsolete-variable-alias
'pcomplete-arg-quote-list 'comint-file-name-quote-list "24.3")
-(defcustom pcomplete-man-function 'man
+(defcustom pcomplete-man-function #'man
"A function to that will be called to display a manual page.
It will be passed the name of the command to document."
- :type 'function
- :group 'pcomplete)
+ :type 'function)
-(defcustom pcomplete-compare-entry-function 'string-lessp
+(defcustom pcomplete-compare-entry-function #'string-lessp
"This function is used to order file entries for completion.
The behavior of most all shells is to sort alphabetically."
:type '(radio (function-item string-lessp)
(function-item file-newer-than-file-p)
- (function :tag "Other"))
- :group 'pcomplete)
+ (function :tag "Other")))
(defcustom pcomplete-help nil
"A string or function (or nil) used for context-sensitive help.
result will be shown in the minibuffer.
If nil, the function `pcomplete-man-function' will be called with the
current command argument."
- :type '(choice string sexp (const :tag "Use man page" nil))
- :group 'pcomplete)
+ :type '(choice string sexp (const :tag "Use man page" nil)))
(defcustom pcomplete-expand-before-complete nil
"If non-nil, expand the current argument before completing it.
to be inserted in the buffer. Note that exactly what gets expanded
and how is entirely up to the behavior of the
`pcomplete-parse-arguments-function'."
- :type 'boolean
- :group 'pcomplete)
+ :type 'boolean)
(defcustom pcomplete-parse-arguments-function
- 'pcomplete-parse-buffer-arguments
+ #'pcomplete-parse-buffer-arguments
"A function to call to parse the current line's arguments.
It should be called with no parameters, and with point at the position
of the argument that is to be completed.
position of each argument, as it is seen by the user. The establishes
a relationship between the fully resolved value of the argument, and
the textual representation of the argument."
- :type 'function
- :group 'pcomplete)
+ :type 'function)
(defcustom pcomplete-cycle-completions t
"If non-nil, hitting the TAB key cycles through the completion list.
followed by any further matches on each subsequent pressing of the TAB
key. \\[pcomplete-list] is the key to press if the user wants to see
the list of possible completions."
- :type 'boolean
- :group 'pcomplete)
+ :type 'boolean)
(defcustom pcomplete-cycle-cutoff-length 5
"If the number of completions is greater than this, don't cycle.
possibilities, and therefore they are probably most interested in
cycling through the candidates. Set this value to nil if you want
cycling to always be enabled."
- :type '(choice integer (const :tag "Always cycle" nil))
- :group 'pcomplete)
+ :type '(choice integer (const :tag "Always cycle" nil)))
(defcustom pcomplete-restore-window-delay 1
"The number of seconds to wait before restoring completion windows.
set to nil, completion windows will be left on second until the user
removes them manually. If set to 0, they will disappear immediately
after the user enters a key other than TAB."
- :type '(choice integer (const :tag "Never restore" nil))
- :group 'pcomplete)
+ :type '(choice integer (const :tag "Never restore" nil)))
(defcustom pcomplete-try-first-hook nil
"A list of functions which are called before completing an argument.
This can be used, for example, for completing things which might apply
to all arguments, such as variable names after a $."
- :type 'hook
- :group 'pcomplete)
+ :type 'hook)
(defsubst pcomplete-executables (&optional regexp)
"Complete amongst a list of directories and executables."
(lambda ()
(pcomplete-here (pcomplete-executables))))
"Function called for completing the initial command argument."
- :type 'function
- :group 'pcomplete)
+ :type 'function)
-(defcustom pcomplete-command-name-function 'pcomplete-command-name
+(defcustom pcomplete-command-name-function #'pcomplete-command-name
"Function called for determining the current command name."
- :type 'function
- :group 'pcomplete)
+ :type 'function)
(defcustom pcomplete-default-completion-function
(function
(while (pcomplete-here (pcomplete-entries)))))
"Function called when no completion rule can be found.
This function is used to generate completions for every argument."
- :type 'function
- :group 'pcomplete)
+ :type 'function)
(defcustom pcomplete-use-paring t
"If t, pare alternatives that have already been used.
If nil, you will always see the completion set of possible options, no
matter which of those options have already been used in previous
command arguments."
- :type 'boolean
- :group 'pcomplete)
+ :type 'boolean)
(defcustom pcomplete-termination-string " "
"A string that is inserted after any completion or expansion.
separator character, or if the completion occurs in a word that is
already terminated by a character, this variable should be locally
modified to be an empty string, or the desired separation string."
- :type 'string
- :group 'pcomplete)
+ :type 'string)
;;; Internal Variables:
;; between pcomplete-stub and the buffer's text is simply due to
;; some chars removed by unquoting. Again, this is not
;; indispensable but reduces the reliance on c-t-subvert and
- ;; improves corner case behaviors.
+ ;; improves corner case behaviors. See e.g. bug#34888.
(while (progn (setq buftext (pcomplete-unquote-argument
(buffer-substring beg (point))))
(and (> beg argbeg)
(setq table (completion-table-case-fold table)))
(list beg (point) table
:predicate pred
+ ;; FIXME: This might be useful even if `completions' is nil!
+ :context-help-function
+ (let ((ph pcomplete-help)) ;;Preserve the current value.
+ (lambda () (let ((pcomplete-help ph)) (pcomplete--help))))
:exit-function
;; If completion is finished, add a terminating space.
;; We used to also do this if STATUS is `sole', but
"Support extensible programmable completion.
To use this function, just bind the TAB key to it, or add it to your
completion functions list (it should occur fairly early in the list)."
+ (declare (obsolete "use `completion-at-point' with `pcomplete-completions-at-point' instead" "27.1"))
(interactive "p")
(if (and interactively
pcomplete-cycle-completions
;;;###autoload
(defun pcomplete-reverse ()
"If cycling completion is in use, cycle backwards."
+ (declare (obsolete ?? "27.1"))
(interactive)
(call-interactively 'pcomplete))
(defun pcomplete-expand-and-complete ()
"Expand the textual value of the current argument.
This will modify the current buffer."
+ (declare (obsolete "use pcomplete-expand and completion-at-point" "27.1"))
(interactive)
(let ((pcomplete-expand-before-complete t))
(pcomplete)))
;;;###autoload
(defun pcomplete-continue ()
"Complete without reference to any cycling completions."
+ ;; It doesn't seem to be used, so it's OK if we don't have a substitute.
+ (declare (obsolete nil "27.1"))
(interactive)
(setq pcomplete-current-completions nil
pcomplete-last-completion-raw nil)
"Expand the textual value of the current argument.
This will modify the current buffer."
(interactive)
- (let ((pcomplete-expand-before-complete t)
- (pcomplete-expand-only-p t))
- (pcomplete)
- (when (and pcomplete-current-completions
- (> (length pcomplete-current-completions) 0)) ;??
- (delete-char (- pcomplete-last-completion-length))
- (while pcomplete-current-completions
- (unless (pcomplete-insert-entry
- "" (car pcomplete-current-completions) t
- pcomplete-last-completion-raw)
- (insert-and-inherit pcomplete-termination-string))
- (setq pcomplete-current-completions
- (cdr pcomplete-current-completions))))))
+ (setq pcomplete-current-completions nil
+ pcomplete-last-completion-raw nil)
+ (catch 'pcompleted
+ (let* ((pcomplete-stub)
+ pcomplete-seen pcomplete-norm-func
+ pcomplete-args pcomplete-last pcomplete-index
+ (pcomplete-autolist pcomplete-autolist)
+ (pcomplete-suffix-list pcomplete-suffix-list)
+ (pcomplete-expand-only-p t))
+ (pcomplete-parse-arguments 'expand-before-complete)))
+ ;; FIXME: What is this doing?
+ (when (and pcomplete-current-completions
+ (> (length pcomplete-current-completions) 0)) ;??
+ (delete-char (- pcomplete-last-completion-length))
+ (dolist (c (prog1 pcomplete-current-completions
+ (setq pcomplete-current-completions nil)))
+ (unless (pcomplete-insert-entry "" c t
+ pcomplete-last-completion-raw)
+ (insert-and-inherit pcomplete-termination-string)))))
;;;###autoload
(defun pcomplete-help ()
"Display any help information relative to the current argument."
- (interactive)
- (let ((pcomplete-show-help t))
- (pcomplete)))
+ (interactive) ;FIXME!
+ ;; (declare (obsolete ?? "27.1"))
+ (let* ((data (pcomplete-completions-at-point))
+ (helpfun (plist-get (nthcdr 3 data) :context-help-function)))
+ (if helpfun
+ (funcall helpfun)
+ (message "No context-sensitive help available"))))
;;;###autoload
(defun pcomplete-list ()
"Show the list of possible completions for the current argument."
+ (declare (obsolete completion-help-at-point "27.1"))
(interactive)
(when (and pcomplete-cycle-completions
pcomplete-current-completions
dynamic-complete-functions are kept. For comint mode itself,
this is `comint-dynamic-complete-functions'."
(set (make-local-variable 'pcomplete-parse-arguments-function)
- 'pcomplete-parse-comint-arguments)
+ #'pcomplete-parse-comint-arguments)
(add-hook 'completion-at-point-functions
- 'pcomplete-completions-at-point nil 'local)
+ #'pcomplete-completions-at-point nil 'local)
(set (make-local-variable completef-sym)
(copy-sequence (symbol-value completef-sym)))
(let* ((funs (symbol-value completef-sym))
(or (eq action t)
(eq (car-safe action) 'boundaries))))
(let ((newstring
- (mapconcat 'identity (nreverse (cons string strings)) "")))
+ (mapconcat #'identity (nreverse (cons string strings)) "")))
;; FIXME: We could also try to return unexpanded envvars.
(complete-with-action action table newstring pred))
(let* ((envpos (apply #'+ (mapcar #' length strings)))
(newstring
- (mapconcat 'identity (nreverse (cons string strings)) ""))
+ (mapconcat #'identity (nreverse (cons string strings)) ""))
(bounds (completion-boundaries newstring table pred
(or (cdr-safe action) ""))))
(if (>= (car bounds) envpos)
;; pare it down, if applicable
(when (and pcomplete-use-paring pcomplete-seen)
(setq pcomplete-seen
- (mapcar 'directory-file-name pcomplete-seen))
+ (mapcar #'directory-file-name pcomplete-seen))
(dolist (p pcomplete-seen)
(add-to-list 'pcomplete-seen
(funcall pcomplete-norm-func p)))
(setq completions
- (apply-partially 'completion-table-with-predicate
+ (apply-partially #'completion-table-with-predicate
completions
(when pcomplete-seen
(lambda (f)
(defun pcomplete--help ()
"Produce context-sensitive help for the current argument.
If specific documentation can't be given, be generic."
- (if (and pcomplete-help
- (or (and (stringp pcomplete-help)
- (fboundp 'Info-goto-node))
- (listp pcomplete-help)))
- (if (listp pcomplete-help)
- (message "%s" (eval pcomplete-help))
- (save-window-excursion (info))
- (switch-to-buffer-other-window "*info*")
- (funcall (symbol-function 'Info-goto-node) pcomplete-help))
+ (cond
+ ((functionp pcomplete-help) (funcall pcomplete-help))
+ ((consp pcomplete-help)
+ (message "%s" (eval pcomplete-help t)))
+ ((and (stringp pcomplete-help)
+ (fboundp 'Info-goto-node))
+ (save-window-excursion (info))
+ (switch-to-buffer-other-window "*info*")
+ (Info-goto-node pcomplete-help))
+ (t
(if pcomplete-man-function
(let ((cmd (funcall pcomplete-command-name-function)))
(if (and cmd (> (length cmd) 0))
(funcall pcomplete-man-function cmd)))
- (message "No context-sensitive help available"))))
+ (message "No context-sensitive help available")))))
;; general utilities
l)
(define-obsolete-function-alias
'pcomplete-uniqify-list
- 'pcomplete-uniquify-list "27.1")
+ #'pcomplete-uniquify-list "27.1")
(defun pcomplete-process-result (cmd &rest args)
"Call CMD using `call-process' and return the simplest result."
(with-temp-buffer
- (apply 'call-process cmd nil t nil args)
+ (apply #'call-process cmd nil t nil args)
(skip-chars-backward "\n")
(buffer-substring (point-min) (point))))
;; and `after-change-functions'. Note that this variable is not set when
;; `c-before-change' is invoked by a change to text properties.
+(defvar c--use-syntax-propertize t)
+
(defun c-basic-common-init (mode default-style)
"Do the necessary initialization for the syntax handling routines
and the line breaking/filling code. Intended to be used by other
;; Install the functions that ensure that various internal caches
;; don't become invalid due to buffer changes.
- (when (featurep 'xemacs)
- (make-local-hook 'before-change-functions)
- (make-local-hook 'after-change-functions))
- (add-hook 'before-change-functions 'c-before-change nil t)
- (setq c-just-done-before-change nil)
- ;; FIXME: We should use the new `depth' arg in Emacs-27 (e.g. a depth of -10
- ;; would do since font-lock uses a(n implicit) depth of 0) so we don't need
- ;; c-after-font-lock-init.
- (add-hook 'after-change-functions 'c-after-change nil t)
+ (if c--use-syntax-propertize
+ (setq-local syntax-propertize-function
+ (lambda (start end)
+ (c-before-change start (point-max))
+ (c-after-change start end (- end start))))
+ (when (featurep 'xemacs)
+ (make-local-hook 'before-change-functions)
+ (make-local-hook 'after-change-functions))
+ (add-hook 'before-change-functions 'c-before-change nil t)
+ (setq c-just-done-before-change nil)
+ ;; FIXME: We should use the new `depth' arg in Emacs-27 (e.g. a depth of -10
+ ;; would do since font-lock uses a(n implicit) depth of 0) so we don't need
+ ;; c-after-font-lock-init.
+ (add-hook 'after-change-functions 'c-after-change nil t))
(when (boundp 'font-lock-extend-after-change-region-function)
(set (make-local-variable 'font-lock-extend-after-change-region-function)
'c-extend-after-change-region))) ; Currently (2009-05) used by all
(widen)
(setq c-new-BEG (point-min))
(setq c-new-END (point-max))
- (save-excursion
- (let (before-change-functions after-change-functions)
- (mapc (lambda (fn)
- (funcall fn (point-min) (point-max)))
- c-get-state-before-change-functions)
- (mapc (lambda (fn)
- (funcall fn (point-min) (point-max)
- (- (point-max) (point-min))))
- c-before-font-lock-functions))))
+ (unless c--use-syntax-propertize
+ (save-excursion
+ (let (before-change-functions after-change-functions)
+ (mapc (lambda (fn)
+ (funcall fn (point-min) (point-max)))
+ c-get-state-before-change-functions)
+ (mapc (lambda (fn)
+ (funcall fn (point-min) (point-max)
+ (- (point-max) (point-min))))
+ c-before-font-lock-functions)
+ ))))
(set (make-local-variable 'outline-regexp) "[^#\n\^M]")
(set (make-local-variable 'outline-level) 'c-outline-level)
;;
;; Type a space in the first blank line, and the fontification of the next
;; line was fouled up by context fontification.
+ (when c--use-syntax-propertize
+ ;; This should also update c-new-END and c-new-BEG.
+ (syntax-propertize end)
+ ;; FIXME: Apparently `c-new-END' may be left unchanged to a stale value,
+ ;; presumably when the buffer gets truncated.
+ (if (> c-new-END (point-max)) (setq c-new-END (point-max))))
(let (new-beg new-end new-region case-fold-search)
(if (and c-in-after-change-fontification
(< beg c-new-END) (> end c-new-BEG))
(defun c-after-font-lock-init ()
;; Put on `font-lock-mode-hook'. This function ensures our after-change
;; function will get executed before the font-lock one.
- (when (memq #'c-after-change after-change-functions)
+ (when (and c--use-syntax-propertize
+ (memq #'c-after-change after-change-functions))
(remove-hook 'after-change-functions #'c-after-change t)
(add-hook 'after-change-functions #'c-after-change nil t)))
(when (eq font-lock-support-mode 'jit-lock-mode)
(save-restriction
(widen)
+ ;; FIXME: This presumes that c-new-BEG and c-new-END have been set
+ ;; I guess from the before-change-function.
(c-save-buffer-state () ; Protect the undo-list from put-text-property.
(if (< c-new-BEG beg)
(put-text-property c-new-BEG beg 'fontified nil))
(if (> c-new-END end)
- (put-text-property end c-new-END 'fontified nil)))))
+ (put-text-property end (min c-new-END (point-max))
+ 'fontified nil)))))
(cons c-new-BEG c-new-END))
;; Emacs < 22 and XEmacs
:type 'string
:group 'cperl-help-system)
-(defcustom cperl-use-syntax-table-text-property
- (boundp 'parse-sexp-lookup-properties)
+(defcustom cperl-use-syntax-table-text-property t
"Non-nil means CPerl sets up and uses `syntax-table' text property."
:type 'boolean
:group 'cperl-speed)
`fill-paragraph' on a comment may leave the point behind the
paragraph. It also triggers a bug in some versions of Emacs (CPerl tries
-to detect it and bulk out).
-
-See documentation of a variable `cperl-problems-old-emaxen' for the
-problems which disappear if you upgrade Emacs to a reasonably new
-version (20.3 for Emacs, and those of 2004 for XEmacs).")
-
-(defvar cperl-problems-old-emaxen 'please-ignore-this-line
- "Description of problems in CPerl mode specific for older Emacs versions.
-
-Emacs had a _very_ restricted syntax parsing engine until version
-20.1. Most problems below are corrected starting from this version of
-Emacs, and all of them should be fixed in version 20.3. (Or apply
-patches to Emacs 19.33/34 - see tips.) XEmacs was very backward in
-this respect (until 2003).
-
-Note that even with newer Emacsen in some very rare cases the details
-of interaction of `font-lock' and syntaxification may be not cleaned
-up yet. You may get slightly different colors basing on the order of
-fontification and syntaxification. Say, the initial faces is correct,
-but editing the buffer breaks this.
-
-Even with older Emacsen CPerl mode tries to corrects some Emacs
-misunderstandings, however, for efficiency reasons the degree of
-correction is different for different operations. The partially
-corrected problems are: POD sections, here-documents, regexps. The
-operations are: highlighting, indentation, electric keywords, electric
-braces.
-
-This may be confusing, since the regexp s#//#/#; may be highlighted
-as a comment, but it will be recognized as a regexp by the indentation
-code. Or the opposite case, when a POD section is highlighted, but
-may break the indentation of the following code (though indentation
-should work if the balance of delimiters is not broken by POD).
-
-The main trick (to make $ a \"backslash\") makes constructions like
-${aaa} look like unbalanced braces. The only trick I can think of is
-to insert it as $ {aaa} (valid in perl5, not in perl4).
-
-Similar problems arise in regexps, when /(\\s|$)/ should be rewritten
-as /($|\\s)/. Note that such a transposition is not always possible.
-
-The solution is to upgrade your Emacs or patch an older one. Note
-that Emacs 20.2 has some bugs related to `syntax-table' text
-properties. Patches are available on the main CPerl download site,
-and on CPAN.
-
-If these bugs cannot be fixed on your machine (say, you have an inferior
-environment and cannot recompile), you may still disable all the fancy stuff
-via `cperl-use-syntax-table-text-property'.")
+to detect it and bulk out).")
(defvar cperl-praise 'please-ignore-this-line
"Advantages of CPerl mode.
(bound-and-true-p
gdb-active-process)))))
([go] menu-item (if (bound-and-true-p gdb-active-process)
- "Continue" "Run") gud-go
+ "Continue" "Run")
+ gud-go
:visible (and (eq gud-minor-mode 'gdbmi)
(gdb-show-run-p)))
([stop] menu-item "Stop" gud-stop-subjob
(eq gud-minor-mode 'gdbmi)))
([print*] menu-item (if (eq gud-minor-mode 'jdb)
"Dump object"
- "Print Dereference") gud-pstar
+ "Print Dereference")
+ gud-pstar
:enable (not gud-running)
:visible (memq gud-minor-mode '(gdbmi gdb jdb)))
([print] menu-item "Print Expression" gud-print
;;; Added by Tom Perrine (TEP)
(defvar m2-mode-syntax-table
(let ((table (make-syntax-table)))
+ ;; FIXME: nesting!
+ ;; FIXME: `comment-indent' just inserts "(**)" whereas the old code
+ ;; resulted in a nicer "(* *)"!
+ (comment-set-syntax table '(("(*" . "*)") ("//" . "\n")))
(modify-syntax-entry ?\\ "\\" table)
- (modify-syntax-entry ?/ ". 12" table)
- (modify-syntax-entry ?\n ">" table)
- (modify-syntax-entry ?\( "()1" table)
- (modify-syntax-entry ?\) ")(4" table)
- (modify-syntax-entry ?* ". 23nb" table)
(modify-syntax-entry ?+ "." table)
(modify-syntax-entry ?- "." table)
(modify-syntax-entry ?= "." table)
(let ((tok (smie-default-backward-token)))
(cond
((zerop (length tok))
- (let ((forward-sexp-function nil))
- (condition-case nil
- (forward-sexp -1)
- (scan-error (setq res ":")))))
+ (if (bobp) (setq res ":")
+ (let ((forward-sexp-function nil))
+ (condition-case nil
+ (forward-sexp -1)
+ (scan-error (setq res ":"))))))
((member tok '("|" "OF" "..")) (setq res ":-case"))
((member tok '(":" "END" ";" "BEGIN" "VAR" "RECORD" "PROCEDURE"))
(setq res ":")))))
(set (make-local-variable 'paragraph-start) (concat "$\\|" page-delimiter))
(set (make-local-variable 'paragraph-separate) paragraph-start)
(set (make-local-variable 'paragraph-ignore-fill-prefix) t)
- (set (make-local-variable 'comment-start) "(* ")
- (set (make-local-variable 'comment-end) " *)")
- (set (make-local-variable 'comment-start-skip) "\\(?:(\\*+\\|//+\\) *")
(set (make-local-variable 'parse-sexp-ignore-comments) t)
(set (make-local-variable 'font-lock-defaults)
'((m3-font-lock-keywords
;; OS specific
"VMSError" "WindowsError"
)
- symbol-end) . font-lock-type-face)
+ symbol-end)
+ . font-lock-type-face)
;; assignments
;; support for a = b = c = 5
(,(lambda (limit)
((rx (or "\"\"\"" "'''"))
(0 (ignore (python-syntax-stringify))))))
+;; Always define the alias(es) *before* the variable.
(define-obsolete-variable-alias 'python--prettify-symbols-alist
'python-prettify-symbols-alist "26.1")
(found-path (if (file-exists-p xdg-path) xdg-path oldstyle-path)))
found-path))
+(defcustom gc-cons-opportunistic-idle-time 5
+ "Number of seconds before trying an opportunistic GC.
+After this number of seconds of idle time, Emacs tries to collect
+garbage more eagerly (i.e. with thresholds halved) in the hope
+to avoid running the GC later during non-idle time."
+ :type 'integer)
+
(defun command-line ()
"A subroutine of `normal-top-level'.
Amongst another things, it parses the command-line arguments."
(eq face-ignored-fonts old-face-ignored-fonts))
(clear-face-cache)))
+ ;; Start opportunistic GC (after loading the init file, so we obey
+ ;; its settings). This is desirable for two reason:
+ ;; - It reduces the number of times we have to GC in the middle of
+ ;; an operation.
+ ;; - It means we GC when the C stack is short, reducing the risk of false
+ ;; positives from the conservative stack scanning.
+ (when gc-cons-opportunistic-idle-time
+ (run-with-idle-timer gc-cons-opportunistic-idle-time t
+ #'garbage-collect-maybe 2))
+
(setq after-init-time (current-time))
;; Display any accumulated warnings after all functions in
;; `after-init-hook' like `desktop-read' have finalized possible
"Return a copy of SEQ with all occurrences of ELT removed.
SEQ must be a list, vector, or string. The comparison is done with `equal'."
(declare (side-effect-free t))
- (if (nlistp seq)
- ;; If SEQ isn't a list, there's no need to copy SEQ because
- ;; `delete' will return a new object.
- (delete elt seq)
- (delete elt (copy-sequence seq))))
+ (delete elt (if (nlistp seq)
+ ;; If SEQ isn't a list, there's no need to copy SEQ because
+ ;; `delete' will return a new object.
+ seq
+ (copy-sequence seq))))
(defun remq (elt list)
"Return LIST with all occurrences of ELT removed.
`edmacro-mode').
For an approximate inverse of this, see `key-description'."
+ (declare (pure t))
;; Don't use a defalias, since the `pure' property is only true for
;; the calling convention of `kbd'.
(read-kbd-macro keys))
-(put 'kbd 'pure t)
(defun undefined ()
"Beep to tell the user this binding is undefined."
(defalias 'flatten-list 'flatten-tree)
;; The initial anchoring is for better performance in searching matches.
+(defun internal--opportunistic-gc ()
+ "Run the GC during idle time."
+ (let ((gc-cons-threshold (/ gc-cons-threshold 2))
+ ;; FIXME: This doesn't work because it's only consulted at the end
+ ;; of a GC in order to set the next `gc_relative_threshold'!
+ (gc-cons-percentage (/ gc-cons-percentage 2)))
+ ;; HACK ATTACK: the purpose of this dummy call to `eval' is to call
+ ;; `maybe_gc', so we will trigger a GC if we allocated half of the maximum
+ ;; allowed before the GC is forced upon us.
+ (eval 1 t)))
+
(defconst regexp-unmatchable "\\`a\\`"
"Standard regexp guaranteed not to match any string at all.")
(t (error "Unsupported number of xterm colors (%d)" (+ 16 ncolors)))))
;; Modifying color mappings means realized faces don't use the
;; right colors, so clear them.
+ ;; FIXME: Only for the selected frame!
(clear-face-cache)))
(defun xterm-maybe-set-dark-background-mode (redc greenc bluec)
(goto-char start-point)
(forward-comment (- (point)))
(skip-chars-backward "@[:alpha:]")
- (unless (looking-at-p "@\\(mixin\\|include\\)")
+ (unless (looking-at-p "@\\(?:mixin\\|include\\)")
(cdr color)))))
(defun css--compute-color (start-point match)
(equal hash (buffer-hash)))
(set-buffer-modified-p nil)))))
+(defun unfill-paragraph ()
+ "That thing."
+ (interactive)
+ (let ((fill-column (/ most-positive-fixnum 2)))
+ (fill-paragraph)))
+
(declare-function comment-search-forward "newcomment" (limit &optional noerror))
(declare-function comment-string-strip "newcomment" (str beforep afterp))
(set-window-dedicated-p window t)
window)))))
-(defcustom special-display-function 'special-display-popup-frame
+(defcustom special-display-function #'special-display-popup-frame
"Function to call for displaying special buffers.
This function is called with two arguments - the buffer and,
optionally, a list - and should return a window displaying that
(setf (terminal-parameter nil 'xterm-mouse-last-down) nil)
(cond
((null down)
- ;; This is an "up-only" event. Pretend there was an up-event
+ ;; This is an "up-only" event. Pretend there was a down-event
;; right before and keep the up-event for later.
(push event unread-command-events)
(vector (cons (intern (replace-regexp-in-string
garbage_collect_1 (&gcst);
}
+DEFUN ("garbage-collect-maybe", Fgarbage_collect_maybe, Sgarbage_collect_maybe, 1, 1, "",
+ doc: /* Call `garbage-collect' if enough allocation happened.
+FACTOR determines what "enough" means here:
+a FACTOR of N means to run the GC if more than 1/Nth of the allocations
+needed to triger automatic allocation took place. */)
+ (Lisp_Object factor)
+{
+ CHECK_FIXNAT (factor);
+ EMACS_INT fact = XFIXNAT (factor);
+ byte_ct new_csgc = consing_since_gc * fact;
+ if (new_csgc / fact != consing_since_gc)
+ /* Overflow! */
+ garbage_collect ();
+ else
+ {
+ consing_since_gc = new_csgc;
+ maybe_gc ();
+ consing_since_gc /= fact;
+ }
+ return Qnil;
+}
+
DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
doc: /* Reclaim storage for Lisp objects no longer needed.
Garbage collection happens automatically if you cons more than
defsubr (&Smake_finalizer);
defsubr (&Spurecopy);
defsubr (&Sgarbage_collect);
+ defsubr (&Sgarbage_collect_maybe);
defsubr (&Smemory_info);
defsubr (&Smemory_use_counts);
defsubr (&Ssuspicious_object);
/* If there is still no input available, ask for GC. */
if (!detect_input_pending_run_timers (0))
- maybe_gc ();
+ maybe_gc (); /* FIXME: Why? */
}
/* Notify the caller if an autosave hook, or a timer, sentinel or
(call-interactively (key-binding `[,last-command-event])))
(should (equal (buffer-string) "int main () {\n \n}"))))
-(define-derived-mode plainer-c-mode c-mode "pC"
- "A plainer/saner C-mode with no internal electric machinery."
- (c-toggle-electric-state -1)
- (setq-local electric-indent-local-mode-hook nil)
- (setq-local electric-indent-mode-hook nil)
- (electric-indent-local-mode 1)
- (dolist (key '(?\" ?\' ?\{ ?\} ?\( ?\) ?\[ ?\]))
- (local-set-key (vector key) 'self-insert-command)))
-
(ert-deftest electric-modes-int-main-allman-style ()
(ert-with-test-buffer ()
(plainer-c-mode)
'completion-table-with-predicate
full-collection no-A nil))))))
-(ert-deftest completion-table-subvert-test ()
+(ert-deftest completion-table-subvert-test () ;bug#34888
(let* ((origtable '("A-hello" "A-there"))
(subvtable (completion-table-subvert origtable "B" "A")))
(should (equal (try-completion "B-hel" subvtable)
:tags '(:expensive-test)
(skip-unless (tramp--test-enabled))
(skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p)))
-
+ (defvar tramp-display-escape-sequence-regexp) ;Defined in tramp-sh.el
(dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let* ((tmp-name (tramp--test-make-temp-name nil quoted))
(fnnd (file-name-nondirectory tmp-name))
projects / emacs.git / commitdiff