;;; subr.el --- basic lisp subroutines for Emacs
;; Copyright (C) 1985, 1986, 1992, 1994, 1995, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005 Free Software Foundation, Inc.
+;; 2004, 2005 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
(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."
+signaled."
`(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
+ "Evaluates FORM, with the expectation that 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."
self-quoting; the result of evaluating the lambda expression is the
expression itself. The lambda expression may then be treated as a
function, i.e., stored as the function value of a symbol, passed to
-funcall or mapcar, etc.
+`funcall' or `mapcar', etc.
ARGS should take the same form as an argument list for a `defun'.
DOCSTRING is an optional documentation string.
(setq loop (1+ loop))))))
(defvar key-substitution-in-progress nil
- "Used internally by substitute-key-definition.")
+ "Used internally by `substitute-key-definition'.")
(defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix)
"Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
(setq event (car event)))
(if (symbolp event)
(car (get event 'event-symbol-elements))
- (let ((base (logand event (1- ?\A-\^@))))
- (downcase (if (< base 32) (logior base 64) base)))))
+ (let* ((base (logand event (1- ?\A-\^@)))
+ (uncontrolled (if (< base 32) (logior base 64) base)))
+ ;; There are some numbers that are invalid characters and
+ ;; cause `downcase' to get an error.
+ (condition-case ()
+ (downcase uncontrolled)
+ (error uncontrolled)))))
(defsubst mouse-movement-p (object)
"Return non-nil if OBJECT is a mouse movement event."
\f
;;;; Obsolescent names for functions.
-(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 'eval-current-buffer 'eval-buffer)
+(define-obsolete-function-alias 'window-dot 'window-point "22.1")
+(define-obsolete-function-alias 'set-window-dot 'set-window-point "22.1")
+(define-obsolete-function-alias 'read-input 'read-string "22.1")
+(define-obsolete-function-alias 'show-buffer 'set-window-buffer "22.1")
+(define-obsolete-function-alias 'eval-current-buffer 'eval-buffer "22.1")
+(define-obsolete-function-alias 'string-to-int 'string-to-number "22.1")
(make-obsolete 'char-bytes "now always returns 1." "20.4")
-(define-obsolete-function-alias 'string-to-int 'string-to-number)
(defun insert-string (&rest args)
"Mocklisp-compatibility insert function.
baud-rate)
(make-obsolete 'baud-rate "use the `baud-rate' variable instead." "before 19.15")
+;; These are used by VM and some old programs
+(defalias 'focus-frame 'ignore "")
+(make-obsolete 'focus-frame "it does nothing." "22.1")
+(defalias 'unfocus-frame 'ignore "")
+(make-obsolete 'unfocus-frame "it does nothing." "22.1")
+
\f
;;;; Obsolescence declarations for variables, and aliases.
(make-obsolete-variable 'unread-command-char
"use `unread-command-events' instead. That variable is a list of events to reread, so it now uses nil to mean `no event', instead of -1."
"before 19.15")
-(make-obsolete-variable 'post-command-idle-hook
- "use timers instead, with `run-with-idle-timer'." "before 19.34")
-(make-obsolete-variable 'post-command-idle-delay
- "use timers instead, with `run-with-idle-timer'." "before 19.34")
;; Lisp manual only updated in 22.1.
(define-obsolete-variable-alias 'executing-macro 'executing-kbd-macro
\f
;;;; Alternate names for functions - these are not being phased out.
+(defalias 'send-string 'process-send-string)
+(defalias 'send-region 'process-send-region)
(defalias 'string= 'string-equal)
(defalias 'string< 'string-lessp)
(defalias 'move-marker 'set-marker)
(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.
+ "Add ELEMENT to the value of LIST-VAR if it isn't there yet.
The test for presence of ELEMENT is done with `equal'.
If ELEMENT is added, it is added at the beginning of the list,
unless the optional argument APPEND is non-nil, in which case
(append (symbol-value list-var) (list element))
(cons element (symbol-value list-var))))))
+
+(defun add-to-ordered-list (list-var element &optional order)
+ "Add ELEMENT to the value of LIST-VAR if it isn't there yet.
+The test for presence of ELEMENT is done with `eq'.
+
+The resulting list is reordered so that the elements are in the
+order given by each element's numeric list order. Elements
+without a numeric list order are placed at the end of the list.
+
+If the third optional argument ORDER is a number (integer or
+float), set the element's list order to the given value. If
+ORDER is nil or omitted, do not change the numeric order of
+ELEMENT. If ORDER has any other value, remove the numeric order
+of ELEMENT if it has one.
+
+The list order for each element is stored in LIST-VAR's
+`list-order' property.
+
+The return value is the new value of LIST-VAR."
+ (let ((ordering (get list-var 'list-order)))
+ (unless ordering
+ (put list-var 'list-order
+ (setq ordering (make-hash-table :weakness 'key :test 'eq))))
+ (when order
+ (puthash element (and (numberp order) order) ordering))
+ (unless (memq element (symbol-value list-var))
+ (set list-var (cons element (symbol-value list-var))))
+ (set list-var (sort (symbol-value list-var)
+ (lambda (a b)
+ (let ((oa (gethash a ordering))
+ (ob (gethash b ordering)))
+ (if (and oa ob)
+ (< oa ob)
+ oa)))))))
+
\f
;;; Load history
\f
;;;; Miscellanea.
-;; A number of major modes set this locally.
-;; Give it a global value to avoid compiler warnings.
-(defvar font-lock-defaults nil)
-
(defvar suspend-hook nil
"Normal hook run by `suspend-emacs', before suspending.")
`yank-excluded-properties'. Otherwise just like (insert STRING).
If STRING has a non-nil `yank-handler' property on the first character,
-the normal insert behaviour is modified in various ways. The value of
-the yank-handler property must be a list with one to five elements
+the normal insert behavior is modified in various ways. The value of
+the yank-handler property must be a list with one to four elements
with the following format: (FUNCTION PARAM NOEXCLUDE UNDO).
When FUNCTION is present and non-nil, it is called instead of `insert'
to insert the string. FUNCTION takes one argument--the object to insert.
(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
+
+This macro saves and restores the current buffer, since otherwise
+its normal operation could potentially make a different
+buffer current. It does not alter the buffer list ordering.
+
+This macro 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
(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)))))
+ (save-current-buffer
+ (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.
(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."
+and `while-no-input' returns t. Quitting makes it return 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)
+ (or (not (sit-for 0 0 t))
,@body))))))
(defmacro combine-after-change-calls (&rest body)
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))
+ (declare (debug t) (indent 0))
`(progn
(make-local-variable 'delay-mode-hooks)
(let ((delay-mode-hooks t))
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'."
+ (declare (debug (lambda-expr)))
(let ((win (make-symbol "window"))
(string (make-symbol "string"))
(predicate (make-symbol "predicate"))
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."
+ (declare (debug (symbol lambda-expr def-body)))
(let ((str (make-symbol "string")))
`(dynamic-completion-table
(lambda (,str)
(unless (listp ,var)
- (setq ,var (funcall ',fun ,@args)))
+ (setq ,var (,fun ,@args)))
,var))))
+
+(defmacro complete-in-turn (a b)
+ "Create a completion table that first tries completion in A and then in B.
+A and B should not be costly (or side-effecting) expressions."
+ (declare (debug (def-form def-form)))
+ `(lambda (string predicate mode)
+ (cond
+ ((eq mode t)
+ (or (all-completions string ,a predicate)
+ (all-completions string ,b predicate)))
+ ((eq mode nil)
+ (or (try-completion string ,a predicate)
+ (try-completion string ,b predicate)))
+ (t
+ (or (test-completion string ,a predicate)
+ (test-completion string ,b predicate))))))
\f
;;; Matching and substitution
'((save-match-data-internal (match-data)))
(list 'unwind-protect
(cons 'progn body)
- '(set-match-data save-match-data-internal))))
+ ;; It is safe to free (evaporate) markers immediately here,
+ ;; as Lisp programs should not copy from save-match-data-internal.
+ '(set-match-data save-match-data-internal 'evaporate))))
(defun match-string (num &optional string)
"Return string of text matched by last search.
(buffer-substring-no-properties (match-beginning num)
(match-end num)))))
-(defun looking-back (regexp &optional limit)
+(defun looking-back (regexp &optional limit greedy)
"Return non-nil if text before point matches regular expression REGEXP.
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."
- (not (null
- (save-excursion
- (re-search-backward (concat "\\(?:" regexp "\\)\\=") limit t)))))
+match can start.
+
+If GREEDY is non-nil, extend the match backwards as far as possible,
+stopping when a single additional previous character cannot be part
+of a match for REGEXP."
+ (let ((start (point))
+ (pos
+ (save-excursion
+ (and (re-search-backward (concat "\\(?:" regexp "\\)\\=") limit t)
+ (point)))))
+ (if (and greedy pos)
+ (save-restriction
+ (narrow-to-region (point-min) start)
+ (while (and (> pos (point-min))
+ (save-excursion
+ (goto-char pos)
+ (backward-char 1)
+ (looking-at (concat "\\(?:" regexp "\\)\\'"))))
+ (setq pos (1- pos)))
+ (save-excursion
+ (goto-char pos)
+ (looking-at (concat "\\(?:" regexp "\\)\\'")))))
+ (not (null pos))))
+
(defconst split-string-default-separators "[ \f\t\n\r\v]+"
"The default value of separators for `split-string'.
is non-nil, start replacements at that index in STRING.
REP is either a string used as the NEWTEXT arg of `replace-match' or a
-function. If it is a function it is applied to each match to generate
-the replacement passed to `replace-match'; the match-data at this
-point are such that match 0 is the function's argument.
+function. If it is a function, it is called with the actual text of each
+match, and its value is used as the replacement text. When REP is called,
+the match-data are the result of matching REGEXP against a substring
+of STRING.
To replace only the first match (if any), make REGEXP match up to \\'
and replace a sub-expression, e.g.
(and (consp object)
(eq (car object) 'frame-configuration)))
-(defsubst left-fringe-p ()
- (equal (car (window-fringes)) 0))
-
(defun functionp (object)
"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
:device DEVICE - play sound on DEVICE. If not specified,
a system-dependent default device name is used."
- (unless (fboundp 'play-sound-internal)
- (error "This Emacs binary lacks sound support"))
- (play-sound-internal sound))
+ (if (fboundp 'play-sound-internal)
+ (play-sound-internal sound)
+ (error "This Emacs binary lacks sound support")))
(defun define-mail-user-agent (symbol composefunc sendfunc
&optional abortfunc hookvar)
(progress-reporter-done ,temp2)
nil ,@(cdr (cdr spec)))))
+\f
+;;;; Compare Version Strings
+
+(defvar version-separator "."
+ "*Specify the string used to separate the version elements.
+
+Usually the separator is \".\", but it can be any other string.")
+
+
+(defvar version-regexp-alist
+ '(("^a\\(lpha\\)?$" . -3)
+ ("^b\\(eta\\)?$" . -2)
+ ("^\\(pre\\|rc\\)$" . -1))
+ "*Specify association between non-numeric version part and a priority.
+
+This association is used to handle version string like \"1.0pre2\",
+\"0.9alpha1\", etc. It's used by `version-to-list' (which see) to convert the
+non-numeric part to an integer. For example:
+
+ String Version Integer List Version
+ \"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)
+ \"0.9AlphA1\" (0 9 -3 1)
+ \"0.9alpha\" (0 9 -3)
+
+Each element has the following form:
+
+ (REGEXP . PRIORITY)
+
+Where:
+
+REGEXP regexp used to match non-numeric part of a version string.
+
+PRIORITY negative integer which indicate the non-numeric priority.")
+
+
+(defun version-to-list (ver)
+ "Convert version string VER into an integer list.
+
+The version syntax is given by the following EBNF:
+
+ VERSION ::= NUMBER ( SEPARATOR NUMBER )*.
+
+ NUMBER ::= (0|1|2|3|4|5|6|7|8|9)+.
+
+ SEPARATOR ::= `version-separator' (which see)
+ | `version-regexp-alist' (which see).
+
+As an example of valid version syntax:
+
+ 1.0pre2 1.0.7.5 22.8beta3 0.9alpha1
+
+As an example of invalid version syntax:
+
+ 1.0prepre2 1.0..7.5 22.8X3 alpha3.2 .5
+
+As an example of version convertion:
+
+ String Version Integer List Version
+ \"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)
+ \"0.9AlphA1\" (0 9 -3 1)
+ \"0.9alpha\" (0 9 -3)
+
+See documentation for `version-separator' and `version-regexp-alist'."
+ (or (and (stringp ver) (not (string= ver "")))
+ (error "Invalid version string: '%s'" ver))
+ (save-match-data
+ (let ((i 0)
+ case-fold-search ; ignore case in matching
+ lst s al)
+ (while (and (setq s (string-match "[0-9]+" ver i))
+ (= s i))
+ ;; handle numeric part
+ (setq lst (cons (string-to-number (substring ver i (match-end 0)))
+ lst)
+ i (match-end 0))
+ ;; handle non-numeric part
+ (when (and (setq s (string-match "[^0-9]+" ver i))
+ (= s i))
+ (setq s (substring ver i (match-end 0))
+ i (match-end 0))
+ ;; handle alpha, beta, pre, etc. separator
+ (unless (string= s version-separator)
+ (setq al version-regexp-alist)
+ (while (and al (not (string-match (caar al) s)))
+ (setq al (cdr al)))
+ (or al (error "Invalid version syntax: '%s'" ver))
+ (setq lst (cons (cdar al) lst)))))
+ (if (null lst)
+ (error "Invalid version syntax: '%s'" ver)
+ (nreverse lst)))))
+
+
+(defun version-list-< (l1 l2)
+ "Return t if integer list L1 is lesser than L2.
+
+Note that integer list (1) is equal to (1 0), (1 0 0), (1 0 0 0),
+etc. That is, the trailing zeroes are irrelevant. Also, integer
+list (1) is greater than (1 -1) which is greater than (1 -2)
+which is greater than (1 -3)."
+ (while (and l1 l2 (= (car l1) (car l2)))
+ (setq l1 (cdr l1)
+ l2 (cdr l2)))
+ (cond
+ ;; l1 not null and l2 not null
+ ((and l1 l2) (< (car l1) (car l2)))
+ ;; l1 null and l2 null ==> l1 length = l2 length
+ ((and (null l1) (null l2)) nil)
+ ;; l1 not null and l2 null ==> l1 length > l2 length
+ (l1 (< (version-list-not-zero l1) 0))
+ ;; l1 null and l2 not null ==> l2 length > l1 length
+ (t (< 0 (version-list-not-zero l2)))))
+
+
+(defun version-list-= (l1 l2)
+ "Return t if integer list L1 is equal to L2.
+
+Note that integer list (1) is equal to (1 0), (1 0 0), (1 0 0 0),
+etc. That is, the trailing zeroes are irrelevant. Also, integer
+list (1) is greater than (1 -1) which is greater than (1 -2)
+which is greater than (1 -3)."
+ (while (and l1 l2 (= (car l1) (car l2)))
+ (setq l1 (cdr l1)
+ l2 (cdr l2)))
+ (cond
+ ;; l1 not null and l2 not null
+ ((and l1 l2) nil)
+ ;; l1 null and l2 null ==> l1 length = l2 length
+ ((and (null l1) (null l2)))
+ ;; l1 not null and l2 null ==> l1 length > l2 length
+ (l1 (zerop (version-list-not-zero l1)))
+ ;; l1 null and l2 not null ==> l2 length > l1 length
+ (t (zerop (version-list-not-zero l2)))))
+
+
+(defun version-list-<= (l1 l2)
+ "Return t if integer list L1 is lesser than or equal to L2.
+
+Note that integer list (1) is equal to (1 0), (1 0 0), (1 0 0 0),
+etc. That is, the trailing zeroes are irrelevant. Also, integer
+list (1) is greater than (1 -1) which is greater than (1 -2)
+which is greater than (1 -3)."
+ (while (and l1 l2 (= (car l1) (car l2)))
+ (setq l1 (cdr l1)
+ l2 (cdr l2)))
+ (cond
+ ;; l1 not null and l2 not null
+ ((and l1 l2) (< (car l1) (car l2)))
+ ;; l1 null and l2 null ==> l1 length = l2 length
+ ((and (null l1) (null l2)))
+ ;; l1 not null and l2 null ==> l1 length > l2 length
+ (l1 (<= (version-list-not-zero l1) 0))
+ ;; l1 null and l2 not null ==> l2 length > l1 length
+ (t (<= 0 (version-list-not-zero l2)))))
+
+(defun version-list-not-zero (lst)
+ "Return the first non-zero element of integer list LST.
+
+If all LST elements are zeroes or LST is nil, return zero."
+ (while (and lst (zerop (car lst)))
+ (setq lst (cdr lst)))
+ (if lst
+ (car lst)
+ ;; there is no element different of zero
+ 0))
+
+
+(defun version< (v1 v2)
+ "Return t if version V1 is lesser than V2.
+
+Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\",
+etc. That is, the trailing \".0\"s are irrelevant. Also, version string \"1\"
+is greater than \"1pre\" which is greater than \"1beta\" which is greater than
+\"1alpha\"."
+ (version-list-< (version-to-list v1) (version-to-list v2)))
+
+
+(defun version<= (v1 v2)
+ "Return t if version V1 is lesser than or equal to V2.
+
+Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\",
+etc. That is, the trailing \".0\"s are irrelevant. Also, version string \"1\"
+is greater than \"1pre\" which is greater than \"1beta\" which is greater than
+\"1alpha\"."
+ (version-list-<= (version-to-list v1) (version-to-list v2)))
+
+(defun version= (v1 v2)
+ "Return t if version V1 is equal to V2.
+
+Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\",
+etc. That is, the trailing \".0\"s are irrelevant. Also, version string \"1\"
+is greater than \"1pre\" which is greater than \"1beta\" which is greater than
+\"1alpha\"."
+ (version-list-= (version-to-list v1) (version-to-list v2)))
+
+
+
;; arch-tag: f7e0e6e5-70aa-4897-ae72-7a3511ec40bc
;;; subr.el ends here