-;;; subr.el --- basic lisp subroutines for Emacs
+;;; subr.el --- basic lisp subroutines for Emacs -*- coding: utf-8 -*-
-;; Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2011
+;; Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2012
;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; depend on backquote.el.
(list 'function (cons 'lambda cdr)))
-;; Partial application of functions (similar to "currying").
-;; This function is here rather than in subr.el because it uses CL.
(defun apply-partially (fun &rest args)
"Return a function that is a partial application of FUN to ARGS.
ARGS is a list of the first N arguments to pass to FUN.
Bindings are always added before any inherited map.
-The order of bindings in a keymap matters when it is used as a menu."
+The order of bindings in a keymap only matters when it is used as
+a menu, so this function is not useful for non-menu keymaps."
(unless after (setq after t))
(or (keymapp keymap)
(signal 'wrong-type-argument (list 'keymapp keymap)))
(defun keymap--menu-item-with-binding (item binding)
"Build a menu-item like ITEM but with its binding changed to BINDING."
(cond
+ ((not (consp item)) binding) ;Not a menu-item.
((eq 'menu-item (car item))
(setq item (copy-sequence item))
(let ((tail (nthcdr 2 item)))
,@(mapcar (lambda (binder) `(setq ,@binder)) binders)
,@body))
-(defmacro with-wrapper-hook (var args &rest body)
- "Run BODY wrapped with the VAR hook.
-VAR is a special hook: its functions are called with a first argument
-which is the \"original\" code (the BODY), so the hook function can wrap
-the original function, or call it any number of times (including not calling
-it at all). This is similar to an `around' advice.
-VAR is normally a symbol (a variable) in which case it is treated like
-a hook, with a buffer-local and a global part. But it can also be an
-arbitrary expression.
-ARGS is a list of variables which will be passed as additional arguments
-to each function, after the initial argument, and which the first argument
-expects to receive when called."
+(defmacro with-wrapper-hook (hook args &rest body)
+ "Run BODY, using wrapper functions from HOOK with additional ARGS.
+HOOK is an abnormal hook. Each hook function in HOOK \"wraps\"
+around the preceding ones, like a set of nested `around' advices.
+
+Each hook function should accept an argument list consisting of a
+function FUN, followed by the additional arguments in ARGS.
+
+The first hook function in HOOK is passed a FUN that, if it is called
+with arguments ARGS, performs BODY (i.e., the default operation).
+The FUN passed to each successive hook function is defined based
+on the preceding hook functions; if called with arguments ARGS,
+it does what the `with-wrapper-hook' call would do if the
+preceding hook functions were the only ones present in HOOK.
+
+Each hook function may call its FUN argument as many times as it wishes,
+including never. In that case, such a hook function acts to replace
+the default definition altogether, and any preceding hook functions.
+Of course, a subsequent hook function may do the same thing.
+
+Each hook function definition is used to construct the FUN passed
+to the next hook function, if any. The last (or \"outermost\")
+FUN is then called once."
(declare (indent 2) (debug (form sexp body)))
;; We need those two gensyms because CL's lexical scoping is not available
;; for function arguments :-(
;; Once there are no more functions on the hook, run
;; the original body.
(apply (lambda ,args ,@body) ,argssym)))))
- (funcall ,runrestofhook ,var
+ (funcall ,runrestofhook ,hook
;; The global part of the hook, if any.
- ,(if (symbolp var)
- `(if (local-variable-p ',var)
- (default-value ',var)))
+ ,(if (symbolp hook)
+ `(if (local-variable-p ',hook)
+ (default-value ',hook)))
(list ,@args)))))
(defun add-to-list (list-var element &optional append compare-fn)
(make-variable-buffer-local 'delayed-mode-hooks)
(put 'delay-mode-hooks 'permanent-local t)
+(defvar change-major-mode-after-body-hook nil
+ "Normal hook run in major mode functions, before the mode hooks.")
+
(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 the variable `delay-mode-hooks' is non-nil.
-Otherwise, runs the mode hooks and then `after-change-major-mode-hook'.
-Major mode functions should use this instead of `run-hooks' when running their
-FOO-mode-hook."
+If the variable `delay-mode-hooks' is non-nil, does not run any hooks,
+just adds the HOOKS to the list `delayed-mode-hooks'.
+Otherwise, runs hooks in the sequence: `change-major-mode-after-body-hook',
+`delayed-mode-hooks' (in reverse order), HOOKS, and finally
+`after-change-major-mode-hook'. Major mode functions should use
+this instead of `run-hooks' when running their FOO-mode-hook."
(if delay-mode-hooks
;; Delaying case.
(dolist (hook hooks)
;; 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 (cons 'change-major-mode-after-body-hook hooks))
(run-hooks 'after-change-major-mode-hook)))
(defmacro delay-mode-hooks (&rest body)
Alternatively, FILE can be a feature (i.e. a symbol), in which case FORM
is evaluated at the end of any file that `provide's this feature.
+If the feature is provided when evaluating code not associated with a
+file, FORM is evaluated immediately after the provide statement.
Usually FILE is just a library name like \"font-lock\" or a feature name
like 'font-lock.
(push elt after-load-alist))
;; Make sure `form' is evalled in the current lexical/dynamic code.
(setq form `(funcall ',(eval `(lambda () ,form) lexical-binding)))
- (when (symbolp regexp-or-feature)
- ;; For features, the after-load-alist elements get run when `provide' is
- ;; called rather than at the end of the file. So add an indirection to
- ;; make sure that `form' is really run "after-load" in case the provide
- ;; call happens early.
- (setq form
- `(when load-file-name
- (let ((fun (make-symbol "eval-after-load-helper")))
- (fset fun `(lambda (file)
- (if (not (equal file ',load-file-name))
- nil
- (remove-hook 'after-load-functions ',fun)
- ,',form)))
- (add-hook 'after-load-functions fun)))))
- ;; Add FORM to the element unless it's already there.
- (unless (member form (cdr elt))
- (nconc elt (purecopy (list form))))
-
;; Is there an already loaded file whose name (or `provide' name)
;; matches FILE?
- (if (if (stringp file)
- (load-history-filename-element regexp-or-feature)
- (featurep file))
- (eval form))))
+ (prog1 (if (if (stringp file)
+ (load-history-filename-element regexp-or-feature)
+ (featurep file))
+ (eval form))
+ (when (symbolp regexp-or-feature)
+ ;; For features, the after-load-alist elements get run when `provide' is
+ ;; called rather than at the end of the file. So add an indirection to
+ ;; make sure that `form' is really run "after-load" in case the provide
+ ;; call happens early.
+ (setq form
+ `(if load-file-name
+ (let ((fun (make-symbol "eval-after-load-helper")))
+ (fset fun `(lambda (file)
+ (if (not (equal file ',load-file-name))
+ nil
+ (remove-hook 'after-load-functions ',fun)
+ ,',form)))
+ (add-hook 'after-load-functions fun))
+ ;; Not being provided from a file, run form right now.
+ ,form)))
+ ;; Add FORM to the element unless it's already there.
+ (unless (member form (cdr elt))
+ (nconc elt (purecopy (list form)))))))
(defvar after-load-functions nil
"Special hook run after loading a file.
(defun display-delayed-warnings ()
"Display delayed warnings from `delayed-warnings-list'.
-This is the default value of `delayed-warnings-hook'."
+Used from `delayed-warnings-hook' (which see)."
(dolist (warning (nreverse delayed-warnings-list))
(apply 'display-warning warning))
(setq delayed-warnings-list nil))
-(defvar delayed-warnings-hook '(display-delayed-warnings)
- "Normal hook run to process delayed warnings.
-Functions in this hook should access the `delayed-warnings-list'
-variable (which see) and remove from it the warnings they process.")
+(defun collapse-delayed-warnings ()
+ "Remove duplicates from `delayed-warnings-list'.
+Collapse identical adjacent warnings into one (plus count).
+Used from `delayed-warnings-hook' (which see)."
+ (let ((count 1)
+ collapsed warning)
+ (while delayed-warnings-list
+ (setq warning (pop delayed-warnings-list))
+ (if (equal warning (car delayed-warnings-list))
+ (setq count (1+ count))
+ (when (> count 1)
+ (setcdr warning (cons (format "%s [%d times]" (cadr warning) count)
+ (cddr warning)))
+ (setq count 1))
+ (push warning collapsed)))
+ (setq delayed-warnings-list (nreverse collapsed))))
+
+;; At present this is only used for Emacs internals.
+;; Ref http://lists.gnu.org/archive/html/emacs-devel/2012-02/msg00085.html
+(defvar delayed-warnings-hook '(collapse-delayed-warnings
+ display-delayed-warnings)
+ "Normal hook run to process and display delayed warnings.
+By default, this hook contains functions to consolidate the
+warnings listed in `delayed-warnings-list', display them, and set
+`delayed-warnings-list' back to nil.")
\f
;;;; Process stuff.
;; where all the keys were unbound (i.e. it somehow got triggered
;; within read-key, apparently). I had to kill it.
(let ((answer 'recenter))
- (if (and (display-popup-menus-p)
- (listp last-nonmenu-event)
- use-dialog-box)
- (setq answer
- (x-popup-dialog t `(,prompt ("Yes" . act) ("No" . skip))))
+ (cond
+ (noninteractive
+ (setq prompt (concat prompt
+ (if (eq ?\s (aref prompt (1- (length prompt))))
+ "" " ")
+ "(y or n) "))
+ (let ((temp-prompt prompt))
+ (while (not (memq answer '(act skip)))
+ (let ((str (read-string temp-prompt)))
+ (cond ((member str '("y" "Y")) (setq answer 'act))
+ ((member str '("n" "N")) (setq answer 'skip))
+ (t (setq temp-prompt (concat "Please answer y or n. "
+ prompt))))))))
+ ((and (display-popup-menus-p)
+ (listp last-nonmenu-event)
+ use-dialog-box)
+ (setq answer
+ (x-popup-dialog t `(,prompt ("Yes" . act) ("No" . skip)))))
+ (t
(setq prompt (concat prompt
(if (eq ?\s (aref prompt (1- (length prompt))))
"" " ")
((memq answer '(exit-prefix quit)) (signal 'quit nil) t)
(t t)))
(ding)
- (discard-input)))
+ (discard-input))))
(let ((ret (eq answer 'act)))
(unless noninteractive
(message "%s %s" prompt (if ret "y" "n")))
"Execute the forms in BODY with FRAME as the selected frame.
The value returned is the value of the last form in BODY.
-This macro neither changes the order of recently selected windows
-nor the buffer list."
+This macro saves and restores the selected frame, and changes the
+order of neither the recently selected windows nor the buffers in
+the buffer list."
(declare (indent 1) (debug t))
(let ((old-frame (make-symbol "old-frame"))
(old-buffer (make-symbol "old-buffer")))
(set-buffer ,old-buffer))))))
(defmacro save-window-excursion (&rest body)
- "Execute BODY, preserving window sizes and contents.
-Return the value of the last form in BODY.
-Restore which buffer appears in which window, where display starts,
-and the value of point and mark for each window.
-Also restore the choice of selected window.
-Also restore which buffer is current.
-Does not restore the value of point in current buffer.
+ "Execute BODY, then restore previous window configuration.
+This macro saves the window configuration on the selected frame,
+executes BODY, then calls `set-window-configuration' to restore
+the saved window configuration. The return value is the last
+form in BODY. The window configuration is also restored if BODY
+exits nonlocally.
BEWARE: Most uses of this macro introduce bugs.
E.g. it should not be used to try and prevent some code from opening
(or (input-pending-p)
(progn ,@body)))))))
-(defmacro condition-case-no-debug (var bodyform &rest handlers)
+(defmacro condition-case-unless-debug (var bodyform &rest handlers)
"Like `condition-case' except that it does not catch anything when debugging.
More specifically if `debug-on-error' is set, then it does not catch any signal."
(declare (debug condition-case) (indent 2))
(funcall ,bodysym)
,@handlers)))))
+(define-obsolete-function-alias 'condition-case-no-debug
+ 'condition-case-unless-debug "24.1")
+
(defmacro with-demoted-errors (&rest body)
"Run BODY and demote any errors to simple messages.
If `debug-on-error' is non-nil, run BODY without catching its errors.
but which should be robust in the unexpected case that an error is signaled."
(declare (debug t) (indent 0))
(let ((err (make-symbol "err")))
- `(condition-case-no-debug ,err
+ `(condition-case-unless-debug ,err
(progn ,@body)
(error (message "Error: %S" ,err) nil))))
;; MIN-CHANGE
;; MIN-TIME])
;;
-;; This weirdeness is for optimization reasons: we want
+;; This weirdness is for optimization reasons: we want
;; `progress-reporter-update' to be as fast as possible, so
;; `(car reporter)' is better than `(aref reporter 0)'.
;;
HCoop / bpt / emacs.git / blobdiff