;;; subr.el --- basic lisp subroutines for Emacs -*- coding: utf-8; lexical-binding:t -*-
-;; Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2013 Free Software
+;; Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2014 Free Software
;; Foundation, Inc.
-;; Maintainer: FSF
+;; Maintainer: emacs-devel@gnu.org
;; Keywords: internal
;; Package: emacs
during the evaluation of the `defun' or `defmacro' form.
The possible values of SPECS are specified by
-`defun-declarations-alist' and `macro-declarations-alist'."
+`defun-declarations-alist' and `macro-declarations-alist'.
+
+For more information, see info node `(elisp)Declare Form'."
;; FIXME: edebug spec should pay attention to defun-declarations-alist.
nil)
configuration."
(and (consp object)
(eq (car object) 'frame-configuration)))
+
\f
;;;; List functions.
(nthcdr (1- (safe-length list)) list))))
(defun butlast (list &optional n)
- "Return a copy of LIST with the last N elements removed."
+ "Return a copy of LIST with the last N elements removed.
+If N is omitted or nil, the last element is removed from the
+copy."
(if (and n (<= n 0)) list
(nbutlast (copy-sequence list) n)))
(defun nbutlast (list &optional n)
- "Modifies LIST to remove the last N elements."
+ "Modifies LIST to remove the last N elements.
+If N is omitted or nil, remove the last element."
(let ((m (length list)))
(or n (setq n 1))
(and (< n m)
(if (> n 0) (setcdr (nthcdr (- (1- m) n) list) nil))
list))))
+(defun zerop (number)
+ "Return t if NUMBER is zero."
+ ;; Used to be in C, but it's pointless since (= 0 n) is faster anyway because
+ ;; = has a byte-code.
+ (declare (compiler-macro (lambda (_) `(= 0 ,number))))
+ (= 0 number))
+
(defun delete-dups (list)
"Destructively remove `equal' duplicates from LIST.
Store the result in LIST and return it. LIST must be a proper list.
(defun event-start (event)
"Return the starting position of EVENT.
-EVENT should be a click, drag, or key press event.
-If it is a key press event, the return value has the form
- (WINDOW POS (0 . 0) 0)
-If it is a click or drag event, it has the form
- (WINDOW AREA-OR-POS (X . Y) TIMESTAMP OBJECT POS (COL . ROW)
- IMAGE (DX . DY) (WIDTH . HEIGHT))
-The `posn-' functions access elements of such lists.
-For more information, see Info node `(elisp)Click Events'.
-
-If EVENT is a mouse or key press or a mouse click, this is the
-position of the event. If EVENT is a drag, this is the starting
-position of the drag."
+EVENT should be a mouse click, drag, or key press event. If
+EVENT is nil, the value of `posn-at-point' is used instead.
+
+The following accessor functions are used to access the elements
+of the position:
+
+`posn-window': The window the event is in.
+`posn-area': A symbol identifying the area the event occurred in,
+or nil if the event occurred in the text area.
+`posn-point': The buffer position of the event.
+`posn-x-y': The pixel-based coordinates of the event.
+`posn-col-row': The estimated column and row corresponding to the
+position of the event.
+`posn-actual-col-row': The actual column and row corresponding to the
+position of the event.
+`posn-string': The string object of the event, which is either
+nil or (STRING . POSITION)'.
+`posn-image': The image object of the event, if any.
+`posn-object': The image or string object of the event, if any.
+`posn-timestamp': The time the event occurred, in milliseconds.
+
+For more information, see Info node `(elisp)Click Events'."
(if (consp event) (nth 1 event)
(or (posn-at-point)
(list (selected-window) (point) '(0 . 0) 0))))
(defun event-end (event)
- "Return the ending location of EVENT.
+ "Return the ending position of EVENT.
EVENT should be a click, drag, or key press event.
-If EVENT is a key press event, the return value has the form
- (WINDOW POS (0 . 0) 0)
-If EVENT is a click event, this function is the same as
-`event-start'. For click and drag events, the return value has
-the form
- (WINDOW AREA-OR-POS (X . Y) TIMESTAMP OBJECT POS (COL . ROW)
- IMAGE (DX . DY) (WIDTH . HEIGHT))
-The `posn-' functions access elements of such lists.
-For more information, see Info node `(elisp)Click Events'.
-
-If EVENT is a mouse or key press or a mouse click, this is the
-position of the event. If EVENT is a drag, this is the starting
-position of the drag."
+
+See `event-start' for a description of the value returned."
(if (consp event) (nth (if (consp (nth 2 event)) 2 1) event)
(or (posn-at-point)
(list (selected-window) (point) '(0 . 0) 0))))
"Return the nominal column and row in POSITION, measured in characters.
The column and row values are approximations calculated from the x
and y coordinates in POSITION and the frame's default character width
-and height.
+and default line height, including spacing.
For a scroll-bar event, the result column is 0, and the row
corresponds to the vertical position of the click in the scroll bar.
POSITION should be a list of the form returned by the `event-start'
(make-obsolete 'unfocus-frame "it does nothing." "22.1")
(make-obsolete 'make-variable-frame-local
"explicitly check for a frame-parameter instead." "22.2")
-(set-advertised-calling-convention
- 'all-completions '(string collection &optional predicate) "23.1")
(set-advertised-calling-convention 'unintern '(name obarray) "23.3")
(set-advertised-calling-convention 'redirect-frame-focus '(frame focus-frame) "24.3")
(set-advertised-calling-convention 'decode-char '(ch charset) "21.4")
to the next hook function, if any. The last (or \"outermost\")
FUN is then called once."
(declare (indent 2) (debug (form sexp body))
- (obsolete "use a <foo>-function variable modified by add-function."
+ (obsolete "use a <foo>-function variable modified by `add-function'."
"24.4"))
;; We need those two gensyms because CL's lexical scoping is not available
;; for function arguments :-(
(defun add-to-list (list-var element &optional append compare-fn)
"Add ELEMENT to the value of LIST-VAR if it isn't there yet.
-The test for presence of ELEMENT is done with `equal',
-or with COMPARE-FN if that's non-nil.
+The test for presence of ELEMENT is done with `equal', or with
+COMPARE-FN if that's non-nil.
If ELEMENT is added, it is added at the beginning of the list,
unless the optional argument APPEND is non-nil, in which case
ELEMENT is added at the end.
The return value is the new value of LIST-VAR.
This is handy to add some elements to configuration variables,
-but please do not abuse it in Elisp code, where you are usually better off
-using `push' or `cl-pushnew'.
-
-If you want to use `add-to-list' on a variable that is not defined
-until a certain package is loaded, you should put the call to `add-to-list'
-into a hook function that will be run only after loading the package.
-`eval-after-load' provides one way to do this. In some cases
-other hooks, such as major mode hooks, can do the job."
+but please do not abuse it in Elisp code, where you are usually
+better off using `push' or `cl-pushnew'.
+
+If you want to use `add-to-list' on a variable that is not
+defined until a certain package is loaded, you should put the
+call to `add-to-list' into a hook function that will be run only
+after loading the package. `eval-after-load' provides one way to
+do this. In some cases other hooks, such as major mode hooks,
+can do the job."
(declare
(compiler-macro
(lambda (exp)
TYPE is `defun', `defvar', or `defface', that specifies function
definition, variable definition, or face definition only."
(if (and (or (null type) (eq type 'defun))
- (symbolp symbol) (fboundp symbol)
+ (symbolp symbol)
(autoloadp (symbol-function symbol)))
(nth 1 (symbol-function symbol))
(let ((files load-history)
(defun process-live-p (process)
"Returns non-nil if PROCESS is alive.
A process is considered alive if its status is `run', `open',
-`listen', `connect' or `stop'."
- (memq (process-status process)
- '(run open listen connect stop)))
+`listen', `connect' or `stop'. Value is nil if PROCESS is not a
+process."
+ (and (processp process)
+ (memq (process-status process)
+ '(run open listen connect stop))))
;; compatibility
Optional DEFAULT is a default password to use instead of empty input.
This function echoes `.' for each character that the user types.
+Note that in batch mode, the input is not hidden!
Once the caller uses the password, it can erase the password
by doing (clear-string STRING)."
(setq-local select-active-regions nil)
(use-local-map read-passwd-map)
(setq-local inhibit-modification-hooks nil) ;bug#15501.
+ (setq-local show-paren-mode nil) ;bug#16091.
(add-hook 'after-change-functions hide-chars-fun nil 'local))
(unwind-protect
(let ((enable-recursive-minibuffers t))
- (read-string prompt nil t default)) ; t = "no history"
+ (read-string
+ (if noninteractive
+ (format "%s[INPUT WILL NOT BE HIDDEN!] " prompt) ; bug#17839
+ prompt)
+ nil t default)) ; t = "no history"
(when (buffer-live-p minibuf)
(with-current-buffer minibuf
;; Not sure why but it seems that there might be cases where the
in milliseconds; this was useful when Emacs was built without
floating point support."
(declare (advertised-calling-convention (seconds &optional nodisp) "22.1"))
+ ;; This used to be implemented in C until the following discussion:
+ ;; http://lists.gnu.org/archive/html/emacs-devel/2006-07/msg00401.html
+ ;; Then it was moved to C using an implementation based on an idle timer,
+ ;; which was then replaced by the use of read-event.
(if (numberp nodisp)
(setq seconds (+ seconds (* 1e-3 nodisp))
nodisp obsolete)
;; FIXME: we should not read-event here at all, because it's much too
;; difficult to reliably "undo" a read-event by pushing it onto
;; unread-command-events.
- (let ((read (read-event nil t seconds)))
+ ;; For bug#14782, we need read-event to do the keyboard-coding-system
+ ;; decoding (hence non-nil as second arg under POSIX ttys).
+ ;; For bug#15614, we need read-event not to inherit-input-method.
+ ;; So we temporarily suspend input-method-function.
+ (let ((read (let ((input-method-function nil))
+ (read-event nil t seconds))))
(or (null read)
(progn
- ;; If last command was a prefix arg, e.g. C-u, push this event onto
- ;; unread-command-events as (t . EVENT) so it will be added to
- ;; this-command-keys by read-key-sequence.
- (if (eq overriding-terminal-local-map universal-argument-map)
- (setq read (cons t read)))
- (push read unread-command-events)
+ ;; https://lists.gnu.org/archive/html/emacs-devel/2006-10/msg00394.html
+ ;; We want `read' appear in the next command's this-command-event
+ ;; but not in the current one.
+ ;; By pushing (cons t read), we indicate that `read' has not
+ ;; yet been recorded in this-command-keys, so it will be recorded
+ ;; next time it's read.
+ ;; And indeed the `seconds' argument to read-event correctly
+ ;; prevented recording this event in the current command's
+ ;; this-command-keys.
+ (push (cons t read) unread-command-events)
nil))))))
;; Behind display-popup-menus-p test.
-(declare-function x-popup-dialog "xmenu.c" (position contents &optional header))
+(declare-function x-popup-dialog "menu.c" (position contents &optional header))
(defun y-or-n-p (prompt)
"Ask user a \"y or n\" question. Return t if answer is \"y\".
;; ¡Beware! when I tried to edebug this code, Emacs got into a weird state
;; where all the keys were unbound (i.e. it somehow got triggered
;; within read-key, apparently). I had to kill it.
- (let ((answer 'recenter))
+ (let ((answer 'recenter)
+ (padded (lambda (prompt &optional dialog)
+ (let ((l (length prompt)))
+ (concat prompt
+ (if (or (zerop l) (eq ?\s (aref prompt (1- l))))
+ "" " ")
+ (if dialog "" "(y or n) "))))))
(cond
(noninteractive
- (setq prompt (concat prompt
- (if (or (zerop (length prompt))
- (eq ?\s (aref prompt (1- (length prompt)))))
- "" " ")
- "(y or n) "))
+ (setq prompt (funcall padded prompt))
(let ((temp-prompt prompt))
(while (not (memq answer '(act skip)))
(let ((str (read-string temp-prompt)))
((and (display-popup-menus-p)
(listp last-nonmenu-event)
use-dialog-box)
- (setq answer
- (x-popup-dialog t `(,prompt ("Yes" . act) ("No" . skip)))))
+ (setq prompt (funcall padded prompt t)
+ answer (x-popup-dialog t `(,prompt ("Yes" . act) ("No" . skip)))))
(t
- (setq prompt (concat prompt
- (if (or (zerop (length prompt))
- (eq ?\s (aref prompt (1- (length prompt)))))
- "" " ")
- "(y or n) "))
+ (setq prompt (funcall padded prompt))
(while
(let* ((scroll-actions '(recenter scroll-up scroll-down
scroll-other-window scroll-other-window-down))
(discard-input))))
(let ((ret (eq answer 'act)))
(unless noninteractive
- ;; FIXME this prints one too many spaces, since prompt
- ;; already ends in a space. Eg "... (y or n) y".
- (message "%s %s" prompt (if ret "y" "n")))
+ (message "%s%c" prompt (if ret ?y ?n)))
ret)))
\f
When in a major mode that does not provide its own
`find-tag-default-function', return a regexp that matches the
symbol at point exactly."
- (let* ((tagf (or find-tag-default-function
- (get major-mode 'find-tag-default-function)
- 'find-tag-default))
- (tag (funcall tagf)))
- (cond ((null tag) nil)
- ((eq tagf 'find-tag-default)
- (format "\\_<%s\\_>" (regexp-quote tag)))
- (t (regexp-quote tag)))))
+ (let ((tag (funcall (or find-tag-default-function
+ (get major-mode 'find-tag-default-function)
+ 'find-tag-default))))
+ (if tag (regexp-quote tag))))
+
+(defun find-tag-default-as-symbol-regexp ()
+ "Return regexp that matches the default tag at point as symbol.
+If there is no tag at point, return nil.
+
+When in a major mode that does not provide its own
+`find-tag-default-function', return a regexp that matches the
+symbol at point exactly."
+ (let ((tag-regexp (find-tag-default-as-regexp)))
+ (if (and tag-regexp
+ (eq (or find-tag-default-function
+ (get major-mode 'find-tag-default-function)
+ 'find-tag-default)
+ 'find-tag-default))
+ (format "\\_<%s\\_>" tag-regexp)
+ tag-regexp)))
(defun play-sound (sound)
"SOUND is a list of the form `(sound KEYWORD VALUE...)'.
`(let* ((,modified (buffer-modified-p))
(buffer-undo-list t)
(inhibit-read-only t)
- (inhibit-modification-hooks t)
- deactivate-mark
- ;; Avoid setting and removing file locks and checking
- ;; buffer's uptodate-ness w.r.t the underlying file.
- buffer-file-name
- buffer-file-truename)
+ (inhibit-modification-hooks t))
(unwind-protect
(progn
,@body)
(defmacro with-demoted-errors (format &rest body)
"Run BODY and demote any errors to simple messages.
+FORMAT is a string passed to `message' to format any error message.
+It should contain a single %-sequence; e.g., \"Error: %S\".
+
If `debug-on-error' is non-nil, run BODY without catching its errors.
This is to be used around code which is not expected to signal an error
but which should be robust in the unexpected case that an error is signaled.
+
For backward compatibility, if FORMAT is not a constant string, it
is assumed to be part of BODY, in which case the message format
used is \"Error: %S\"."
,@body)
(with-current-buffer ,old-buffer
(set-case-table ,old-case-table))))))
+
+(defmacro with-file-modes (modes &rest body)
+ "Execute BODY with default file permissions temporarily set to MODES.
+MODES is as for `set-default-file-modes'."
+ (declare (indent 1) (debug t))
+ (let ((umask (make-symbol "umask")))
+ `(let ((,umask (default-file-modes)))
+ (unwind-protect
+ (progn
+ (set-default-file-modes ,modes)
+ ,@body)
+ (set-default-file-modes ,umask)))))
+
\f
;;; Matching and match data.
(setq matches (cons (substring string start l) matches)) ; leftover
(apply #'concat (nreverse matches)))))
\f
-(defun string-prefix-p (str1 str2 &optional ignore-case)
- "Return non-nil if STR1 is a prefix of STR2.
+(defun string-prefix-p (prefix string &optional ignore-case)
+ "Return non-nil if PREFIX is a prefix of STRING.
If IGNORE-CASE is non-nil, the comparison is done without paying attention
to case differences."
- (eq t (compare-strings str1 nil nil
- str2 0 (length str1) ignore-case)))
+ (let ((prefix-length (length prefix)))
+ (if (> prefix-length (length string)) nil
+ (eq t (compare-strings prefix 0 prefix-length string
+ 0 prefix-length ignore-case)))))
+
+(defun string-suffix-p (suffix string &optional ignore-case)
+ "Return non-nil if SUFFIX is a suffix of STRING.
+If IGNORE-CASE is non-nil, the comparison is done without paying
+attention to case differences."
+ (let ((start-pos (- (length string) (length suffix))))
+ (and (>= start-pos 0)
+ (eq t (compare-strings suffix nil nil
+ string start-pos nil ignore-case)))))
(defun bidi-string-mark-left-to-right (str)
"Return a string that can be safely inserted in left-to-right text.
(byte-compile-log-warning msg))
(run-with-timer 0 nil
(lambda (msg)
- (message "%s" msg)) msg))))
+ (message "%s" msg))
+ msg))))
;; Finally, run any other hook.
(run-hook-with-args 'after-load-functions abs-file))
if those frames don't seem special and otherwise, it should return
the number of frames to skip (minus 1).")
-(defconst internal--call-interactively (symbol-function 'call-interactively))
+(defconst internal--funcall-interactively
+ (symbol-function 'funcall-interactively))
(defun called-interactively-p (&optional kind)
"Return t if the containing function was called by `call-interactively'.
(pcase (cons frame nextframe)
;; No subr calls `interactive-p', so we can rule that out.
(`((,_ ,(pred (lambda (f) (subrp (indirect-function f)))) . ,_) . ,_) nil)
- ;; In case #<subr call-interactively> without going through the
- ;; `call-interactively' symbol (bug#3984).
- (`(,_ . (t ,(pred (eq internal--call-interactively)) . ,_)) t)
- (`(,_ . (t call-interactively . ,_)) t)))))
+ ;; In case #<subr funcall-interactively> without going through the
+ ;; `funcall-interactively' symbol (bug#3984).
+ (`(,_ . (t ,(pred (lambda (f)
+ (eq internal--funcall-interactively
+ (indirect-function f))))
+ . ,_))
+ t)))))
(defun interactive-p ()
"Return t if the containing function was run directly by user input.
(eq 'add-keymap-witness (nth 1 map))
(set symbol tail)))))
-(defun set-temporary-overlay-map (map &optional keep-pred on-exit)
- "Set MAP as a temporary keymap taking precedence over most other keymaps.
-Note that this does NOT take precedence over the \"overriding\" maps
-`overriding-terminal-local-map' and `overriding-local-map' (or the
-`keymap' text property). Unlike those maps, if no match for a key is
-found in MAP, the normal key lookup sequence then continues.
-
-Normally, MAP is used only once. If the optional argument
-KEEP-PRED is t, MAP stays active if a key from MAP is used.
-KEEP-PRED can also be a function of no arguments: if it returns
-non-nil then MAP stays active.
-
-Optional ON-EXIT argument is a function that is called after the
-deactivation of MAP."
- (let ((clearfun (make-symbol "clear-temporary-overlay-map")))
+(define-obsolete-function-alias
+ 'set-temporary-overlay-map 'set-transient-map "24.4")
+
+(defun set-transient-map (map &optional keep-pred on-exit)
+ "Set MAP as a temporary keymap taking precedence over other keymaps.
+Normally, MAP is used only once, to look up the very next key.
+However, if the optional argument KEEP-PRED is t, MAP stays
+active if a key from MAP is used. KEEP-PRED can also be a
+function of no arguments: if it returns non-nil, then MAP stays
+active.
+
+Optional arg ON-EXIT, if non-nil, specifies a function that is
+called, with no arguments, after MAP is deactivated.
+
+This uses `overriding-terminal-local-map' which takes precedence over all other
+keymaps. As usual, if no match for a key is found in MAP, the normal key
+lookup sequence then continues."
+ (let ((clearfun (make-symbol "clear-transient-map")))
;; Don't use letrec, because equal (in add/remove-hook) would get trapped
;; in a cycle.
(fset clearfun
(lambda ()
- ;; FIXME: Handle the case of multiple temporary-overlay-maps
- ;; E.g. if isearch and C-u both use temporary-overlay-maps, Then
- ;; the lifetime of the C-u should be nested within the isearch
- ;; overlay, so the pre-command-hook of isearch should be
- ;; suspended during the C-u one so we don't exit isearch just
- ;; because we hit 1 after C-u and that 1 exits isearch whereas it
- ;; doesn't exit C-u.
- (with-demoted-errors "set-temporary-overlay-map PCH: %S"
- (unless (cond ((null keep-pred) nil)
- ((eq t keep-pred)
- (eq this-command
- (lookup-key map (this-command-keys-vector))))
- (t (funcall keep-pred)))
+ (with-demoted-errors "set-transient-map PCH: %S"
+ (unless (cond
+ ((null keep-pred) nil)
+ ((not (eq map (cadr overriding-terminal-local-map)))
+ ;; There's presumably some other transient-map in
+ ;; effect. Wait for that one to terminate before we
+ ;; remove ourselves.
+ ;; For example, if isearch and C-u both use transient
+ ;; maps, then the lifetime of the C-u should be nested
+ ;; within isearch's, so the pre-command-hook of
+ ;; isearch should be suspended during the C-u one so
+ ;; we don't exit isearch just because we hit 1 after
+ ;; C-u and that 1 exits isearch whereas it doesn't
+ ;; exit C-u.
+ t)
+ ((eq t keep-pred)
+ (eq this-command
+ (lookup-key map (this-command-keys-vector))))
+ (t (funcall keep-pred)))
(internal-pop-keymap map 'overriding-terminal-local-map)
(remove-hook 'pre-command-hook clearfun)
- (when on-exit (funcall on-exit))))))
+ (when on-exit (funcall on-exit))
+ ;; Comment out the fset if you want to debug the GC bug.
+;;; (fset clearfun nil)
+;;; (set clearfun nil)
+ ))))
(add-hook 'pre-command-hook clearfun)
(internal-push-keymap map 'overriding-terminal-local-map)))
("^[-_+ ]?\\(cvs\\|git\\|bzr\\|svn\\|hg\\|darcs\\)$" . -4)
("^[-_+ ]?alpha$" . -3)
("^[-_+ ]?beta$" . -2)
- ("^[-_+ ]?\\(pre\\|rcc\\)$" . -1))
+ ("^[-_+ ]?\\(pre\\|rc\\)$" . -1))
"Specify association between non-numeric version and its priority.
This association is used to handle version string like \"1.0pre2\",
HCoop / bpt / emacs.git / blobdiff