diff options
Diffstat (limited to 'lisp/subr.el')
| -rw-r--r-- | lisp/subr.el | 306 |
1 files changed, 194 insertions, 112 deletions
diff --git a/lisp/subr.el b/lisp/subr.el index efea412af0e..89ceb9ba55f 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. @@ -512,7 +514,8 @@ argument VECP, this copies vectors as well as conses." (setq newcar (copy-tree (car tree) vecp))) (push newcar result)) (setq tree (cdr tree))) - (nconc (nreverse result) tree)) + (nconc (nreverse result) + (if (and vecp (vectorp tree)) (copy-tree tree vecp) tree))) (if (and vecp (vectorp tree)) (let ((i (length (setq tree (copy-sequence tree))))) (while (>= (setq i (1- i)) 0) @@ -859,7 +862,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)) @@ -1283,27 +1291,14 @@ be a list of the form returned by `event-start' and `event-end'." ;;;; Obsolescent names for functions. -(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 'forward-point "use (+ (point) N) instead." "23.1") (make-obsolete 'buffer-has-markers-at nil "24.3") -(defun insert-string (&rest args) - "Mocklisp-compatibility insert function. -Like the function `insert' except that any argument that is a number -is converted into a string by expressing it in decimal." - (declare (obsolete insert "22.1")) - (dolist (el args) - (insert (if (integerp el) (number-to-string el) el)))) - -(defun makehash (&optional test) - (declare (obsolete make-hash-table "22.1")) - (make-hash-table :test (or test 'eql))) +;; bug#23850 +(make-obsolete 'string-to-unibyte "use `encode-coding-string'." "26.1") +(make-obsolete 'string-as-unibyte "use `encode-coding-string'." "26.1") +(make-obsolete 'string-to-multibyte "use `decode-coding-string'." "26.1") +(make-obsolete 'string-as-multibyte "use `decode-coding-string'." "26.1") (defun log10 (x) "Return (log X 10), the log base 10 of X." @@ -1315,57 +1310,15 @@ is converted into a string by expressing it in decimal." (make-obsolete 'focus-frame "it does nothing." "22.1") (defalias 'unfocus-frame 'ignore "") (make-obsolete 'unfocus-frame "it does nothing." "22.1") -(make-obsolete 'make-variable-frame-local - "explicitly check for a frame-parameter instead." "22.2") + (set-advertised-calling-convention 'all-completions '(string collection &optional predicate) "23.1") (set-advertised-calling-convention 'unintern '(name obarray) "23.3") (set-advertised-calling-convention 'indirect-function '(object) "25.1") (set-advertised-calling-convention 'redirect-frame-focus '(frame focus-frame) "24.3") -(set-advertised-calling-convention 'decode-char '(ch charset) "21.4") -(set-advertised-calling-convention 'encode-char '(ch charset) "21.4") ;;;; Obsolescence declarations for variables, and aliases. -;; Special "default-FOO" variables which contain the default value of -;; the "FOO" variable are nasty. Their implementation is brittle, and -;; slows down several unrelated variable operations; furthermore, they -;; can lead to really odd behavior if you decide to make them -;; buffer-local. - -;; Not used at all in Emacs, last time I checked: -(make-obsolete-variable 'default-mode-line-format - "use (setq-default mode-line-format) or (default-value mode-line-format) instead" - "23.2") -(make-obsolete-variable 'default-header-line-format 'header-line-format "23.2") -(make-obsolete-variable 'default-line-spacing 'line-spacing "23.2") -(make-obsolete-variable 'default-abbrev-mode 'abbrev-mode "23.2") -(make-obsolete-variable 'default-ctl-arrow 'ctl-arrow "23.2") -(make-obsolete-variable 'default-truncate-lines 'truncate-lines "23.2") -(make-obsolete-variable 'default-left-margin 'left-margin "23.2") -(make-obsolete-variable 'default-tab-width 'tab-width "23.2") -(make-obsolete-variable 'default-case-fold-search 'case-fold-search "23.2") -(make-obsolete-variable 'default-left-margin-width 'left-margin-width "23.2") -(make-obsolete-variable 'default-right-margin-width 'right-margin-width "23.2") -(make-obsolete-variable 'default-left-fringe-width 'left-fringe-width "23.2") -(make-obsolete-variable 'default-right-fringe-width 'right-fringe-width "23.2") -(make-obsolete-variable 'default-fringes-outside-margins 'fringes-outside-margins "23.2") -(make-obsolete-variable 'default-scroll-bar-width 'scroll-bar-width "23.2") -(make-obsolete-variable 'default-vertical-scroll-bar 'vertical-scroll-bar "23.2") -(make-obsolete-variable 'default-indicate-empty-lines 'indicate-empty-lines "23.2") -(make-obsolete-variable 'default-indicate-buffer-boundaries 'indicate-buffer-boundaries "23.2") -(make-obsolete-variable 'default-fringe-indicator-alist 'fringe-indicator-alist "23.2") -(make-obsolete-variable 'default-fringe-cursor-alist 'fringe-cursor-alist "23.2") -(make-obsolete-variable 'default-scroll-up-aggressively 'scroll-up-aggressively "23.2") -(make-obsolete-variable 'default-scroll-down-aggressively 'scroll-down-aggressively "23.2") -(make-obsolete-variable 'default-fill-column 'fill-column "23.2") -(make-obsolete-variable 'default-cursor-type 'cursor-type "23.2") -(make-obsolete-variable 'default-cursor-in-non-selected-windows 'cursor-in-non-selected-windows "23.2") -(make-obsolete-variable 'default-buffer-file-coding-system 'buffer-file-coding-system "23.2") -(make-obsolete-variable 'default-major-mode 'major-mode "23.2") -(make-obsolete-variable 'default-enable-multibyte-characters - "use enable-multibyte-characters or set-buffer-multibyte instead" "23.2") - (make-obsolete-variable 'define-key-rebound-commands nil "23.2") (make-obsolete-variable 'redisplay-end-trigger-functions 'jit-lock-register "23.1") (make-obsolete-variable 'deferred-action-list 'post-command-hook "24.1") @@ -1548,6 +1501,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")) @@ -1623,7 +1580,7 @@ can do the job." ;; FIXME: We should also emit a warning for let-bound ;; variables with dynamic binding. (when (assq sym byte-compile--lexical-environment) - (byte-compile-log-warning msg t :error)))) + (byte-compile-report-error msg :fill)))) (code (macroexp-let2 macroexp-copyable-p x element `(if ,(if compare-fn @@ -1738,6 +1695,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.") @@ -1746,12 +1708,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) @@ -1760,7 +1729,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'. @@ -1903,7 +1878,7 @@ definition, variable definition, or face definition only." (autoloadp (symbol-function symbol))) (nth 1 (symbol-function symbol)) (let ((files load-history) - file) + file match) (while files (if (if type (if (eq type 'defvar) @@ -1914,7 +1889,8 @@ definition, variable definition, or face definition only." ;; 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))))) + (and (setq match (rassq symbol (cdr (car files)))) + (not (eq 'require (car match)))))) (setq file (car (car files)) files nil)) (setq files (cdr files))) file))) @@ -2505,26 +2481,27 @@ This finishes the change group by reverting all of its changes." ;; Widen buffer temporarily so if the buffer was narrowed within ;; the body of `atomic-change-group' all changes can be undone. (widen) - (let ((old-car - (if (consp elt) (car elt))) - (old-cdr - (if (consp elt) (cdr elt)))) - ;; Temporarily truncate the undo log at ELT. - (when (consp elt) - (setcar elt nil) (setcdr elt nil)) - (unless (eq last-command 'undo) (undo-start)) - ;; Make sure there's no confusion. - (when (and (consp elt) (not (eq elt (last pending-undo-list)))) - (error "Undoing to some unrelated state")) - ;; Undo it all. - (save-excursion - (while (listp pending-undo-list) (undo-more 1))) - ;; Reset the modified cons cell ELT to its original content. - (when (consp elt) - (setcar elt old-car) - (setcdr elt old-cdr)) - ;; Revert the undo info to what it was when we grabbed the state. - (setq buffer-undo-list elt)))))) + (let ((old-car (car-safe elt)) + (old-cdr (cdr-safe elt))) + (unwind-protect + (progn + ;; Temporarily truncate the undo log at ELT. + (when (consp elt) + (setcar elt nil) (setcdr elt nil)) + (unless (eq last-command 'undo) (undo-start)) + ;; Make sure there's no confusion. + (when (and (consp elt) (not (eq elt (last pending-undo-list)))) + (error "Undoing to some unrelated state")) + ;; Undo it all. + (save-excursion + (while (listp pending-undo-list) (undo-more 1))) + ;; Revert the undo info to what it was when we grabbed + ;; the state. + (setq buffer-undo-list elt)) + ;; Reset the modified cons cell ELT to its original content. + (when (consp elt) + (setcar elt old-car) + (setcdr elt old-cdr)))))))) ;;;; Display-related functions. @@ -3025,6 +3002,28 @@ Similar to `call-process-shell-command', but calls `process-file'." infile buffer display (if (file-remote-p default-directory) "-c" shell-command-switch) (mapconcat 'identity (cons command args) " "))) + +(defun call-shell-region (start end command &optional delete buffer) + "Send text from START to END as input to an inferior shell running COMMAND. +Delete the text if fourth arg DELETE is non-nil. + +Insert output in BUFFER before point; t means current buffer; nil for + BUFFER means discard it; 0 means discard and don't wait; and `(:file + FILE)', where FILE is a file name string, means that it should be + written to that file (if the file already exists it is overwritten). +BUFFER can also have the form (REAL-BUFFER STDERR-FILE); in that case, +REAL-BUFFER says what to do with standard output, as above, +while STDERR-FILE says what to do with standard error in the child. +STDERR-FILE may be nil (discard standard error output), +t (mix it with ordinary output), or a file name string. + +If BUFFER is 0, `call-shell-region' returns immediately with value nil. +Otherwise it waits for COMMAND to terminate +and returns a numeric exit status or a signal description string. +If you quit, the process is killed with SIGINT, or SIGKILL if you quit again." + (call-process-region start end + shell-file-name delete buffer nil + shell-command-switch command)) ;;;; Lisp macros to do various things temporarily. @@ -3336,6 +3335,11 @@ is allowed once again. (Immediately, if `inhibit-quit' is nil.)" ;; that intends to handle the quit signal next time. (eval '(ignore nil))))) +;; Don't throw `throw-on-input' on those events by default. +(setq while-no-input-ignore-events + '(focus-in focus-out help-echo iconify-frame + make-frame-visible selection-request)) + (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, @@ -3983,7 +3987,7 @@ This function is called directly from the C code." (expand-file-name byte-compile-current-file byte-compile-root-dir))) - (byte-compile-log-warning msg)) + (byte-compile-warn "%s" msg)) (run-with-timer 0 nil (lambda (msg) (message "%s" msg)) @@ -4120,8 +4124,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 @@ -4134,8 +4137,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 @@ -4331,6 +4333,51 @@ The properties used on SYMBOL are `composefunc', `sendfunc', (put symbol 'sendfunc sendfunc) (put symbol 'abortfunc (or abortfunc 'kill-buffer)) (put symbol 'hookvar (or hookvar 'mail-send-hook))) + + +(defun backtrace--print-frame (evald func args flags) + "Print a trace of a single stack frame to `standard-output'. +EVALD, FUNC, ARGS, FLAGS are as in `mapbacktrace'." + (princ (if (plist-get flags :debug-on-exit) "* " " ")) + (cond + ((and evald (not debugger-stack-frame-as-list)) + (prin1 func) + (if args (prin1 args) (princ "()"))) + (t + (prin1 (cons func args)))) + (princ "\n")) + +(defun backtrace () + "Print a trace of Lisp function calls currently active. +Output stream used is value of `standard-output'." + (let ((print-level (or print-level 8))) + (mapbacktrace #'backtrace--print-frame 'backtrace))) + +(defun backtrace-frames (&optional base) + "Collect all frames of current backtrace into a list. +If non-nil, BASE should be a function, and frames before its +nearest activation frames are discarded." + (let ((frames nil)) + (mapbacktrace (lambda (&rest frame) (push frame frames)) + (or base 'backtrace-frames)) + (nreverse frames))) + +(defun backtrace-frame (nframes &optional base) + "Return the function and arguments NFRAMES up from current execution point. +If non-nil, BASE should be a function, and NFRAMES counts from its +nearest activation frame. +If the frame has not evaluated the arguments yet (or is a special form), +the value is (nil FUNCTION ARG-FORMS...). +If the frame has evaluated its arguments and called its function already, +the value is (t FUNCTION ARG-VALUES...). +A &rest arg is represented as the tail of the list ARG-VALUES. +FUNCTION is whatever was supplied as car of evaluated list, +or a lambda expression for macro calls. +If NFRAMES is more than the number of frames, the value is nil." + (backtrace-frame--internal + (lambda (evald func args _) `(,evald ,func ,@args)) + nframes (or base 'backtrace-frame))) + (defvar called-interactively-p-functions nil "Special hook called to skip special frames in `called-interactively-p'. @@ -4494,7 +4541,8 @@ to deactivate this transient map, regardless of KEEP-PRED." (with-demoted-errors "set-transient-map PCH: %S" (unless (cond ((null keep-pred) nil) - ((not (eq map (cadr overriding-terminal-local-map))) + ((and (not (eq map (cadr overriding-terminal-local-map))) + (memq map (cddr overriding-terminal-local-map))) ;; There's presumably some other transient-map in ;; effect. Wait for that one to terminate before we ;; remove ourselves. @@ -4949,7 +4997,41 @@ as a list.") "-pkg.el")) +;;; Thread support. + +(defmacro with-mutex (mutex &rest body) + "Invoke BODY with MUTEX held, releasing MUTEX when done. +This is the simplest safe way to acquire and release a mutex." + (declare (indent 1) (debug t)) + (let ((sym (make-symbol "mutex"))) + `(let ((,sym ,mutex)) + (mutex-lock ,sym) + (unwind-protect + (progn ,@body) + (mutex-unlock ,sym))))) + + ;;; 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.") |