diff options
Diffstat (limited to 'lisp/subr.el')
| -rw-r--r-- | lisp/subr.el | 262 |
1 files changed, 237 insertions, 25 deletions
diff --git a/lisp/subr.el b/lisp/subr.el index 43660d74377..b66ff288b7a 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -22,20 +22,18 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. -;;; Commentary: - -;;; Code: - ;; Beware: while this file has tag `utf-8', before it's compiled, it gets ;; loaded as "raw-text", so non-ASCII chars won't work right during bootstrap. -(defmacro declare-function (_fn _file &optional _arglist _fileonly) + +;; declare-function's args use &rest, not &optional, for compatibility +;; with byte-compile-macroexpand-declare-function. + +(defmacro declare-function (_fn _file &rest _args) "Tell the byte-compiler that function FN is defined, in FILE. -Optional ARGLIST is the argument list used by the function. The FILE argument is not used by the byte-compiler, but by the `check-declare' package, which checks that FILE contains a -definition for FN. ARGLIST is used by both the byte-compiler -and `check-declare' to check for consistency. +definition for FN. FILE can be either a Lisp file (in which case the \".el\" extension is optional), or a C file. C files are expanded @@ -46,19 +44,22 @@ declaration. A FILE with an \"ext:\" prefix is an external file. `check-declare' will check such files if they are found, and skip them without error if they are not. -FILEONLY non-nil means that `check-declare' will only check that -FILE exists, not that it defines FN. This is intended for -function-definitions that `check-declare' does not recognize, e.g. -`defstruct'. +Optional ARGLIST specifies FN's arguments, or is t to not specify +FN's arguments. An omitted ARGLIST defaults to t, not nil: a nil +ARGLIST specifies an empty argument list, and an explicit t +ARGLIST is a placeholder that allows supplying a later arg. -To specify a value for FILEONLY without passing an argument list, -set ARGLIST to t. This is necessary because nil means an -empty argument list, rather than an unspecified one. +Optional FILEONLY non-nil means that `check-declare' will check +only that FILE exists, not that it defines FN. This is intended +for function definitions that `check-declare' does not recognize, +e.g., `defstruct'. Note that for the purposes of `check-declare', this statement must be the first non-whitespace on a line. For more information, see Info node `(elisp)Declaring Functions'." + (declare (advertised-calling-convention + (fn file &optional arglist fileonly) nil)) ;; Does nothing - byte-compile-declare-function does the work. nil) @@ -66,6 +67,7 @@ For more information, see Info node `(elisp)Declaring Functions'." ;;;; Basic Lisp macros. (defalias 'not 'null) +(defalias 'sxhash 'sxhash-equal) (defmacro noreturn (form) "Evaluate FORM, expecting it not to return. @@ -857,7 +859,12 @@ above 127 (such as ISO Latin-1) can be included if you use a vector. Note that if KEY has a local binding in the current buffer, that local binding will continue to shadow any global binding that you make with this function." - (interactive "KSet key globally: \nCSet key %s to command: ") + (interactive + (let* ((menu-prompting nil) + (key (read-key-sequence "Set key globally: "))) + (list key + (read-command (format "Set key %s to command: " + (key-description key)))))) (or (vectorp key) (stringp key) (signal 'wrong-type-argument (list 'arrayp key))) (define-key (current-global-map) key command)) @@ -1543,6 +1550,10 @@ FUN is then called once." (declare (indent 2) (debug (form sexp body)) (obsolete "use a <foo>-function variable modified by `add-function'." "24.4")) + `(subr--with-wrapper-hook-no-warnings ,hook ,args ,@body)) + +(defmacro subr--with-wrapper-hook-no-warnings (hook args &rest body) + "Like (with-wrapper-hook HOOK ARGS BODY), but without warnings." ;; We need those two gensyms because CL's lexical scoping is not available ;; for function arguments :-( (let ((funs (make-symbol "funs")) @@ -1733,6 +1744,11 @@ if it is empty or a duplicate." (make-variable-buffer-local 'delayed-mode-hooks) (put 'delay-mode-hooks 'permanent-local t) +(defvar delayed-after-hook-forms nil + "List of delayed :after-hook forms waiting to be run. +These forms come from `define-derived-mode'.") +(make-variable-buffer-local 'delayed-after-hook-forms) + (defvar change-major-mode-after-body-hook nil "Normal hook run in major mode functions, before the mode hooks.") @@ -1741,12 +1757,19 @@ if it is empty or a duplicate." (defun run-mode-hooks (&rest hooks) "Run mode hooks `delayed-mode-hooks' and HOOKS, or delay HOOKS. -If the variable `delay-mode-hooks' is non-nil, does not run any hooks, +Call `hack-local-variables' to set up file local and directory local +variables. + +If the variable `delay-mode-hooks' is non-nil, does not do anything, 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." +`delayed-mode-hooks' (in reverse order), HOOKS, then runs +`hack-local-variables', runs the hook `after-change-major-mode-hook', and +finally evaluates the forms in `delayed-after-hook-forms' (see +`define-derived-mode'). + +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) @@ -1755,7 +1778,13 @@ this instead of `run-hooks' when running their FOO-mode-hook." (setq hooks (nconc (nreverse delayed-mode-hooks) hooks)) (setq delayed-mode-hooks nil) (apply 'run-hooks (cons 'change-major-mode-after-body-hook hooks)) - (run-hooks 'after-change-major-mode-hook))) + (if (buffer-file-name) + (with-demoted-errors "File local-variables error: %s" + (hack-local-variables 'no-mode))) + (run-hooks 'after-change-major-mode-hook) + (dolist (form (nreverse delayed-after-hook-forms)) + (eval form)) + (setq delayed-after-hook-forms nil))) (defmacro delay-mode-hooks (&rest body) "Execute BODY, but delay any `run-mode-hooks'. @@ -2251,6 +2280,171 @@ keyboard-quit events while waiting for a valid input." (message "%s%s" prompt (char-to-string char)) char)) +(defun read-multiple-choice (prompt choices) + "Ask user a multiple choice question. +PROMPT should be a string that will be displayed as the prompt. + +CHOICES is an alist where the first element in each entry is a +character to be entered, the second element is a short name for +the entry to be displayed while prompting (if there's room, it +might be shortened), and the third, optional entry is a longer +explanation that will be displayed in a help buffer if the user +requests more help. + +This function translates user input into responses by consulting +the bindings in `query-replace-map'; see the documentation of +that variable for more information. In this case, the useful +bindings are `recenter', `scroll-up', and `scroll-down'. If the +user enters `recenter', `scroll-up', or `scroll-down' responses, +perform the requested window recentering or scrolling and ask +again. + +The return value is the matching entry from the CHOICES list. + +Usage example: + +\(read-multiple-choice \"Continue connecting?\" + '((?a \"always\") + (?s \"session only\") + (?n \"no\")))" + (let* ((altered-names nil) + (full-prompt + (format + "%s (%s): " + prompt + (mapconcat + (lambda (elem) + (let* ((name (cadr elem)) + (pos (seq-position name (car elem))) + (altered-name + (cond + ;; Not in the name string. + ((not pos) + (format "[%c] %s" (car elem) name)) + ;; The prompt character is in the name, so highlight + ;; it on graphical terminals... + ((display-supports-face-attributes-p + '(:underline t) (window-frame)) + (setq name (copy-sequence name)) + (put-text-property pos (1+ pos) + 'face 'read-multiple-choice-face + name) + name) + ;; And put it in [bracket] on non-graphical terminals. + (t + (concat + (substring name 0 pos) + "[" + (upcase (substring name pos (1+ pos))) + "]" + (substring name (1+ pos))))))) + (push (cons (car elem) altered-name) + altered-names) + altered-name)) + (append choices '((?? "?"))) + ", "))) + tchar buf wrong-char answer) + (save-window-excursion + (save-excursion + (while (not tchar) + (message "%s%s" + (if wrong-char + "Invalid choice. " + "") + full-prompt) + (setq tchar + (if (and (display-popup-menus-p) + last-input-event ; not during startup + (listp last-nonmenu-event) + use-dialog-box) + (x-popup-dialog + t + (cons prompt + (mapcar + (lambda (elem) + (cons (capitalize (cadr elem)) + (car elem))) + choices))) + (condition-case nil + (let ((cursor-in-echo-area t)) + (read-char)) + (error nil)))) + (setq answer (lookup-key query-replace-map (vector tchar) t)) + (setq tchar + (cond + ((eq answer 'recenter) + (recenter) t) + ((eq answer 'scroll-up) + (ignore-errors (scroll-up-command)) t) + ((eq answer 'scroll-down) + (ignore-errors (scroll-down-command)) t) + ((eq answer 'scroll-other-window) + (ignore-errors (scroll-other-window)) t) + ((eq answer 'scroll-other-window-down) + (ignore-errors (scroll-other-window-down)) t) + (t tchar))) + (when (eq tchar t) + (setq wrong-char nil + tchar nil)) + ;; The user has entered an invalid choice, so display the + ;; help messages. + (when (and (not (eq tchar nil)) + (not (assq tchar choices))) + (setq wrong-char (not (memq tchar '(?? ?\C-h))) + tchar nil) + (when wrong-char + (ding)) + (with-help-window (setq buf (get-buffer-create + "*Multiple Choice Help*")) + (with-current-buffer buf + (erase-buffer) + (pop-to-buffer buf) + (insert prompt "\n\n") + (let* ((columns (/ (window-width) 25)) + (fill-column 21) + (times 0) + (start (point))) + (dolist (elem choices) + (goto-char start) + (unless (zerop times) + (if (zerop (mod times columns)) + ;; Go to the next "line". + (goto-char (setq start (point-max))) + ;; Add padding. + (while (not (eobp)) + (end-of-line) + (insert (make-string (max (- (* (mod times columns) + (+ fill-column 4)) + (current-column)) + 0) + ?\s)) + (forward-line 1)))) + (setq times (1+ times)) + (let ((text + (with-temp-buffer + (insert (format + "%c: %s\n" + (car elem) + (cdr (assq (car elem) altered-names)))) + (fill-region (point-min) (point-max)) + (when (nth 2 elem) + (let ((start (point))) + (insert (nth 2 elem)) + (unless (bolp) + (insert "\n")) + (fill-region start (point-max)))) + (buffer-string)))) + (goto-char start) + (dolist (line (split-string text "\n")) + (end-of-line) + (if (bolp) + (insert line "\n") + (insert line)) + (forward-line 1))))))))))) + (when (buffer-live-p buf) + (kill-buffer buf)) + (assq tchar choices))) + (defun sit-for (seconds &optional nodisp obsolete) "Redisplay, then wait for SECONDS seconds. Stop when input is available. SECONDS may be a floating-point value. @@ -4134,8 +4328,7 @@ and the function returns nil. Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. This function is like `forward-word', but it is not affected -by `find-word-boundary-function-table' (as set up by -e.g. `subword-mode'). It is also not interactive." +by `find-word-boundary-function-table'. It is also not interactive." (let ((find-word-boundary-function-table (if (char-table-p word-move-empty-char-table) word-move-empty-char-table @@ -4148,8 +4341,7 @@ With argument ARG, do this that many times. If ARG is omitted or nil, move point backward one word. This function is like `forward-word', but it is not affected -by `find-word-boundary-function-table' (as set up by -e.g. `subword-mode'). It is also not interactive." +by `find-word-boundary-function-table'. It is also not interactive." (let ((find-word-boundary-function-table (if (char-table-p word-move-empty-char-table) word-move-empty-char-table @@ -4962,6 +5154,26 @@ as a list.") ;;; Misc. + +(defvar definition-prefixes (make-hash-table :test 'equal) + "Hash table mapping prefixes to the files in which they're used. +This can be used to automatically fetch not-yet-loaded definitions. +More specifically, if there is a value of the form (FILES...) for a string PREFIX +it means that the FILES define variables or functions with names that start +with PREFIX. + +Note that it does not imply that all definitions starting with PREFIX can +be found in those files. E.g. if prefix is \"gnus-article-\" there might +still be definitions of the form \"gnus-article-toto-titi\" in other files, which would +presumably appear in this table under another prefix such as \"gnus-\" +or \"gnus-article-toto-\".") + +(defun register-definition-prefixes (file prefixes) + "Register that FILE uses PREFIXES." + (dolist (prefix prefixes) + (puthash prefix (cons file (gethash prefix definition-prefixes)) + definition-prefixes))) + (defconst menu-bar-separator '("--") "Separator for menus.") |