;;; subr.el --- basic lisp subroutines for Emacs
-;; Copyright (C) 1985, 86, 92, 94, 95, 99, 2000, 2001, 2002, 03, 2004
-;; 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
(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)
(char (logand type (lognot (logior ?\M-\^@ ?\C-\^@ ?\S-\^@
?\H-\^@ ?\s-\^@ ?\A-\^@)))))
(if (not (zerop (logand type ?\M-\^@)))
- (setq list (cons 'meta list)))
+ (push 'meta list))
(if (or (not (zerop (logand type ?\C-\^@)))
(< char 32))
- (setq list (cons 'control list)))
+ (push 'control list))
(if (or (not (zerop (logand type ?\S-\^@)))
(/= char (downcase char)))
- (setq list (cons 'shift list)))
+ (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)
(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.
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 ()
(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.
;;; 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)))
(make-obsolete 'process-kill-without-query
"use `process-query-on-exit-flag' or `set-process-query-on-exit-flag'."
- "21.5")
+ "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.
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.
-If optional CONFIRM is non-nil, read password 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) (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)))
+ "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))
- (clear-string new-char)
- (setq c ?\0)
- (setq pass new-pass))
- (if (> (length pass) 0)
- (let ((new-pass (substring pass 0 -1)))
+ (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))
- (setq pass new-pass))))))
- (message nil)
- (or pass default ""))))
+ (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)
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)
(defmacro with-local-quit (&rest body)
"Execute BODY, allowing quits to terminate BODY but not escape further.
-When a quit terminates BODY, `with-local-quit' requests another quit when
-it finishes. That quit will be processed in turn, the next time quitting
-is again allowed."
+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.
(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))
+ (buffer-substring-no-properties
+ (point)
+ (progn (forward-sexp -1)
+ (while (looking-at "\\s'")
+ (forward-char 1))
+ (point))))
+ 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
(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
;; 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."
(unless (or (< pos (point-min)) (>= pos (point-max)))
(let ((st (if parse-sexp-lookup-properties
(get-char-property pos 'syntax-table))))
(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))
(put symbol 'abortfunc (or abortfunc 'kill-buffer))
(put symbol 'hookvar (or hookvar 'mail-send-hook)))
-;;; arch-tag: f7e0e6e5-70aa-4897-ae72-7a3511ec40bc
+;; 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 (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