X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/5d752c8a1c28e003ded0f2daa0d93eb12a31195a..401857eda39c57bd59a1e3a1dee57fd6420eeab5:/lisp/subr.el diff --git a/lisp/subr.el b/lisp/subr.el index b9a847d76e..0fb4a2ec25 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -1,6 +1,6 @@ -;;; 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 @@ -295,7 +295,7 @@ In Emacs, the convention is that error messages start with a capital 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'. @@ -305,7 +305,7 @@ for the sake of consistency. 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. @@ -426,8 +426,8 @@ one is kept." (let ((elt (car retail))) (if (gethash elt hash) (setcdr tail (cdr retail)) - (puthash elt t hash))) - (setq tail retail))) + (puthash elt t hash) + (setq tail retail))))) (let ((tail list)) (while tail (setcdr tail (delete (car tail) (cdr tail))) @@ -440,16 +440,16 @@ one is kept." 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. @@ -1213,14 +1213,14 @@ and `event-end' functions." "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) @@ -1384,6 +1384,7 @@ is converted into a string by expressing it in decimal." (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) @@ -1502,19 +1503,6 @@ All symbols are bound before the VALUEFORMs are evalled." ,@(mapcar (lambda (binder) `(setq ,@binder)) binders) ,@body)) -(defmacro let-when-compile (bindings &rest body) - "Like `let', but allow for compile time optimization. -Use BINDINGS as in regular `let', but in BODY each usage should -be wrapped in `eval-when-compile'. -This will generate compile-time constants from BINDINGS." - (declare (indent 1) (debug let)) - (cl-progv (mapcar #'car bindings) - (mapcar (lambda (x) (eval (cadr x))) bindings) - (macroexpand-all - (macroexp-progn - body) - macroexpand-all-environment))) - (defmacro with-wrapper-hook (hook args &rest body) "Run BODY, using wrapper functions from HOOK with additional ARGS. HOOK is an abnormal hook. Each hook function in HOOK \"wraps\" @@ -1605,8 +1593,9 @@ can do the job." 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 @@ -2097,6 +2086,10 @@ some sort of escape sequence, the ambiguity is resolved via `read-key-delay'." (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 @@ -2275,7 +2268,18 @@ floating point support." 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)) @@ -2347,6 +2351,7 @@ is nil and `use-dialog-box' is non-nil." (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) @@ -2537,7 +2542,8 @@ If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there." (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)))) @@ -2624,29 +2630,7 @@ See also `locate-user-emacs-file'.") "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. @@ -2709,7 +2693,11 @@ Note: :data and :device are currently not supported on Windows." (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 @@ -3834,6 +3822,13 @@ consisting of STR followed by an invisible left-to-right mark (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)) + ;;;; Specifying things to do later. @@ -3895,7 +3890,7 @@ If the feature is provided when evaluating code not associated with a 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 @@ -3950,7 +3945,8 @@ This function makes or adds to an entry on `after-load-alist'." (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))) @@ -4057,9 +4053,10 @@ that can be added." (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)))) ;;;; Syntax tables. @@ -4110,6 +4107,41 @@ If SYNTAX is nil, return nil." ;; 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) @@ -4672,14 +4704,14 @@ Usually the separator is \".\", but it can be any other string.") (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\", @@ -4689,6 +4721,7 @@ non-numeric part of a version string to an integer. For example: 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) @@ -4728,41 +4761,47 @@ in `version-regexp-alist'. 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)) @@ -4778,15 +4817,15 @@ See documentation for `version-separator' and `version-regexp-alist'." (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.