-;;; subr.el --- basic lisp subroutines for Emacs -*- coding: utf-8; lexical-binding:t -*-
+;;; subr.el --- basic lisp subroutines for Emacs -*- lexical-binding:t -*-
-;; Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2015 Free Software
+;; Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2016 Free Software
;; Foundation, Inc.
;; Maintainer: emacs-devel@gnu.org
letter but *do not* end with a period. Please follow this convention
for the sake of consistency."
(declare (advertised-calling-convention (string &rest args) "23.1"))
- (signal 'error (list (apply 'format args))))
+ (signal 'error (list (apply #'format-message args))))
(defun user-error (format &rest args)
"Signal a pilot error, making error message by passing all args to `format'.
This is just like `error' except that `user-error's are expected to be the
result of an incorrect manipulation on the part of the user, rather than the
result of an actual problem."
- (signal 'user-error (list (apply #'format format args))))
+ (signal 'user-error (list (apply #'format-message format args))))
(defun define-error (name message &optional parent)
"Define NAME as a new error signal.
Store the result in LIST and return it. LIST must be a proper list.
Of several `equal' occurrences of an element in LIST, the first
one is kept."
- (let ((tail list))
- (while tail
- (setcdr tail (delete (car tail) (cdr tail)))
- (setq tail (cdr tail))))
+ (let ((l (length list)))
+ (if (> l 100)
+ (let ((hash (make-hash-table :test #'equal :size l))
+ (tail list) retail)
+ (puthash (car list) t hash)
+ (while (setq retail (cdr tail))
+ (let ((elt (car retail)))
+ (if (gethash elt hash)
+ (setcdr tail (cdr retail))
+ (puthash elt t hash)
+ (setq tail retail)))))
+ (let ((tail list))
+ (while tail
+ (setcdr tail (delete (car tail) (cdr tail)))
+ (setq tail (cdr tail))))))
list)
;; See http://lists.gnu.org/archive/html/emacs-devel/2013-05/msg00204.html
First and last elements are considered consecutive if CIRCULAR is
non-nil."
(let ((tail list) last)
- (while (consp tail)
+ (while (cdr tail)
(if (equal (car tail) (cadr tail))
(setcdr tail (cddr tail))
- (setq last (car tail)
+ (setq last tail
tail (cdr tail))))
(if (and circular
- (cdr list)
- (equal last (car list)))
- (nbutlast list)
- list)))
+ last
+ (equal (car tail) (car list)))
+ (setcdr last nil)))
+ list)
(defun number-sequence (from &optional to inc)
"Return a sequence of numbers from FROM to TO (both inclusive) as a list.
(nconc (nreverse skipped) newdef)))
;; Look past a symbol that names a keymap.
(setq inner-def
- (or (indirect-function defn t) defn))
+ (or (indirect-function defn) defn))
;; For nested keymaps, we use `inner-def' rather than `defn' so as to
;; avoid autoloading a keymap. This is mostly done to preserve the
;; original non-autoloading behavior of pre-map-keymap times.
"Return the window row number in POSITION and character number in that row.
Return nil if POSITION does not contain the actual position; in that case
-\`posn-col-row' can be used to get approximate values.
+`posn-col-row' can be used to get approximate values.
POSITION should be a list of the form returned by the `event-start'
and `event-end' functions.
This function does not account for the width on display, like the
number of visual columns taken by a TAB or image. If you need
the coordinates of POSITION in character units, you should use
-\`posn-col-row', not this function."
+`posn-col-row', not this function."
(nth 6 position))
(defsubst posn-timestamp (position)
(defalias 'send-region 'process-send-region)
(defalias 'string= 'string-equal)
(defalias 'string< 'string-lessp)
+(defalias 'string> 'string-greaterp)
(defalias 'move-marker 'set-marker)
(defalias 'rplaca 'setcar)
(defalias 'rplacd 'setcdr)
exp
(let* ((sym (cadr list-var))
(append (eval append))
- (msg (format "`add-to-list' can't use lexical var `%s'; use `push' or `cl-pushnew'"
- sym))
+ (msg (format-message
+ "`add-to-list' can't use lexical var `%s'; use `push' or `cl-pushnew'"
+ sym))
;; Big ugly hack so we only output a warning during
;; byte-compilation, and so we can use
;; byte-compile-not-lexical-var-p to silence the warning
(defmacro delay-mode-hooks (&rest body)
"Execute BODY, but delay any `run-mode-hooks'.
These hooks will be executed by the first following call to
-`run-mode-hooks' that occurs outside any `delayed-mode-hooks' form.
+`run-mode-hooks' that occurs outside any `delay-mode-hooks' form.
Only affects hooks run in the current buffer."
(declare (debug t) (indent 0))
`(progn
;; compatibility
-(make-obsolete
- 'process-kill-without-query
- "use `process-query-on-exit-flag' or `set-process-query-on-exit-flag'."
- "22.1")
(defun process-kill-without-query (process &optional _flag)
"Say no query needed if PROCESS is running when Emacs is exited.
Optional second argument if non-nil says to require a query.
Value is t if a query was formerly required."
+ (declare (obsolete
+ "use `process-query-on-exit-flag' or `set-process-query-on-exit-flag'."
+ "22.1"))
(let ((old (process-query-on-exit-flag process)))
(set-process-query-on-exit-flag process nil)
old))
(aref keys 1)
key)))
(cancel-timer timer)
+ ;; For some reason, `read-key(-sequence)' leaves the prompt in the echo
+ ;; area, whereas `read-event' seems to empty it just before returning
+ ;; (bug#22714). So, let's mimic the behavior of `read-event'.
+ (message nil)
(use-global-map old-global-map))))
(defvar read-passwd-map
t)
((input-pending-p t)
nil)
- ((<= seconds 0)
+ ((or (<= seconds 0)
+ ;; We are going to call read-event below, which will record
+ ;; the the next key as part of the macro, even if that key
+ ;; invokes kmacro-end-macro, so if we are recording a macro,
+ ;; the macro will recursively call itself. In addition, when
+ ;; that key is removed from unread-command-events, it will be
+ ;; recorded the second time, so the macro will have each key
+ ;; doubled. This used to happen if a macro was defined with
+ ;; Flyspell mode active (because Flyspell calls sit-for in its
+ ;; post-command-hook, see bug #21329.) To avoid all that, we
+ ;; simply disable the wait when we are recording a macro.
+ defining-kbd-macro)
(or nodisp (redisplay)))
(t
(or nodisp (redisplay))
(t (setq temp-prompt (concat "Please answer y or n. "
prompt))))))))
((and (display-popup-menus-p)
+ last-input-event ; not during startup
(listp last-nonmenu-event)
use-dialog-box)
(setq prompt (funcall padded prompt t)
(or (eq event exit-char)
(eq event (event-convert-list exit-char))
(setq unread-command-events
- (append (this-single-command-raw-keys))))))
+ (append (this-single-command-raw-keys)
+ unread-command-events)))))
(delete-overlay ol))))
\f
"Determine the boundaries of the default tag, based on text at point.
Return a cons cell with the beginning and end of the found tag.
If there is no plausible default, return nil."
- (let (from to bound)
- (when (or (progn
- ;; Look at text around `point'.
- (save-excursion
- (skip-syntax-backward "w_") (setq from (point)))
- (save-excursion
- (skip-syntax-forward "w_") (setq to (point)))
- (> to from))
- ;; Look between `line-beginning-position' and `point'.
- (save-excursion
- (and (setq bound (line-beginning-position))
- (skip-syntax-backward "^w_" bound)
- (> (setq to (point)) bound)
- (skip-syntax-backward "w_")
- (setq from (point))))
- ;; Look between `point' and `line-end-position'.
- (save-excursion
- (and (setq bound (line-end-position))
- (skip-syntax-forward "^w_" bound)
- (< (setq from (point)) bound)
- (skip-syntax-forward "w_")
- (setq to (point)))))
- (cons from to))))
+ (bounds-of-thing-at-point 'symbol))
(defun find-tag-default ()
"Determine default tag to search for, based on text at point.
(declare-function w32-shell-dos-semantics "w32-fns" nil)
(defun shell-quote-argument (argument)
- "Quote ARGUMENT for passing as argument to an inferior shell."
+ "Quote ARGUMENT for passing as argument to an inferior shell.
+
+This function is designed to work with the syntax of your system's
+standard shell, and might produce incorrect results with unusual shells.
+See Info node `(elisp)Security Considerations'."
(cond
((eq system-type 'ms-dos)
;; Quote using double quotes, but escape any existing quotes in
(defun special-form-p (object)
"Non-nil if and only if OBJECT is a special form."
(if (and (symbolp object) (fboundp object))
- (setq object (indirect-function object t)))
+ (setq object (indirect-function object)))
(and (subrp object) (eq (cdr (subr-arity object)) 'unevalled)))
(defun macrop (object)
"Non-nil if and only if OBJECT is a macro."
- (let ((def (indirect-function object t)))
+ (let ((def (indirect-function object)))
(when (consp def)
(or (eq 'macro (car def))
(and (autoloadp def) (memq (nth 4 def) '(macro t)))))))
(let ((inhibit-read-only t))
(dolist (handler yank-handled-properties)
(let ((prop (car handler))
- (fun (cdr handler))
- (run-start start))
- (while (< run-start end)
- (let ((value (get-text-property run-start prop))
- (run-end (next-single-property-change
- run-start prop nil end)))
- (funcall fun value run-start run-end)
- (setq run-start run-end)))))
- (if (eq yank-excluded-properties t)
- (set-text-properties start end nil)
- (remove-list-of-text-properties start end yank-excluded-properties))))
+ (fun (cdr handler))
+ (run-start start))
+ (while (< run-start end)
+ (let ((value (get-text-property run-start prop))
+ (run-end (next-single-property-change
+ run-start prop nil end)))
+ (funcall fun value run-start run-end)
+ (setq run-start run-end)))))
+ (with-silent-modifications
+ (if (eq yank-excluded-properties t)
+ (set-text-properties start end nil)
+ (remove-list-of-text-properties start end yank-excluded-properties)))))
(defvar yank-undo-function)
As a general recommendation, try to avoid using `looking-back'
wherever possible, since it is slow."
+ (declare
+ (advertised-calling-convention (regexp limit &optional greedy) "25.1"))
(let ((start (point))
(pos
(save-excursion
function. If it is a function, it is called with the actual text of each
match, and its value is used as the replacement text. When REP is called,
the match data are the result of matching REGEXP against a substring
-of STRING.
+of STRING, the same substring that is the actual text of the match which
+is passed to REP as its argument.
To replace only the first match (if any), make REGEXP match up to \\'
and replace a sub-expression, e.g.
(if (string-match "\\cR" str)
(concat str (propertize (string ?\x200e) 'invisible t))
str))
+
+(defun string-greaterp (string1 string2)
+ "Return non-nil if STRING1 is greater than STRING2 in lexicographic order.
+Case is significant.
+Symbols are also allowed; their print names are used instead."
+ (string-lessp string2 string1))
+
\f
;;;; Specifying things to do later.
file, FORM is evaluated immediately after the provide statement.
Usually FILE is just a library name like \"font-lock\" or a feature name
-like 'font-lock.
+like `font-lock'.
This function makes or adds to an entry on `after-load-alist'."
(declare (compiler-macro
(defmacro with-eval-after-load (file &rest body)
"Execute BODY after FILE is loaded.
FILE is normally a feature name, but it can also be a file name,
-in case that file does not provide any feature."
+in case that file does not provide any feature. See `eval-after-load'
+for more details about the different forms of FILE and their semantics."
(declare (indent 1) (debug t))
`(eval-after-load ,file (lambda () ,@body)))
;; discard the file name regexp
(mapc #'funcall (cdr a-l-element))))
;; Complain when the user uses obsolete files.
- (when (save-match-data
- (and (string-match "/obsolete/\\([^/]*\\)\\'" abs-file)
- (not (equal "loaddefs.el" (match-string 1 abs-file)))))
+ (when (string-match-p "/obsolete/\\([^/]*\\)\\'" abs-file)
;; Maybe we should just use display-warning? This seems yucky...
(let* ((file (file-name-nondirectory abs-file))
(msg (format "Package %s is obsolete!"
(defun remove-from-invisibility-spec (element)
"Remove ELEMENT from `buffer-invisibility-spec'."
- (if (consp buffer-invisibility-spec)
- (setq buffer-invisibility-spec
- (delete element buffer-invisibility-spec))))
+ (setq buffer-invisibility-spec
+ (if (consp buffer-invisibility-spec)
+ (delete element buffer-invisibility-spec)
+ (list t))))
\f
;;;; Syntax tables.
\f
;; Utility motion commands
+(defvar word-move-empty-char-table nil
+ "Used in `forward-word-strictly' and `backward-word-strictly'
+to countermand the effect of `find-word-boundary-function-table'.")
+
+(defun forward-word-strictly (&optional arg)
+ "Move point forward ARG words (backward if ARG is negative).
+If ARG is omitted or nil, move point forward one word.
+Normally returns t.
+If an edge of the buffer or a field boundary is reached, point is left there
+and the function returns nil. Field boundaries are not noticed if
+`inhibit-field-text-motion' is non-nil.
+
+This function is like `forward-word', but it is not affected
+by `find-word-boundary-function-table' (as set up by
+e.g. `subword-mode'). It is also not interactive."
+ (let ((find-word-boundary-function-table
+ (if (char-table-p word-move-empty-char-table)
+ word-move-empty-char-table
+ (setq word-move-empty-char-table (make-char-table nil)))))
+ (forward-word (or arg 1))))
+
+(defun backward-word-strictly (&optional arg)
+ "Move backward until encountering the beginning of a word.
+With argument ARG, do this that many times.
+If ARG is omitted or nil, move point backward one word.
+
+This function is like `forward-word', but it is not affected
+by `find-word-boundary-function-table' (as set up by
+e.g. `subword-mode'). It is also not interactive."
+ (let ((find-word-boundary-function-table
+ (if (char-table-p word-move-empty-char-table)
+ word-move-empty-char-table
+ (setq word-move-empty-char-table (make-char-table nil)))))
+ (forward-word (- (or arg 1)))))
+
;; Whitespace
(defun forward-whitespace (arg)
(defconst version-regexp-alist
- '(("^[-_+ ]?snapshot$" . -4)
+ '(("^[-._+ ]?snapshot$" . -4)
;; treat "1.2.3-20050920" and "1.2-3" as snapshot releases
- ("^[-_+]$" . -4)
+ ("^[-._+]$" . -4)
;; treat "1.2.3-CVS" as snapshot release
- ("^[-_+ ]?\\(cvs\\|git\\|bzr\\|svn\\|hg\\|darcs\\)$" . -4)
- ("^[-_+ ]?alpha$" . -3)
- ("^[-_+ ]?beta$" . -2)
- ("^[-_+ ]?\\(pre\\|rc\\)$" . -1))
+ ("^[-._+ ]?\\(cvs\\|git\\|bzr\\|svn\\|hg\\|darcs\\)$" . -4)
+ ("^[-._+ ]?alpha$" . -3)
+ ("^[-._+ ]?beta$" . -2)
+ ("^[-._+ ]?\\(pre\\|rc\\)$" . -1))
"Specify association between non-numeric version and its priority.
This association is used to handle version string like \"1.0pre2\",
String Version Integer List Version
\"0.9snapshot\" (0 9 -4)
\"1.0-git\" (1 0 -4)
+ \"1.0.cvs\" (1 0 -4)
\"1.0pre2\" (1 0 -1 2)
\"1.0PRE2\" (1 0 -1 2)
\"22.8beta3\" (22 8 -2 3)
Examples of valid version syntax:
- 1.0pre2 1.0.7.5 22.8beta3 0.9alpha1 6.9.30Beta
+ 1.0pre2 1.0.7.5 22.8beta3 0.9alpha1 6.9.30Beta 2.4.snapshot .5
Examples of invalid version syntax:
- 1.0prepre2 1.0..7.5 22.8X3 alpha3.2 .5
+ 1.0prepre2 1.0..7.5 22.8X3 alpha3.2
Examples of version conversion:
Version String Version as a List of Integers
- \"1.0.7.5\" (1 0 7 5)
- \"1.0pre2\" (1 0 -1 2)
- \"1.0PRE2\" (1 0 -1 2)
- \"22.8beta3\" (22 8 -2 3)
- \"22.8Beta3\" (22 8 -2 3)
- \"0.9alpha1\" (0 9 -3 1)
+ \".5\" (0 5)
+ \"0.9 alpha\" (0 9 -3)
\"0.9AlphA1\" (0 9 -3 1)
- \"0.9alpha\" (0 9 -3)
\"0.9snapshot\" (0 9 -4)
\"1.0-git\" (1 0 -4)
+ \"1.0.7.5\" (1 0 7 5)
+ \"1.0.cvs\" (1 0 -4)
+ \"1.0PRE2\" (1 0 -1 2)
+ \"1.0pre2\" (1 0 -1 2)
+ \"22.8 Beta3\" (22 8 -2 3)
+ \"22.8beta3\" (22 8 -2 3)
See documentation for `version-separator' and `version-regexp-alist'."
- (or (and (stringp ver) (> (length ver) 0))
- (error "Invalid version string: '%s'" ver))
+ (unless (stringp ver)
+ (error "Version must be a string"))
;; Change .x.y to 0.x.y
(if (and (>= (length ver) (length version-separator))
(string-equal (substring ver 0 (length version-separator))
version-separator))
(setq ver (concat "0" ver)))
+ (unless (string-match-p "^[0-9]" ver)
+ (error "Invalid version syntax: `%s' (must start with a number)" ver))
+
(save-match-data
(let ((i 0)
(case-fold-search t) ; ignore case in matching
lst s al)
+ ;; Parse the version-string up to a separator until there are none left
(while (and (setq s (string-match "[0-9]+" ver i))
(= s i))
- ;; handle numeric part
+ ;; Add the numeric part to the beginning of the version list;
+ ;; lst gets reversed at the end
(setq lst (cons (string-to-number (substring ver i (match-end 0)))
lst)
i (match-end 0))
(setq al (cdr al)))
(cond (al
(push (cdar al) lst))
- ;; Convert 22.3a to 22.3.1, 22.3b to 22.3.2, etc.
- ((string-match "^[-_+ ]?\\([a-zA-Z]\\)$" s)
+ ;; Convert 22.3a to 22.3.1, 22.3b to 22.3.2, etc., but only if
+ ;; the letter is the end of the version-string, to avoid
+ ;; 22.8X3 being valid
+ ((and (string-match "^[-._+ ]?\\([a-zA-Z]\\)$" s)
+ (= i (length ver)))
(push (- (aref (downcase (match-string 1 s)) 0) ?a -1)
lst))
- (t (error "Invalid version syntax: '%s'" ver))))))
- (if (null lst)
- (error "Invalid version syntax: '%s'" ver)
- (nreverse lst)))))
-
+ (t (error "Invalid version syntax: `%s'" ver))))))
+ (nreverse lst))))
(defun version-list-< (l1 l2)
"Return t if L1, a list specification of a version, is lower than L2.