;;; subr.el --- basic lisp subroutines for Emacs
-;; Copyright (C) 1985, 86, 92, 94, 95, 99, 2000, 2001, 2002, 2003
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1986, 1992, 1994, 1995, 1999, 2000, 2001, 2002, 2003,
+;; 2004, 2005 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
(setq custom-declare-variable-list
(cons arguments custom-declare-variable-list)))
-\f
-(defun macro-declaration-function (macro decl)
- "Process a declaration found in a macro definition.
-This is set as the value of the variable `macro-declaration-function'.
-MACRO is the name of the macro being defined.
-DECL is a list `(declare ...)' containing the declarations.
-The return value of this function is not used."
- ;; We can't use `dolist' or `cadr' yet for bootstrapping reasons.
- (let (d)
- ;; Ignore the first element of `decl' (it's always `declare').
- (while (setq decl (cdr decl))
- (setq d (car decl))
- (cond ((and (consp d) (eq (car d) 'indent))
- (put macro 'lisp-indent-function (car (cdr d))))
- ((and (consp d) (eq (car d) 'debug))
- (put macro 'edebug-form-spec (car (cdr d))))
- (t
- (message "Unknown declaration %s" d))))))
-
-(setq macro-declaration-function 'macro-declaration-function)
-
\f
;;;; Lisp language features.
(defalias 'not 'null)
+(defmacro noreturn (form)
+ "Evaluates FORM, with the expectation that the evaluation will signal an error
+instead of returning to its caller. If FORM does return, an error is
+signalled."
+ `(prog1 ,form
+ (error "Form marked with `noreturn' did return")))
+
+(defmacro 1value (form)
+ "Evaluates FORM, with the expectation that all the same value will be returned
+from all evaluations of FORM. This is the global do-nothing
+version of `1value'. There is also `testcover-1value' that
+complains if FORM ever does return differing values."
+ form)
+
(defmacro lambda (&rest cdr)
"Return a lambda expression.
A call of the form (lambda ARGS DOCSTRING INTERACTIVE BODY) is
But documentation strings are usually not useful in nameless functions.
INTERACTIVE should be a call to the function `interactive', which see.
It may also be omitted.
-BODY should be a list of Lisp expressions."
+BODY should be a list of Lisp expressions.
+
+\(fn ARGS [DOCSTRING] [INTERACTIVE] BODY)"
;; Note that this definition should not use backquotes; subr.el should not
;; depend on backquote.el.
(list 'function (cons 'lambda cdr)))
(setq ,(car spec) (1+ ,(car spec))))
,@(cdr (cdr spec)))))
+(defmacro declare (&rest specs)
+ "Do not evaluate any arguments and return nil.
+Treated as a declaration when used at the right place in a
+`defmacro' form. \(See Info anchor `(elisp)Definition of declare'.)"
+ nil)
+
(defsubst caar (x)
"Return the car of the car of X."
(car (car x)))
"Return the cdr of the cdr of X."
(cdr (cdr x)))
-(defun last (x &optional n)
- "Return the last link of the list X. Its car is the last element.
-If X is nil, return nil.
-If N is non-nil, return the Nth-to-last link of X.
-If N is bigger than the length of X, return X."
+(defun last (list &optional n)
+ "Return the last link of LIST. Its car is the last element.
+If LIST is nil, return nil.
+If N is non-nil, return the Nth-to-last link of LIST.
+If N is bigger than the length of LIST, return LIST."
(if n
- (let ((m 0) (p x))
+ (let ((m 0) (p list))
(while (consp p)
(setq m (1+ m) p (cdr p)))
(if (<= n 0) p
- (if (< n m) (nthcdr (- m n) x) x)))
- (while (consp (cdr x))
- (setq x (cdr x)))
- x))
+ (if (< n m) (nthcdr (- m n) list) list)))
+ (while (consp (cdr list))
+ (setq list (cdr list)))
+ list))
-(defun butlast (x &optional n)
- "Returns a copy of LIST with the last N elements removed."
- (if (and n (<= n 0)) x
- (nbutlast (copy-sequence x) n)))
+(defun butlast (list &optional n)
+ "Return a copy of LIST with the last N elements removed."
+ (if (and n (<= n 0)) list
+ (nbutlast (copy-sequence list) n)))
-(defun nbutlast (x &optional n)
+(defun nbutlast (list &optional n)
"Modifies LIST to remove the last N elements."
- (let ((m (length x)))
+ (let ((m (length list)))
(or n (setq n 1))
(and (< n m)
(progn
- (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
- x))))
+ (if (> n 0) (setcdr (nthcdr (- (1- m) n) list) nil))
+ list))))
+
+(defun delete-dups (list)
+ "Destructively remove `equal' duplicates from LIST.
+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))))
+ list)
(defun number-sequence (from &optional to inc)
"Return a sequence of numbers from FROM to TO (both inclusive) as a list.
-INC is the increment used between numbers in the sequence.
-So, the Nth element of the list is (+ FROM (* N INC)) where N counts from
-zero.
-If INC is nil, it defaults to 1 (one).
-If TO is nil, it defaults to FROM.
-If TO is less than FROM, the value is nil.
-Note that FROM, TO and INC can be integer or float."
- (if (not to)
+INC is the increment used between numbers in the sequence and defaults to 1.
+So, the Nth element of the list is \(+ FROM \(* N INC)) where N counts from
+zero. TO is only included if there is an N for which TO = FROM + N * INC.
+If TO is nil or numerically equal to FROM, return \(FROM).
+If INC is positive and TO is less than FROM, or INC is negative
+and TO is larger than FROM, return nil.
+If INC is zero and TO is neither nil nor numerically equal to
+FROM, signal an error.
+
+This function is primarily designed for integer arguments.
+Nevertheless, FROM, TO and INC can be integer or float. However,
+floating point arithmetic is inexact. For instance, depending on
+the machine, it may quite well happen that
+\(number-sequence 0.4 0.6 0.2) returns the one element list \(0.4),
+whereas \(number-sequence 0.4 0.8 0.2) returns a list with three
+elements. Thus, if some of the arguments are floats and one wants
+to make sure that TO is included, one may have to explicitly write
+TO as \(+ FROM \(* N INC)) or use a variable whose value was
+computed with this exact expression. Alternatively, you can,
+of course, also replace TO with a slightly larger value
+\(or a slightly more negative value if INC is negative)."
+ (if (or (not to) (= from to))
(list from)
(or inc (setq inc 1))
- (let (seq)
- (while (<= from to)
- (setq seq (cons from seq)
- from (+ from inc)))
+ (when (zerop inc) (error "The increment can not be zero"))
+ (let (seq (n 0) (next from))
+ (if (> inc 0)
+ (while (<= next to)
+ (setq seq (cons next seq)
+ n (1+ n)
+ next (+ from (* n inc))))
+ (while (>= next to)
+ (setq seq (cons next seq)
+ n (1+ n)
+ next (+ from (* n inc)))))
(nreverse seq))))
(defun remove (elt seq)
(setq tail (cdr tail)))
value))
+(make-obsolete 'assoc-ignore-case 'assoc-string)
(defun assoc-ignore-case (key alist)
"Like `assoc', but ignores differences in case and text representation.
KEY must be a string. Upper-case and lower-case letters are treated as equal.
Unibyte strings are converted to multibyte for comparison."
- (let (element)
- (while (and alist (not element))
- (if (eq t (compare-strings key 0 nil (car (car alist)) 0 nil t))
- (setq element (car alist)))
- (setq alist (cdr alist)))
- element))
+ (assoc-string key alist t))
+(make-obsolete 'assoc-ignore-representation 'assoc-string)
(defun assoc-ignore-representation (key alist)
"Like `assoc', but ignores differences in text representation.
KEY must be a string.
Unibyte strings are converted to multibyte for comparison."
- (let (element)
- (while (and alist (not element))
- (if (eq t (compare-strings key 0 nil (car (car alist)) 0 nil))
- (setq element (car alist)))
- (setq alist (cdr alist)))
- element))
+ (assoc-string key alist nil))
(defun member-ignore-case (elt list)
"Like `member', but ignores differences in case and text representation.
(define-key map (char-to-string loop) 'digit-argument)
(setq loop (1+ loop))))))
-;Moved to keymap.c
-;(defun copy-keymap (keymap)
-; "Return a copy of KEYMAP"
-; (while (not (keymapp keymap))
-; (setq keymap (signal 'wrong-type-argument (list 'keymapp keymap))))
-; (if (vectorp keymap)
-; (copy-sequence keymap)
-; (copy-alist keymap)))
-
(defvar key-substitution-in-progress nil
"Used internally by substitute-key-definition.")
"Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
In other words, OLDDEF is replaced with NEWDEF where ever it appears.
Alternatively, if optional fourth argument OLDMAP is specified, we redefine
-in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP."
+in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP.
+
+For most uses, it is simpler and safer to use command remappping like this:
+ \(define-key KEYMAP [remap OLDDEF] NEWDEF)"
;; Don't document PREFIX in the doc string because we don't want to
;; advertise it. It's meant for recursive calls only. Here's its
;; meaning
;; original key, with PREFIX added at the front.
(or prefix (setq prefix ""))
(let* ((scan (or oldmap keymap))
- (vec1 (vector nil))
- (prefix1 (vconcat prefix vec1))
+ (prefix1 (vconcat prefix [nil]))
(key-substitution-in-progress
(cons scan key-substitution-in-progress)))
;; Scan OLDMAP, finding each char or event-symbol that
;; has any definition, and act on it with hack-key.
- (while (consp scan)
- (if (consp (car scan))
- (let ((char (car (car scan)))
- (defn (cdr (car scan))))
- ;; The inside of this let duplicates exactly
- ;; the inside of the following let that handles array elements.
- (aset vec1 0 char)
- (aset prefix1 (length prefix) char)
- (let (inner-def skipped)
- ;; Skip past menu-prompt.
- (while (stringp (car-safe defn))
- (setq skipped (cons (car defn) skipped))
- (setq defn (cdr defn)))
- ;; Skip past cached key-equivalence data for menu items.
- (and (consp defn) (consp (car defn))
- (setq defn (cdr defn)))
- (setq inner-def defn)
- ;; Look past a symbol that names a keymap.
- (while (and (symbolp inner-def)
- (fboundp inner-def))
- (setq inner-def (symbol-function inner-def)))
- (if (or (eq defn olddef)
- ;; Compare with equal if definition is a key sequence.
- ;; That is useful for operating on function-key-map.
- (and (or (stringp defn) (vectorp defn))
- (equal defn olddef)))
- (define-key keymap prefix1 (nconc (nreverse skipped) newdef))
- (if (and (keymapp defn)
- ;; Avoid recursively scanning
- ;; where KEYMAP does not have a submap.
- (let ((elt (lookup-key keymap prefix1)))
- (or (null elt)
- (keymapp elt)))
- ;; Avoid recursively rescanning keymap being scanned.
- (not (memq inner-def
- key-substitution-in-progress)))
- ;; If this one isn't being scanned already,
- ;; scan it now.
- (substitute-key-definition olddef newdef keymap
- inner-def
- prefix1)))))
- (if (vectorp (car scan))
- (let* ((array (car scan))
- (len (length array))
- (i 0))
- (while (< i len)
- (let ((char i) (defn (aref array i)))
- ;; The inside of this let duplicates exactly
- ;; the inside of the previous let.
- (aset vec1 0 char)
- (aset prefix1 (length prefix) char)
- (let (inner-def skipped)
- ;; Skip past menu-prompt.
- (while (stringp (car-safe defn))
- (setq skipped (cons (car defn) skipped))
- (setq defn (cdr defn)))
- (and (consp defn) (consp (car defn))
- (setq defn (cdr defn)))
- (setq inner-def defn)
- (while (and (symbolp inner-def)
- (fboundp inner-def))
- (setq inner-def (symbol-function inner-def)))
- (if (or (eq defn olddef)
- (and (or (stringp defn) (vectorp defn))
- (equal defn olddef)))
- (define-key keymap prefix1
- (nconc (nreverse skipped) newdef))
- (if (and (keymapp defn)
- (let ((elt (lookup-key keymap prefix1)))
- (or (null elt)
- (keymapp elt)))
- (not (memq inner-def
- key-substitution-in-progress)))
- (substitute-key-definition olddef newdef keymap
- inner-def
- prefix1)))))
- (setq i (1+ i))))
- (if (char-table-p (car scan))
- (map-char-table
- (function (lambda (char defn)
- (let ()
- ;; The inside of this let duplicates exactly
- ;; the inside of the previous let,
- ;; except that it uses set-char-table-range
- ;; instead of define-key.
- (aset vec1 0 char)
- (aset prefix1 (length prefix) char)
- (let (inner-def skipped)
- ;; Skip past menu-prompt.
- (while (stringp (car-safe defn))
- (setq skipped (cons (car defn) skipped))
- (setq defn (cdr defn)))
- (and (consp defn) (consp (car defn))
- (setq defn (cdr defn)))
- (setq inner-def defn)
- (while (and (symbolp inner-def)
- (fboundp inner-def))
- (setq inner-def (symbol-function inner-def)))
- (if (or (eq defn olddef)
- (and (or (stringp defn) (vectorp defn))
- (equal defn olddef)))
- (define-key keymap prefix1
- (nconc (nreverse skipped) newdef))
- (if (and (keymapp defn)
- (let ((elt (lookup-key keymap prefix1)))
- (or (null elt)
- (keymapp elt)))
- (not (memq inner-def
- key-substitution-in-progress)))
- (substitute-key-definition olddef newdef keymap
- inner-def
- prefix1)))))))
- (car scan)))))
- (setq scan (cdr scan)))))
+ (map-keymap
+ (lambda (char defn)
+ (aset prefix1 (length prefix) char)
+ (substitute-key-definition-key defn olddef newdef prefix1 keymap))
+ scan)))
+
+(defun substitute-key-definition-key (defn olddef newdef prefix keymap)
+ (let (inner-def skipped menu-item)
+ ;; Find the actual command name within the binding.
+ (if (eq (car-safe defn) 'menu-item)
+ (setq menu-item defn defn (nth 2 defn))
+ ;; Skip past menu-prompt.
+ (while (stringp (car-safe defn))
+ (push (pop defn) skipped))
+ ;; Skip past cached key-equivalence data for menu items.
+ (if (consp (car-safe defn))
+ (setq defn (cdr defn))))
+ (if (or (eq defn olddef)
+ ;; Compare with equal if definition is a key sequence.
+ ;; That is useful for operating on function-key-map.
+ (and (or (stringp defn) (vectorp defn))
+ (equal defn olddef)))
+ (define-key keymap prefix
+ (if menu-item
+ (let ((copy (copy-sequence menu-item)))
+ (setcar (nthcdr 2 copy) newdef)
+ copy)
+ (nconc (nreverse skipped) newdef)))
+ ;; Look past a symbol that names a keymap.
+ (setq inner-def
+ (and defn
+ (condition-case nil (indirect-function defn) (error 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.
+ (if (and (keymapp inner-def)
+ ;; Avoid recursively scanning
+ ;; where KEYMAP does not have a submap.
+ (let ((elt (lookup-key keymap prefix)))
+ (or (null elt) (natnump elt) (keymapp elt)))
+ ;; Avoid recursively rescanning keymap being scanned.
+ (not (memq inner-def key-substitution-in-progress)))
+ ;; If this one isn't being scanned already, scan it now.
+ (substitute-key-definition olddef newdef keymap inner-def prefix)))))
(defun define-key-after (keymap key definition &optional after)
"Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding.
(setq inserted t)))
(setq tail (cdr tail)))))
+(defun map-keymap-internal (function keymap &optional sort-first)
+ "Implement `map-keymap' with sorting.
+Don't call this function; it is for internal use only."
+ (if sort-first
+ (let (list)
+ (map-keymap (lambda (a b) (push (cons a b) list))
+ keymap)
+ (setq list (sort list
+ (lambda (a b)
+ (setq a (car a) b (car b))
+ (if (integerp a)
+ (if (integerp b) (< a b)
+ t)
+ (if (integerp b) t
+ (string< a b))))))
+ (dolist (p list)
+ (funcall function (car p) (cdr p))))
+ (map-keymap function keymap)))
(defmacro kbd (keys)
"Convert KEYS to the internal Emacs key representation.
KEYS should be a string constant in the format used for
-saving keyboard macros (see `insert-kbd-macro')."
+saving keyboard macros (see `edmacro-mode')."
(read-kbd-macro keys))
(put 'keyboard-translate-table 'char-table-extra-slots 0)
(defsubst eventp (obj)
"True if the argument is an event object."
- (or (integerp obj)
+ (or (and (integerp obj)
+ ;; Filter out integers too large to be events.
+ ;; M is the biggest modifier.
+ (zerop (logand obj (lognot (1- (lsh ?\M-\^@ 1)))))
+ (char-valid-p (event-basic-type obj)))
(and (symbolp obj)
(get obj 'event-symbol-elements))
(and (consp obj)
(get (car obj) 'event-symbol-elements))))
(defun event-modifiers (event)
- "Returns a list of symbols representing the modifier keys in event EVENT.
+ "Return a list of symbols representing the modifier keys in event EVENT.
The elements of the list may include `meta', `control',
`shift', `hyper', `super', `alt', `click', `double', `triple', `drag',
-and `down'."
+and `down'.
+EVENT may be an event or an event type. If EVENT is a symbol
+that has never been used in an event that has been read as input
+in the current Emacs session, then this function can return nil,
+even when EVENT actually has modifiers."
(let ((type event))
(if (listp type)
(setq type (car type)))
(if (symbolp type)
(cdr (get type 'event-symbol-elements))
- (let ((list nil))
- (or (zerop (logand type ?\M-\^@))
- (setq list (cons 'meta list)))
- (or (and (zerop (logand type ?\C-\^@))
- (>= (logand type 127) 32))
- (setq list (cons 'control list)))
- (or (and (zerop (logand type ?\S-\^@))
- (= (logand type 255) (downcase (logand type 255))))
- (setq list (cons 'shift list)))
+ (let ((list nil)
+ (char (logand type (lognot (logior ?\M-\^@ ?\C-\^@ ?\S-\^@
+ ?\H-\^@ ?\s-\^@ ?\A-\^@)))))
+ (if (not (zerop (logand type ?\M-\^@)))
+ (push 'meta list))
+ (if (or (not (zerop (logand type ?\C-\^@)))
+ (< char 32))
+ (push 'control list))
+ (if (or (not (zerop (logand type ?\S-\^@)))
+ (/= char (downcase char)))
+ (push 'shift list))
(or (zerop (logand type ?\H-\^@))
- (setq list (cons 'hyper list)))
+ (push 'hyper list))
(or (zerop (logand type ?\s-\^@))
- (setq list (cons 'super list)))
+ (push 'super list))
(or (zerop (logand type ?\A-\^@))
- (setq list (cons 'alt list)))
+ (push 'alt list))
list))))
(defun event-basic-type (event)
- "Returns the basic type of the given event (all modifiers removed).
-The value is a printing character (not upper case) or a symbol."
+ "Return the basic type of the given event (all modifiers removed).
+The value is a printing character (not upper case) or a symbol.
+EVENT may be an event or an event type. If EVENT is a symbol
+that has never been used in an event that has been read as input
+in the current Emacs session, then this function may return nil."
(if (consp event)
(setq event (car event)))
(if (symbolp event)
(car (get event 'event-symbol-elements))
- (let ((base (logand event (1- (lsh 1 18)))))
+ (let ((base (logand event (1- ?\A-\^@))))
(downcase (if (< base 32) (logior base 64) base)))))
(defsubst mouse-movement-p (object)
"Return non-nil if OBJECT is a mouse movement event."
- (and (consp object)
- (eq (car object) 'mouse-movement)))
+ (eq (car-safe object) 'mouse-movement))
(defsubst event-start (event)
"Return the starting position of EVENT.
-If EVENT is a mouse press or a mouse click, this returns the location
+If EVENT is a mouse or key press or a mouse click, this returns the location
of the event.
If EVENT is a drag, this returns the drag's starting position.
The return value is of the form
- (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
+ (WINDOW AREA-OR-POS (X . Y) TIMESTAMP OBJECT POS (COL . ROW)
+ IMAGE (DX . DY) (WIDTH . HEIGHT))
The `posn-' functions access elements of such lists."
(if (consp event) (nth 1 event)
(list (selected-window) (point) '(0 . 0) 0)))
(defsubst event-end (event)
- "Return the ending location of EVENT. EVENT should be a click or drag event.
+ "Return the ending location of EVENT.
+EVENT should be a click, drag, or key press event.
If EVENT is a click event, this function is the same as `event-start'.
The return value is of the form
- (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
+ (WINDOW AREA-OR-POS (X . Y) TIMESTAMP OBJECT POS (COL . ROW)
+ IMAGE (DX . DY) (WIDTH . HEIGHT))
The `posn-' functions access elements of such lists."
(if (consp event) (nth (if (consp (nth 2 event)) 2 1) event)
(list (selected-window) (point) '(0 . 0) 0)))
(defsubst posn-window (position)
"Return the window in POSITION.
-POSITION should be a list of the form
- (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
-as returned by the `event-start' and `event-end' functions."
+POSITION should be a list of the form returned by the `event-start'
+and `event-end' functions."
(nth 0 position))
+(defsubst posn-area (position)
+ "Return the window area recorded in POSITION, or nil for the text area.
+POSITION should be a list of the form returned by the `event-start'
+and `event-end' functions."
+ (let ((area (if (consp (nth 1 position))
+ (car (nth 1 position))
+ (nth 1 position))))
+ (and (symbolp area) area)))
+
(defsubst posn-point (position)
"Return the buffer location in POSITION.
-POSITION should be a list of the form
- (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
-as returned by the `event-start' and `event-end' functions."
- (if (consp (nth 1 position))
- (car (nth 1 position))
- (nth 1 position)))
+POSITION should be a list of the form returned by the `event-start'
+and `event-end' functions."
+ (or (nth 5 position)
+ (if (consp (nth 1 position))
+ (car (nth 1 position))
+ (nth 1 position))))
+
+(defun posn-set-point (position)
+ "Move point to POSITION.
+Select the corresponding window as well."
+ (if (not (windowp (posn-window position)))
+ (error "Position not in text area of window"))
+ (select-window (posn-window position))
+ (if (numberp (posn-point position))
+ (goto-char (posn-point position))))
(defsubst posn-x-y (position)
"Return the x and y coordinates in POSITION.
-POSITION should be a list of the form
- (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
-as returned by the `event-start' and `event-end' functions."
+POSITION should be a list of the form returned by the `event-start'
+and `event-end' functions."
(nth 2 position))
(defun posn-col-row (position)
- "Return the column and row in POSITION, measured in characters.
-POSITION should be a list of the form
- (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
-as returned by the `event-start' and `event-end' functions.
+ "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.
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."
- (let* ((pair (nth 2 position))
- (window (posn-window position)))
- (if (eq (if (consp (nth 1 position))
- (car (nth 1 position))
- (nth 1 position))
- 'vertical-scroll-bar)
- (cons 0 (scroll-bar-scale pair (1- (window-height window))))
- (if (eq (if (consp (nth 1 position))
- (car (nth 1 position))
- (nth 1 position))
- 'horizontal-scroll-bar)
- (cons (scroll-bar-scale pair (window-width window)) 0)
- (let* ((frame (if (framep window) window (window-frame window)))
- (x (/ (car pair) (frame-char-width frame)))
- (y (/ (cdr pair) (+ (frame-char-height frame)
- (or (frame-parameter frame 'line-spacing)
- default-line-spacing
- 0)))))
- (cons x y))))))
+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'
+and `event-end' functions."
+ (let* ((pair (posn-x-y position))
+ (window (posn-window position))
+ (area (posn-area position)))
+ (cond
+ ((null window)
+ '(0 . 0))
+ ((eq area 'vertical-scroll-bar)
+ (cons 0 (scroll-bar-scale pair (1- (window-height window)))))
+ ((eq area 'horizontal-scroll-bar)
+ (cons (scroll-bar-scale pair (window-width window)) 0))
+ (t
+ (let* ((frame (if (framep window) window (window-frame window)))
+ (x (/ (car pair) (frame-char-width frame)))
+ (y (/ (cdr pair) (+ (frame-char-height frame)
+ (or (frame-parameter frame 'line-spacing)
+ default-line-spacing
+ 0)))))
+ (cons x y))))))
+
+(defun posn-actual-col-row (position)
+ "Return the actual column and row in POSITION, measured in characters.
+These are the actual row number in the window 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.
+POSITION should be a list of the form returned by the `event-start'
+and `event-end' functions."
+ (nth 6 position))
(defsubst posn-timestamp (position)
"Return the timestamp of POSITION.
-POSITION should be a list of the form
- (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
-as returned by the `event-start' and `event-end' functions."
+POSITION should be a list of the form returned by the `event-start'
+and `event-end' functions."
(nth 3 position))
+(defsubst posn-string (position)
+ "Return the string object of POSITION, or nil if a buffer position.
+POSITION should be a list of the form returned by the `event-start'
+and `event-end' functions."
+ (nth 4 position))
+
+(defsubst posn-image (position)
+ "Return the image object of POSITION, or nil if a not an image.
+POSITION should be a list of the form returned by the `event-start'
+and `event-end' functions."
+ (nth 7 position))
+
+(defsubst posn-object (position)
+ "Return the object (image or string) of POSITION.
+POSITION should be a list of the form returned by the `event-start'
+and `event-end' functions."
+ (or (posn-image position) (posn-string position)))
+
+(defsubst posn-object-x-y (position)
+ "Return the x and y coordinates relative to the object of POSITION.
+POSITION should be a list of the form returned by the `event-start'
+and `event-end' functions."
+ (nth 8 position))
+
+(defsubst posn-object-width-height (position)
+ "Return the pixel width and height of the object of POSITION.
+POSITION should be a list of the form returned by the `event-start'
+and `event-end' functions."
+ (nth 9 position))
+
\f
;;;; Obsolescent names for functions.
-(defalias 'dot 'point)
-(defalias 'dot-marker 'point-marker)
-(defalias 'dot-min 'point-min)
-(defalias 'dot-max 'point-max)
(defalias 'window-dot 'window-point)
(defalias 'set-window-dot 'set-window-point)
(defalias 'read-input 'read-string)
(defalias 'send-string 'process-send-string)
(defalias 'send-region 'process-send-region)
(defalias 'show-buffer 'set-window-buffer)
-(defalias 'buffer-flush-undo 'buffer-disable-undo)
(defalias 'eval-current-buffer 'eval-buffer)
-(defalias 'compiled-function-p 'byte-code-function-p)
(defalias 'define-function 'defalias)
(defalias 'sref 'aref)
(make-obsolete 'sref 'aref "20.4")
(make-obsolete 'char-bytes "now always returns 1." "20.4")
(make-obsolete 'chars-in-region "use (abs (- BEG END))." "20.3")
-(make-obsolete 'dot 'point "before 19.15")
-(make-obsolete 'dot-max 'point-max "before 19.15")
-(make-obsolete 'dot-min 'point-min "before 19.15")
-(make-obsolete 'dot-marker 'point-marker "before 19.15")
-(make-obsolete 'buffer-flush-undo 'buffer-disable-undo "before 19.15")
-(make-obsolete 'baud-rate "use the baud-rate variable instead." "before 19.15")
-(make-obsolete 'compiled-function-p 'byte-code-function-p "before 19.15")
+(make-obsolete 'baud-rate "use the `baud-rate' variable instead." "before 19.15")
(make-obsolete 'define-function 'defalias "20.1")
(defun insert-string (&rest args)
is converted into a string by expressing it in decimal."
(dolist (el args)
(insert (if (integerp el) (number-to-string el) el))))
-(make-obsolete 'insert-string 'insert "21.4")
+(make-obsolete 'insert-string 'insert "22.1")
(defun makehash (&optional test) (make-hash-table :test (or test 'eql)))
-(make-obsolete 'makehash 'make-hash-table "21.4")
+(make-obsolete 'makehash 'make-hash-table "22.1")
;; Some programs still use this as a function.
(defun baud-rate ()
"Return the value of the `baud-rate' variable."
baud-rate)
-(defalias 'focus-frame 'ignore)
-(defalias 'unfocus-frame 'ignore)
-
\f
-;;;; Obsolescence declarations for variables.
+;;;; Obsolescence declarations for variables, and aliases.
(make-obsolete-variable 'directory-sep-char "do not use it." "21.1")
(make-obsolete-variable 'mode-line-inverse-video "use the appropriate faces instead." "21.1")
(make-obsolete-variable 'post-command-idle-delay
"use timers instead, with `run-with-idle-timer'." "before 19.34")
+(defvaralias 'x-lost-selection-hooks 'x-lost-selection-functions)
+(make-obsolete-variable 'x-lost-selection-hooks 'x-lost-selection-functions "22.1")
+(defvaralias 'x-sent-selection-hooks 'x-sent-selection-functions)
+(make-obsolete-variable 'x-sent-selection-hooks 'x-sent-selection-functions "22.1")
+
+(defvaralias 'messages-buffer-max-lines 'message-log-max)
\f
;;;; Alternate names for functions - these are not being phased out.
;;; Should this be an obsolete name? If you decide it should, you get
;;; to go through all the sources and change them.
-(defalias 'string-to-int 'string-to-number)
+(define-obsolete-function-alias 'string-to-int 'string-to-number)
\f
;;;; Hook manipulation functions.
list of hooks to run in HOOK, then nothing is done. See `add-hook'.
The optional third argument, LOCAL, if non-nil, says to modify
-the hook's buffer-local value rather than its default value.
-This makes the hook buffer-local if needed."
+the hook's buffer-local value rather than its default value."
(or (boundp hook) (set hook nil))
(or (default-boundp hook) (set-default hook nil))
- (if local (unless (local-variable-if-set-p hook)
- (set (make-local-variable hook) (list t)))
+ ;; Do nothing if LOCAL is t but this hook has no local binding.
+ (unless (and local (not (local-variable-p hook)))
;; Detect the case where make-local-variable was used on a hook
;; and do what we used to do.
- (unless (and (consp (symbol-value hook)) (memq t (symbol-value hook)))
- (setq local t)))
- (let ((hook-value (if local (symbol-value hook) (default-value hook))))
- ;; Remove the function, for both the list and the non-list cases.
- (if (or (not (listp hook-value)) (eq (car hook-value) 'lambda))
- (if (equal hook-value function) (setq hook-value nil))
- (setq hook-value (delete function (copy-sequence hook-value))))
- ;; If the function is on the global hook, we need to shadow it locally
- ;;(when (and local (member function (default-value hook))
- ;; (not (member (cons 'not function) hook-value)))
- ;; (push (cons 'not function) hook-value))
- ;; Set the actual variable
- (if (not local)
- (set-default hook hook-value)
- (if (equal hook-value '(t))
- (kill-local-variable hook)
- (set hook hook-value)))))
+ (when (and (local-variable-p hook)
+ (not (and (consp (symbol-value hook))
+ (memq t (symbol-value hook)))))
+ (setq local t))
+ (let ((hook-value (if local (symbol-value hook) (default-value hook))))
+ ;; Remove the function, for both the list and the non-list cases.
+ (if (or (not (listp hook-value)) (eq (car hook-value) 'lambda))
+ (if (equal hook-value function) (setq hook-value nil))
+ (setq hook-value (delete function (copy-sequence hook-value))))
+ ;; If the function is on the global hook, we need to shadow it locally
+ ;;(when (and local (member function (default-value hook))
+ ;; (not (member (cons 'not function) hook-value)))
+ ;; (push (cons 'not function) hook-value))
+ ;; Set the actual variable
+ (if (not local)
+ (set-default hook hook-value)
+ (if (equal hook-value '(t))
+ (kill-local-variable hook)
+ (set hook hook-value))))))
(defun add-to-list (list-var element &optional append)
"Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.
;;; nil nil t)
;;; (setq symbol-file-load-history-loaded t)))
-(defun symbol-file (function)
- "Return the input source from which FUNCTION was loaded.
+(defun symbol-file (symbol &optional type)
+ "Return the input source in which SYMBOL was defined.
The value is normally a string that was passed to `load':
either an absolute file name, or a library name
\(with no directory name and no `.el' or `.elc' at the end).
-It can also be nil, if the definition is not associated with any file."
- (if (and (symbolp function) (fboundp function)
- (eq 'autoload (car-safe (symbol-function function))))
- (nth 1 (symbol-function function))
+It can also be nil, if the definition is not associated with any file.
+
+If TYPE is nil, then any kind of definition is acceptable.
+If TYPE is `defun' or `defvar', that specifies function
+definition only or variable definition only."
+ (if (and (or (null type) (eq type 'defun))
+ (symbolp symbol) (fboundp symbol)
+ (eq 'autoload (car-safe (symbol-function symbol))))
+ (nth 1 (symbol-function symbol))
(let ((files load-history)
file)
(while files
- (if (member function (cdr (car files)))
+ (if (if type
+ (if (eq type 'defvar)
+ ;; Variables are present just as their names.
+ (member symbol (cdr (car files)))
+ ;; Other types are represented as (TYPE . NAME).
+ (member (cons type symbol) (cdr (car files))))
+ ;; We accept all types, so look for variable def
+ ;; and then for any other kind.
+ (or (member symbol (cdr (car files)))
+ (rassq symbol (cdr (car files)))))
(setq file (car (car files)) files nil))
(setq files (cdr files)))
file)))
"Open a TCP connection for a service to a host.
Returns a subprocess-object to represent the connection.
Input and output work as for subprocesses; `delete-process' closes it.
+
Args are NAME BUFFER HOST SERVICE.
NAME is name for process. It is modified if necessary to make it unique.
-BUFFER is the buffer (or buffer-name) to associate with the process.
+BUFFER is the buffer (or buffer name) to associate with the process.
Process output goes at end of that buffer, unless you specify
an output stream or filter function to handle the output.
BUFFER may be also nil, meaning that this process is not associated
- with any buffer
-Third arg is name of the host to connect to, or its IP address.
-Fourth arg SERVICE is name of the service desired, or an integer
-specifying a port number to connect to."
+ with any buffer.
+HOST is name of the host to connect to, or its IP address.
+SERVICE is name of the service desired, or an integer specifying
+ a port number to connect to."
(make-network-process :name name :buffer buffer
:host host :service service))
It returns nil if non-blocking connects are not supported; otherwise,
it returns a subprocess-object to represent the connection.
-This function is similar to `open-network-stream', except that this
-function returns before the connection is established. When the
-connection is completed, the sentinel function will be called with
-second arg matching `open' (if successful) or `failed' (on error).
+This function is similar to `open-network-stream', except that it
+returns before the connection is established. When the connection
+is completed, the sentinel function will be called with second arg
+matching `open' (if successful) or `failed' (on error).
Args are NAME BUFFER HOST SERVICE SENTINEL FILTER.
NAME, BUFFER, HOST, and SERVICE are as for `open-network-stream'.
-Optional args, SENTINEL and FILTER specifies the sentinel and filter
+Optional args SENTINEL and FILTER specify the sentinel and filter
functions to be used for this network stream."
(if (featurep 'make-network-process '(:nowait t))
(make-network-process :name name :buffer buffer :nowait t
Args are NAME BUFFER SERVICE SENTINEL FILTER.
NAME is name for the server process. Client processes are named by
-appending the ip-address and port number of the client to NAME.
-BUFFER is the buffer (or buffer-name) to associate with the server
-process. Client processes will not get a buffer if a process filter
-is specified or BUFFER is nil; otherwise, a new buffer is created for
-the client process. The name is similar to the process name.
+ appending the ip-address and port number of the client to NAME.
+BUFFER is the buffer (or buffer name) to associate with the server
+ process. Client processes will not get a buffer if a process filter
+ is specified or BUFFER is nil; otherwise, a new buffer is created for
+ the client process. The name is similar to the process name.
Third arg SERVICE is name of the service desired, or an integer
-specifying a port number to connect to. It may also be t to selected
-an unused port number for the server.
-Optional args, SENTINEL and FILTER specifies the sentinel and filter
-functions to be used for the client processes; the server process
-does not use these function."
+ specifying a port number to connect to. It may also be t to select
+ an unused port number for the server.
+Optional args SENTINEL and FILTER specify the sentinel and filter
+ functions to be used for the client processes; the server process
+ does not use these function."
(if (featurep 'make-network-process '(:server t))
(make-network-process :name name :buffer buffer
:service service :server t :noquery t
;; 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.
-New code should not use this function; use `process-query-on-exit-flag'
-or `set-process-query-on-exit-flag' instead."
+Value is t if a query was formerly required."
(let ((old (process-query-on-exit-flag process)))
(set-process-query-on-exit-flag process nil)
old))
code))
(defun read-passwd (prompt &optional confirm default)
- "Read a password, prompting with PROMPT. Echo `.' for each character typed.
-End with RET, LFD, or ESC. DEL or C-h rubs out. C-u kills line.
-Optional argument CONFIRM, if non-nil, then read it twice to make sure.
-Optional DEFAULT is a default password to use instead of empty input."
- (if confirm
- (let (success)
- (while (not success)
- (let ((first (read-passwd prompt nil default))
- (second (read-passwd "Confirm password: " nil default)))
- (if (equal first second)
- (progn
- (and (arrayp second) (fillarray second ?\0))
- (setq success first))
- (and (arrayp first) (fillarray first ?\0))
- (and (arrayp second) (fillarray second ?\0))
- (message "Password not repeated accurately; please start over")
- (sit-for 1))))
- success)
- (let ((pass nil)
- (c 0)
- (echo-keystrokes 0)
- (cursor-in-echo-area t))
- (while (progn (message "%s%s"
- prompt
- (make-string (length pass) ?.))
- (setq c (read-char-exclusive nil t))
- (and (/= c ?\r) (/= c ?\n) (/= c ?\e)))
- (clear-this-command-keys)
- (if (= c ?\C-u)
- (progn
- (and (arrayp pass) (fillarray pass ?\0))
- (setq pass ""))
- (if (and (/= c ?\b) (/= c ?\177))
- (let* ((new-char (char-to-string c))
- (new-pass (concat pass new-char)))
- (and (arrayp pass) (fillarray pass ?\0))
- (fillarray new-char ?\0)
- (setq c ?\0)
- (setq pass new-pass))
- (if (> (length pass) 0)
- (let ((new-pass (substring pass 0 -1)))
- (and (arrayp pass) (fillarray pass ?\0))
- (setq pass new-pass))))))
- (message nil)
- (or pass default ""))))
+ "Read a password, prompting with PROMPT, and return it.
+If optional CONFIRM is non-nil, read the password twice to make sure.
+Optional DEFAULT is a default password to use instead of empty input.
+
+This function echoes `.' for each character that the user types.
+The user ends with RET, LFD, or ESC. DEL or C-h rubs out. C-u kills line.
+C-g quits; if `inhibit-quit' was non-nil around this function,
+then it returns nil if the user types C-g.
+
+Once the caller uses the password, it can erase the password
+by doing (clear-string STRING)."
+ (with-local-quit
+ (if confirm
+ (let (success)
+ (while (not success)
+ (let ((first (read-passwd prompt nil default))
+ (second (read-passwd "Confirm password: " nil default)))
+ (if (equal first second)
+ (progn
+ (and (arrayp second) (clear-string second))
+ (setq success first))
+ (and (arrayp first) (clear-string first))
+ (and (arrayp second) (clear-string second))
+ (message "Password not repeated accurately; please start over")
+ (sit-for 1))))
+ success)
+ (let ((pass nil)
+ (c 0)
+ (echo-keystrokes 0)
+ (cursor-in-echo-area t))
+ (while (progn (message "%s%s"
+ prompt
+ (make-string (length pass) ?.))
+ (setq c (read-char-exclusive nil t))
+ (and (/= c ?\r) (/= c ?\n) (/= c ?\e)))
+ (clear-this-command-keys)
+ (if (= c ?\C-u)
+ (progn
+ (and (arrayp pass) (clear-string pass))
+ (setq pass ""))
+ (if (and (/= c ?\b) (/= c ?\177))
+ (let* ((new-char (char-to-string c))
+ (new-pass (concat pass new-char)))
+ (and (arrayp pass) (clear-string pass))
+ (clear-string new-char)
+ (setq c ?\0)
+ (setq pass new-pass))
+ (if (> (length pass) 0)
+ (let ((new-pass (substring pass 0 -1)))
+ (and (arrayp pass) (clear-string pass))
+ (setq pass new-pass))))))
+ (message nil)
+ (or pass default "")))))
+
+;; This should be used by `call-interactively' for `n' specs.
+(defun read-number (prompt &optional default)
+ (let ((n nil))
+ (when default
+ (setq prompt
+ (if (string-match "\\(\\):[ \t]*\\'" prompt)
+ (replace-match (format " (default %s)" default) t t prompt 1)
+ (replace-regexp-in-string "[ \t]*\\'"
+ (format " (default %s) " default)
+ prompt t t))))
+ (while
+ (progn
+ (let ((str (read-from-minibuffer prompt nil nil nil nil
+ (and default
+ (number-to-string default)))))
+ (setq n (cond
+ ((zerop (length str)) default)
+ ((stringp str) (read str)))))
+ (unless (numberp n)
+ (message "Please enter a number.")
+ (sit-for 1)
+ t)))
+ n))
\f
;;; Atomic change groups.
(defalias 'redraw-modeline 'force-mode-line-update)
(defun force-mode-line-update (&optional all)
- "Force the mode line of the current buffer to be redisplayed.
-With optional non-nil ALL, force redisplay of all mode lines."
+ "Force redisplay of the current buffer's mode line and header line.
+With optional non-nil ALL, force redisplay of all mode lines and
+header lines. This function also forces recomputation of the
+menu bar menus and the frame title."
(if all (save-excursion (set-buffer (other-buffer))))
(set-buffer-modified-p (buffer-modified-p)))
(defun momentary-string-display (string pos &optional exit-char message)
"Momentarily display STRING in the buffer at POS.
-Display remains until next character is typed.
-If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed;
-otherwise it is then available as input (as a command if nothing else).
+Display remains until next event is input.
+Optional third arg EXIT-CHAR can be a character, event or event
+description list. EXIT-CHAR defaults to SPC. If the input is
+EXIT-CHAR it is swallowed; otherwise it is then available as
+input (as a command if nothing else).
Display MESSAGE (optional fourth arg) in the echo area.
If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
(or exit-char (setq exit-char ?\ ))
(recenter 0))))
(message (or message "Type %s to continue editing.")
(single-key-description exit-char))
- (let ((char (read-event)))
- (or (eq char exit-char)
- (setq unread-command-events (list char)))))
+ (let (char)
+ (if (integerp exit-char)
+ (condition-case nil
+ (progn
+ (setq char (read-char))
+ (or (eq char exit-char)
+ (setq unread-command-events (list char))))
+ (error
+ ;; `exit-char' is a character, hence it differs
+ ;; from char, which is an event.
+ (setq unread-command-events (list char))))
+ ;; `exit-char' can be an event, or an event description
+ ;; list.
+ (setq char (read-event))
+ (or (eq char exit-char)
+ (eq char (event-convert-list exit-char))
+ (setq unread-command-events (list char))))))
(if insert-end
(save-excursion
(delete-region pos insert-end)))
(overlay-put o1 (pop props) (pop props)))
o1))
-(defun remove-overlays (beg end name val)
+(defun remove-overlays (&optional beg end name val)
"Clear BEG and END of overlays whose property NAME has value VAL.
-Overlays might be moved and or split."
+Overlays might be moved and/or split.
+BEG and END default respectively to the beginning and end of buffer."
+ (unless beg (setq beg (point-min)))
+ (unless end (setq end (point-max)))
(if (< end beg)
(setq beg (prog1 end (setq end beg))))
(save-excursion
;; This should probably be written in C (i.e., without using `walk-windows').
(defun get-buffer-window-list (buffer &optional minibuf frame)
- "Return windows currently displaying BUFFER, or nil if none.
+ "Return list of all windows displaying BUFFER, or nil if none.
+BUFFER can be a buffer or a buffer name.
See `walk-windows' for the meaning of MINIBUF and FRAME."
(let ((buffer (if (bufferp buffer) buffer (get-buffer buffer))) windows)
(walk-windows (function (lambda (window)
(defvar yank-undo-function)
(defun insert-for-yank (string)
+ "Calls `insert-for-yank-1' repetitively for each `yank-handler' segment.
+
+See `insert-for-yank-1' for more details."
+ (let (to)
+ (while (setq to (next-single-property-change 0 'yank-handler string))
+ (insert-for-yank-1 (substring string 0 to))
+ (setq string (substring string to))))
+ (insert-for-yank-1 string))
+
+(defun insert-for-yank-1 (string)
"Insert STRING at point, stripping some text properties.
+
Strip text properties from the inserted text according to
`yank-excluded-properties'. Otherwise just like (insert STRING).
(if (nth 4 handler) ;; COMMAND
(setq this-command (nth 4 handler)))))
-(defun insert-buffer-substring-no-properties (buf &optional start end)
- "Insert before point a substring of buffer BUFFER, without text properties.
+(defun insert-buffer-substring-no-properties (buffer &optional start end)
+ "Insert before point a substring of BUFFER, without text properties.
BUFFER may be a buffer or a buffer name.
-Arguments START and END are character numbers specifying the substring.
-They default to the beginning and the end of BUFFER."
+Arguments START and END are character positions specifying the substring.
+They default to the values of (point-min) and (point-max) in BUFFER."
(let ((opoint (point)))
- (insert-buffer-substring buf start end)
+ (insert-buffer-substring buffer start end)
(let ((inhibit-read-only t))
(set-text-properties opoint (point) nil))))
-(defun insert-buffer-substring-as-yank (buf &optional start end)
- "Insert before point a part of buffer BUFFER, stripping some text properties.
-BUFFER may be a buffer or a buffer name. Arguments START and END are
-character numbers specifying the substring. They default to the
-beginning and the end of BUFFER. Strip text properties from the
-inserted text according to `yank-excluded-properties'."
+(defun insert-buffer-substring-as-yank (buffer &optional start end)
+ "Insert before point a part of BUFFER, stripping some text properties.
+BUFFER may be a buffer or a buffer name.
+Arguments START and END are character positions specifying the substring.
+They default to the values of (point-min) and (point-max) in BUFFER.
+Strip text properties from the inserted text according to
+`yank-excluded-properties'."
+ ;; Since the buffer text should not normally have yank-handler properties,
+ ;; there is no need to handle them here.
(let ((opoint (point)))
- (insert-buffer-substring buf start end)
+ (insert-buffer-substring buffer start end)
(remove-yank-excluded-properties opoint (point))))
\f
(defun start-process-shell-command (name buffer &rest args)
"Start a program in a subprocess. Return the process object for it.
-Args are NAME BUFFER COMMAND &rest COMMAND-ARGS.
NAME is name for process. It is modified if necessary to make it unique.
-BUFFER is the buffer or (buffer-name) to associate with the process.
+BUFFER is the buffer (or buffer name) to associate with the process.
Process output goes at end of that buffer, unless you specify
an output stream or filter function to handle the output.
BUFFER may be also nil, meaning that this process is not associated
with any buffer
-Third arg is command name, the name of a shell command.
+COMMAND is the name of a shell command.
Remaining arguments are the arguments for the command.
-Wildcards and redirection are handled as usual in the shell."
+Wildcards and redirection are handled as usual in the shell.
+
+\(fn NAME BUFFER COMMAND &rest COMMAND-ARGS)"
(cond
((eq system-type 'vax-vms)
(apply 'start-process name buffer args))
(defmacro with-selected-window (window &rest body)
"Execute the forms in BODY with WINDOW as the selected window.
The value returned is the value of the last form in BODY.
+This does not alter the buffer list ordering.
+This function saves and restores the selected window, as well as
+the selected window in each frame. If the previously selected
+window of some frame is no longer live at the end of BODY, that
+frame's selected window is left alone. If the selected window is
+no longer live, then whatever window is selected at the end of
+BODY remains selected.
See also `with-temp-buffer'."
(declare (indent 1) (debug t))
- `(save-selected-window
- (select-window ,window 'norecord)
- ,@body))
+ ;; Most of this code is a copy of save-selected-window.
+ `(let ((save-selected-window-window (selected-window))
+ ;; It is necessary to save all of these, because calling
+ ;; select-window changes frame-selected-window for whatever
+ ;; frame that window is in.
+ (save-selected-window-alist
+ (mapcar (lambda (frame) (list frame (frame-selected-window frame)))
+ (frame-list))))
+ (unwind-protect
+ (progn (select-window ,window 'norecord)
+ ,@body)
+ (dolist (elt save-selected-window-alist)
+ (and (frame-live-p (car elt))
+ (window-live-p (cadr elt))
+ (set-frame-selected-window (car elt) (cadr elt))))
+ (if (window-live-p save-selected-window-window)
+ (select-window save-selected-window-window 'norecord)))))
(defmacro with-temp-file (file &rest body)
"Create a new buffer, evaluate BODY there, and write the buffer to FILE.
See also `with-temp-file' and `with-output-to-string'."
(declare (indent 0) (debug t))
(let ((temp-buffer (make-symbol "temp-buffer")))
- `(let ((,temp-buffer
- (get-buffer-create (generate-new-buffer-name " *temp*"))))
+ `(let ((,temp-buffer (generate-new-buffer " *temp*")))
(unwind-protect
(with-current-buffer ,temp-buffer
,@body)
(kill-buffer nil)))))
(defmacro with-local-quit (&rest body)
- "Execute BODY with `inhibit-quit' temporarily bound to nil."
+ "Execute BODY, allowing quits to terminate BODY but not escape further.
+When a quit terminates BODY, `with-local-quit' returns nil but
+requests another quit. That quit will be processed, the next time quitting
+is allowed once again."
(declare (debug t) (indent 0))
`(condition-case nil
(let ((inhibit-quit nil))
,@body)
- (quit (setq quit-flag t))))
+ (quit (setq quit-flag t) nil)))
+
+(defmacro while-no-input (&rest body)
+ "Execute BODY only as long as there's no pending input.
+If input arrives, that ends the execution of BODY,
+and `while-no-input' returns nil. If BODY finishes,
+`while-no-input' returns whatever value BODY produced."
+ (declare (debug t) (indent 0))
+ (let ((catch-sym (make-symbol "input")))
+ `(with-local-quit
+ (catch ',catch-sym
+ (let ((throw-on-input ',catch-sym))
+ (when (sit-for 0 0 t)
+ ,@body))))))
(defmacro combine-after-change-calls (&rest body)
"Execute BODY, but don't call the after-change functions till the end.
(defvar delayed-mode-hooks nil
"List of delayed mode hooks waiting to be run.")
(make-variable-buffer-local 'delayed-mode-hooks)
+(put 'delay-mode-hooks 'permanent-local t)
+
+(defvar after-change-major-mode-hook nil
+ "Normal hook run at the very end of major mode functions.")
(defun run-mode-hooks (&rest hooks)
"Run mode hooks `delayed-mode-hooks' and HOOKS, or delay HOOKS.
Execution is delayed if `delay-mode-hooks' is non-nil.
+If `delay-mode-hooks' is nil, run `after-change-major-mode-hook'
+after running the mode hooks.
Major mode functions should use this."
(if delay-mode-hooks
;; Delaying case.
;; Normal case, just run the hook as before plus any delayed hooks.
(setq hooks (nconc (nreverse delayed-mode-hooks) hooks))
(setq delayed-mode-hooks nil)
- (apply 'run-hooks hooks)))
+ (apply 'run-hooks hooks)
+ (run-hooks 'after-change-major-mode-hook)))
(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.
Only affects hooks run in the current buffer."
(declare (debug t))
`(progn
(setq parent (get parent 'derived-mode-parent))))
parent))
+(defun find-tag-default ()
+ "Determine default tag to search for, based on text at point.
+If there is no plausible default, return nil."
+ (save-excursion
+ (while (looking-at "\\sw\\|\\s_")
+ (forward-char 1))
+ (if (or (re-search-backward "\\sw\\|\\s_"
+ (save-excursion (beginning-of-line) (point))
+ t)
+ (re-search-forward "\\(\\sw\\|\\s_\\)+"
+ (save-excursion (end-of-line) (point))
+ t))
+ (progn
+ (goto-char (match-end 0))
+ (condition-case nil
+ (buffer-substring-no-properties
+ (point)
+ (progn (forward-sexp -1)
+ (while (looking-at "\\s'")
+ (forward-char 1))
+ (point)))
+ (error nil)))
+ nil)))
+
(defmacro with-syntax-table (table &rest body)
"Evaluate BODY with syntax table of current buffer set to TABLE.
The syntax table of the current buffer is saved, BODY is evaluated, and the
"Use function FUN as a dynamic completion table.
FUN is called with one argument, the string for which completion is required,
and it should return an alist containing all the intended possible
-completions. This alist may be a full list of possible completions so that FUN
-can ignore the value of its argument. If completion is performed in the
+completions. This alist may be a full list of possible completions so that FUN
+can ignore the value of its argument. If completion is performed in the
minibuffer, FUN will be called in the buffer from which the minibuffer was
-entered. `dynamic-completion-table' then computes the completion, see Info
-node `(elisp)Programmed Completion'."
+entered.
+
+The result of the `dynamic-completion-table' form is a function
+that can be used as the ALIST argument to `try-completion' and
+`all-completion'. See Info node `(elisp)Programmed Completion'."
(let ((win (make-symbol "window"))
(string (make-symbol "string"))
(predicate (make-symbol "predicate"))
"Initialize variable VAR as a lazy completion table.
If the completion table VAR is used for the first time (e.g., by passing VAR
as an argument to `try-completion'), the function FUN is called with arguments
-ARGS. FUN must return the completion table that will be stored in VAR. If
-completion is requested in the minibuffer, FUN will be called in the buffer
-from which the minibuffer was entered. The return value of
+ARGS. FUN must return the completion table that will be stored in VAR.
+If completion is requested in the minibuffer, FUN will be called in the buffer
+from which the minibuffer was entered. The return value of
`lazy-completion-table' must be used to initialize the value of VAR."
(let ((str (make-symbol "string")))
`(dynamic-completion-table
STRING should be given if the last search was by `string-match' on STRING."
(if (match-beginning num)
(if string
- (let ((result
- (substring string (match-beginning num) (match-end num))))
- (set-text-properties 0 (length result) nil result)
- result)
+ (substring-no-properties string (match-beginning num)
+ (match-end num))
(buffer-substring-no-properties (match-beginning num)
(match-end num)))))
(defun looking-back (regexp &optional limit)
"Return non-nil if text before point matches regular expression REGEXP.
-Like `looking-at' except backwards and slower.
+Like `looking-at' except matches before point, and is slower.
LIMIT if non-nil speeds up the search by specifying how far back the
match can start."
- (save-excursion
- (re-search-backward (concat "\\(?:" regexp "\\)\\=") limit t)))
+ (not (null
+ (save-excursion
+ (re-search-backward (concat "\\(?:" regexp "\\)\\=") limit t)))))
(defconst split-string-default-separators "[ \f\t\n\r\v]+"
"The default value of separators for `split-string'.
;; expression leads to the equivalent implementation that if SEPARATORS
;; is defaulted, OMIT-NULLS is treated as t.
(defun split-string (string &optional separators omit-nulls)
- "Splits STRING into substrings bounded by matches for SEPARATORS.
+ "Split STRING into substrings bounded by matches for SEPARATORS.
The beginning and end of STRING, and each match for SEPARATORS, are
splitting points. The substrings matching SEPARATORS are removed, and
`split-string-default-separators', normally \"[ \\f\\t\\n\\r\\v]+\", and
OMIT-NULLS is forced to t.
-If OMIT-NULLs is t, zero-length substrings are omitted from the list \(so
+If OMIT-NULLS is t, zero-length substrings are omitted from the list \(so
that for the default value of SEPARATORS leading and trailing whitespace
are effectively trimmed). If nil, all zero-length substrings are retained,
which correctly parses CSV format, for example.
;; Reconstruct a string from the pieces.
(setq matches (cons (substring string start l) matches)) ; leftover
(apply #'concat (nreverse matches)))))
+
+(defun subregexp-context-p (regexp pos &optional start)
+ "Return non-nil if POS is in a normal subregexp context in REGEXP.
+A subregexp context is one where a sub-regexp can appear.
+A non-subregexp context is for example within brackets, or within a
+repetition bounds operator `\\=\\{...\\}', or right after a `\\'.
+If START is non-nil, it should be a position in REGEXP, smaller
+than POS, and known to be in a subregexp context."
+ ;; Here's one possible implementation, with the great benefit that it
+ ;; reuses the regexp-matcher's own parser, so it understands all the
+ ;; details of the syntax. A disadvantage is that it needs to match the
+ ;; error string.
+ (condition-case err
+ (progn
+ (string-match (substring regexp (or start 0) pos) "")
+ t)
+ (invalid-regexp
+ (not (member (cadr err) '("Unmatched [ or [^"
+ "Unmatched \\{"
+ "Trailing backslash")))))
+ ;; An alternative implementation:
+ ;; (defconst re-context-re
+ ;; (let* ((harmless-ch "[^\\[]")
+ ;; (harmless-esc "\\\\[^{]")
+ ;; (class-harmless-ch "[^][]")
+ ;; (class-lb-harmless "[^]:]")
+ ;; (class-lb-colon-maybe-charclass ":\\([a-z]+:]\\)?")
+ ;; (class-lb (concat "\\[\\(" class-lb-harmless
+ ;; "\\|" class-lb-colon-maybe-charclass "\\)"))
+ ;; (class
+ ;; (concat "\\[^?]?"
+ ;; "\\(" class-harmless-ch
+ ;; "\\|" class-lb "\\)*"
+ ;; "\\[?]")) ; special handling for bare [ at end of re
+ ;; (braces "\\\\{[0-9,]+\\\\}"))
+ ;; (concat "\\`\\(" harmless-ch "\\|" harmless-esc
+ ;; "\\|" class "\\|" braces "\\)*\\'"))
+ ;; "Matches any prefix that corresponds to a normal subregexp context.")
+ ;; (string-match re-context-re (substring regexp (or start 0) pos))
+ )
\f
(defun shell-quote-argument (argument)
"Quote an argument for passing as argument to an inferior shell."
table))
(defun syntax-after (pos)
- "Return the syntax of the char after POS."
+ "Return the raw syntax of the char after POS.
+If POS is outside the buffer's accessible portion, return nil."
(unless (or (< pos (point-min)) (>= pos (point-max)))
(let ((st (if parse-sexp-lookup-properties
(get-char-property pos 'syntax-table))))
(if (consp st) st
(aref (or st (syntax-table)) (char-after pos))))))
-(defun add-to-invisibility-spec (arg)
- "Add elements to `buffer-invisibility-spec'.
+(defun syntax-class (syntax)
+ "Return the syntax class part of the syntax descriptor SYNTAX.
+If SYNTAX is nil, return nil."
+ (and syntax (logand (car syntax) 65535)))
+
+(defun add-to-invisibility-spec (element)
+ "Add ELEMENT to `buffer-invisibility-spec'.
See documentation for `buffer-invisibility-spec' for the kind of elements
that can be added."
(if (eq buffer-invisibility-spec t)
(setq buffer-invisibility-spec (list t)))
(setq buffer-invisibility-spec
- (cons arg buffer-invisibility-spec)))
+ (cons element buffer-invisibility-spec)))
-(defun remove-from-invisibility-spec (arg)
- "Remove elements from `buffer-invisibility-spec'."
+(defun remove-from-invisibility-spec (element)
+ "Remove ELEMENT from `buffer-invisibility-spec'."
(if (consp buffer-invisibility-spec)
- (setq buffer-invisibility-spec (delete arg buffer-invisibility-spec))))
+ (setq buffer-invisibility-spec (delete element buffer-invisibility-spec))))
\f
(defun global-set-key (key command)
"Give KEY a global binding as COMMAND.
(defun global-unset-key (key)
"Remove global binding of KEY.
-KEY is a string representing a sequence of keystrokes."
+KEY is a string or vector representing a sequence of keystrokes."
(interactive "kUnset key globally: ")
(global-set-key key nil))
(defun local-unset-key (key)
"Remove local binding of KEY.
-KEY is a string representing a sequence of keystrokes."
+KEY is a string or vector representing a sequence of keystrokes."
(interactive "kUnset key locally: ")
(if (current-local-map)
(local-set-key key nil))
(eq (car object) 'frame-configuration)))
(defun functionp (object)
- "Non-nil iff OBJECT is a type of object that can be called as a function."
+ "Non-nil if OBJECT is any kind of function or a special form.
+Also non-nil if OBJECT is a symbol and its function definition is
+\(recursively) a function or special form. This does not include
+macros."
(or (and (symbolp object) (fboundp object)
(condition-case nil
(setq object (indirect-function object))
(subrp object) (byte-code-function-p object)
(eq (car-safe object) 'lambda)))
-(defun interactive-form (function)
- "Return the interactive form of FUNCTION.
-If function is a command (see `commandp'), value is a list of the form
-\(interactive SPEC). If function is not a command, return nil."
- (setq function (indirect-function function))
- (when (commandp function)
- (cond ((byte-code-function-p function)
- (when (> (length function) 5)
- (let ((spec (aref function 5)))
- (if spec
- (list 'interactive spec)
- (list 'interactive)))))
- ((subrp function)
- (subr-interactive-form function))
- ((eq (car-safe function) 'lambda)
- (setq function (cddr function))
- (when (stringp (car function))
- (setq function (cdr function)))
- (let ((form (car function)))
- (when (eq (car-safe form) 'interactive)
- (copy-sequence form)))))))
-
(defun assq-delete-all (key alist)
- "Delete from ALIST all elements whose car is KEY.
+ "Delete from ALIST all elements whose car is `eq' to KEY.
Return the modified alist.
Elements of ALIST that are not conses are ignored."
- (let ((tail alist))
- (while tail
- (if (and (consp (car tail)) (eq (car (car tail)) key))
- (setq alist (delq (car tail) alist)))
- (setq tail (cdr tail)))
- alist))
+ (while (and (consp (car alist))
+ (eq (car (car alist)) key))
+ (setq alist (cdr alist)))
+ (let ((tail alist) tail-cdr)
+ (while (setq tail-cdr (cdr tail))
+ (if (and (consp (car tail-cdr))
+ (eq (car (car tail-cdr)) key))
+ (setcdr tail (cdr tail-cdr))
+ (setq tail tail-cdr))))
+ alist)
+
+(defun rassq-delete-all (value alist)
+ "Delete from ALIST all elements whose cdr is `eq' to VALUE.
+Return the modified alist.
+Elements of ALIST that are not conses are ignored."
+ (while (and (consp (car alist))
+ (eq (cdr (car alist)) value))
+ (setq alist (cdr alist)))
+ (let ((tail alist) tail-cdr)
+ (while (setq tail-cdr (cdr tail))
+ (if (and (consp (car tail-cdr))
+ (eq (cdr (car tail-cdr)) value))
+ (setcdr tail (cdr tail-cdr))
+ (setq tail tail-cdr))))
+ alist)
(defun make-temp-file (prefix &optional dir-flag suffix)
"Create a temporary file.
;; isearch-mode is deliberately excluded, since you should
;; not call it yourself.
(defvar minor-mode-list '(auto-save-mode auto-fill-mode abbrev-mode
- overwrite-mode view-mode)
+ overwrite-mode view-mode
+ hs-minor-mode)
"List of all minor mode functions.")
(defun add-minor-mode (toggle name &optional keymap after toggle-fun)
(push toggle minor-mode-list))
(unless toggle-fun (setq toggle-fun toggle))
+ (unless (eq toggle-fun toggle)
+ (put toggle :minor-mode-function toggle-fun))
;; Add the name to the minor-mode-alist.
(when name
(let ((existing (assq toggle minor-mode-alist)))
(put symbol 'abortfunc (or abortfunc 'kill-buffer))
(put symbol 'hookvar (or hookvar 'mail-send-hook)))
+;; Standardized progress reporting
+
+;; Progress reporter has the following structure:
+;;
+;; (NEXT-UPDATE-VALUE . [NEXT-UPDATE-TIME
+;; MIN-VALUE
+;; MAX-VALUE
+;; MESSAGE
+;; MIN-CHANGE
+;; MIN-TIME])
+;;
+;; This weirdeness is for optimization reasons: we want
+;; `progress-reporter-update' to be as fast as possible, so
+;; `(car reporter)' is better than `(aref reporter 0)'.
+;;
+;; NEXT-UPDATE-TIME is a float. While `float-time' loses a couple
+;; digits of precision, it doesn't really matter here. On the other
+;; hand, it greatly simplifies the code.
+
+(defsubst progress-reporter-update (reporter value)
+ "Report progress of an operation in the echo area.
+However, if the change since last echo area update is too small
+or not enough time has passed, then do nothing (see
+`make-progress-reporter' for details).
+
+First parameter, REPORTER, should be the result of a call to
+`make-progress-reporter'. Second, VALUE, determines the actual
+progress of operation; it must be between MIN-VALUE and MAX-VALUE
+as passed to `make-progress-reporter'.
+
+This function is very inexpensive, you may not bother how often
+you call it."
+ (when (>= value (car reporter))
+ (progress-reporter-do-update reporter value)))
+
+(defun make-progress-reporter (message min-value max-value
+ &optional current-value
+ min-change min-time)
+ "Return progress reporter object to be used with `progress-reporter-update'.
+
+MESSAGE is shown in the echo area. When at least 1% of operation
+is complete, the exact percentage will be appended to the
+MESSAGE. When you call `progress-reporter-done', word \"done\"
+is printed after the MESSAGE. You can change MESSAGE of an
+existing progress reporter with `progress-reporter-force-update'.
+
+MIN-VALUE and MAX-VALUE designate starting (0% complete) and
+final (100% complete) states of operation. The latter should be
+larger; if this is not the case, then simply negate all values.
+Optional CURRENT-VALUE specifies the progress by the moment you
+call this function. You should omit it or set it to nil in most
+cases since it defaults to MIN-VALUE.
+
+Optional MIN-CHANGE determines the minimal change in percents to
+report (default is 1%.) Optional MIN-TIME specifies the minimal
+time before echo area updates (default is 0.2 seconds.) If
+`float-time' function is not present, then time is not tracked
+at all. If OS is not capable of measuring fractions of seconds,
+then this parameter is effectively rounded up."
+
+ (unless min-time
+ (setq min-time 0.2))
+ (let ((reporter
+ (cons min-value ;; Force a call to `message' now
+ (vector (if (and (fboundp 'float-time)
+ (>= min-time 0.02))
+ (float-time) nil)
+ min-value
+ max-value
+ message
+ (if min-change (max (min min-change 50) 1) 1)
+ min-time))))
+ (progress-reporter-update reporter (or current-value min-value))
+ reporter))
+
+(defun progress-reporter-force-update (reporter value &optional new-message)
+ "Report progress of an operation in the echo area unconditionally.
+
+First two parameters are the same as for
+`progress-reporter-update'. Optional NEW-MESSAGE allows you to
+change the displayed message."
+ (let ((parameters (cdr reporter)))
+ (when new-message
+ (aset parameters 3 new-message))
+ (when (aref parameters 0)
+ (aset parameters 0 (float-time)))
+ (progress-reporter-do-update reporter value)))
+
+(defun progress-reporter-do-update (reporter value)
+ (let* ((parameters (cdr reporter))
+ (min-value (aref parameters 1))
+ (max-value (aref parameters 2))
+ (one-percent (/ (- max-value min-value) 100.0))
+ (percentage (if (= max-value min-value)
+ 0
+ (truncate (/ (- value min-value) one-percent))))
+ (update-time (aref parameters 0))
+ (current-time (float-time))
+ (enough-time-passed
+ ;; See if enough time has passed since the last update.
+ (or (not update-time)
+ (when (>= current-time update-time)
+ ;; Calculate time for the next update
+ (aset parameters 0 (+ update-time (aref parameters 5)))))))
+ ;;
+ ;; Calculate NEXT-UPDATE-VALUE. If we are not going to print
+ ;; message this time because not enough time has passed, then use
+ ;; 1 instead of MIN-CHANGE. This makes delays between echo area
+ ;; updates closer to MIN-TIME.
+ (setcar reporter
+ (min (+ min-value (* (+ percentage
+ (if enough-time-passed
+ (aref parameters 4) ;; MIN-CHANGE
+ 1))
+ one-percent))
+ max-value))
+ (when (integerp value)
+ (setcar reporter (ceiling (car reporter))))
+ ;;
+ ;; Only print message if enough time has passed
+ (when enough-time-passed
+ (if (> percentage 0)
+ (message "%s%d%%" (aref parameters 3) percentage)
+ (message "%s" (aref parameters 3))))))
+
+(defun progress-reporter-done (reporter)
+ "Print reporter's message followed by word \"done\" in echo area."
+ (message "%sdone" (aref (cdr reporter) 3)))
+
+(defmacro dotimes-with-progress-reporter (spec message &rest body)
+ "Loop a certain number of times and report progress in the echo area.
+Evaluate BODY with VAR bound to successive integers running from
+0, inclusive, to COUNT, exclusive. Then evaluate RESULT to get
+the return value (nil if RESULT is omitted).
+
+At each iteration MESSAGE followed by progress percentage is
+printed in the echo area. After the loop is finished, MESSAGE
+followed by word \"done\" is printed. This macro is a
+convenience wrapper around `make-progress-reporter' and friends.
+
+\(fn (VAR COUNT [RESULT]) MESSAGE BODY...)"
+ (declare (indent 2) (debug ((symbolp form &optional form) form body)))
+ (let ((temp (make-symbol "--dotimes-temp--"))
+ (temp2 (make-symbol "--dotimes-temp2--"))
+ (start 0)
+ (end (nth 1 spec)))
+ `(let ((,temp ,end)
+ (,(car spec) ,start)
+ (,temp2 (make-progress-reporter ,message ,start ,end)))
+ (while (< ,(car spec) ,temp)
+ ,@body
+ (progress-reporter-update ,temp2
+ (setq ,(car spec) (1+ ,(car spec)))))
+ (progress-reporter-done ,temp2)
+ nil ,@(cdr (cdr spec)))))
+
+;; arch-tag: f7e0e6e5-70aa-4897-ae72-7a3511ec40bc
;;; subr.el ends here