diff options
Diffstat (limited to 'lisp/subr.el')
| -rw-r--r-- | lisp/subr.el | 482 |
1 files changed, 330 insertions, 152 deletions
diff --git a/lisp/subr.el b/lisp/subr.el index f0de6d5ac92..0a31ef2b29f 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -31,7 +31,8 @@ "Tell the byte-compiler that function FN is defined, in FILE. 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. +definition for FN. (FILE can be nil, and that disables this +check.) FILE can be either a Lisp file (in which case the \".el\" extension is optional), or a C file. C files are expanded @@ -64,8 +65,8 @@ For more information, see Info node `(elisp)Declaring Functions'." ;;;; Basic Lisp macros. -(defalias 'not 'null) -(defalias 'sxhash 'sxhash-equal) +(defalias 'not #'null) +(defalias 'sxhash #'sxhash-equal) (defmacro noreturn (form) "Evaluate FORM, expecting it not to return. @@ -82,14 +83,27 @@ Testcover will raise an error." form) (defmacro def-edebug-spec (symbol spec) - "Set the `edebug-form-spec' property of SYMBOL according to SPEC. + "Set the Edebug SPEC to use for sexps which have SYMBOL as head. Both SYMBOL and SPEC are unevaluated. The SPEC can be: 0 (instrument no arguments); t (instrument all arguments); a symbol (naming a function with an Edebug specification); or a list. The elements of the list describe the argument types; see Info node `(elisp)Specification List' for details." + (declare (indent 1)) `(put (quote ,symbol) 'edebug-form-spec (quote ,spec))) +(defun def-edebug-elem-spec (name spec) + "Define a new Edebug spec element NAME as shorthand for SPEC. +The SPEC has to be a list." + (declare (indent 1)) + (when (string-match "\\`[&:]" (symbol-name name)) + ;; & and : have special meaning in spec element names. + (error "Edebug spec name cannot start with '&' or ':'")) + (unless (consp spec) + (error "Edebug spec has to be a list: %S" spec)) + (put name 'edebug-elem-spec spec)) + + (defmacro lambda (&rest cdr) "Return an anonymous function. Under dynamic binding, a call of the form (lambda ARGS DOCSTRING @@ -182,6 +196,14 @@ buffer-local wherever it is set." (list 'progn (list 'defvar var val docstring) (list 'make-variable-buffer-local (list 'quote var)))) +(defun buffer-local-boundp (symbol buffer) + "Return non-nil if SYMBOL is bound in BUFFER. +Also see `local-variable-p'." + (condition-case nil + (buffer-local-value symbol buffer) + (:success t) + (void-variable nil))) + (defmacro push (newelt place) "Add NEWELT to the list stored in the generalized variable PLACE. This is morally equivalent to (setf PLACE (cons NEWELT PLACE)), @@ -233,6 +255,11 @@ value of last one, or nil if there are none. (declare (indent 1) (debug t)) (cons 'if (cons cond (cons nil body)))) +(defsubst subr-primitive-p (object) + "Return t if OBJECT is a built-in primitive function." + (and (subrp object) + (not (subr-native-elisp-p object)))) + (defsubst xor (cond1 cond2) "Return the boolean exclusive-or of COND1 and COND2. If only one of the arguments is non-nil, return it; otherwise @@ -360,10 +387,18 @@ PREFIX is a string, and defaults to \"g\"." (defun ignore (&rest _arguments) "Do nothing and return nil. -This function accepts any number of ARGUMENTS, but ignores them." +This function accepts any number of ARGUMENTS, but ignores them. +Also see `always'." + (declare (completion ignore)) (interactive) nil) +(defun always (&rest _arguments) + "Do nothing and return t. +This function accepts any number of ARGUMENTS, but ignores them. +Also see `ignore'." + t) + ;; Signal a compile-error if the first arg is missing. (defun error (&rest args) "Signal an error, making a message by passing ARGS to `format-message'. @@ -772,7 +807,7 @@ If TEST is omitted or nil, `equal' is used." (let (found (tail alist) value) (while (and tail (not found)) (let ((elt (car tail))) - (when (funcall (or test 'equal) (if (consp elt) (car elt) elt) key) + (when (funcall (or test #'equal) (if (consp elt) (car elt) elt) key) (setq found t value (if (consp elt) (cdr elt) default)))) (setq tail (cdr tail))) value)) @@ -866,7 +901,9 @@ Example: (defun remove (elt seq) "Return a copy of SEQ with all occurrences of ELT removed. -SEQ must be a list, vector, or string. The comparison is done with `equal'." +SEQ must be a list, vector, or string. The comparison is done with `equal'. +Contrary to `delete', this does not use side-effects, and the argument +SEQ is not modified." (declare (side-effect-free t)) (if (nlistp seq) ;; If SEQ isn't a list, there's no need to copy SEQ because @@ -902,6 +939,7 @@ For an approximate inverse of this, see `key-description'." (defun undefined () "Beep to tell the user this binding is undefined." + (declare (completion ignore)) (interactive) (ding) (if defining-kbd-macro @@ -922,14 +960,14 @@ For an approximate inverse of this, see `key-description'." "Make MAP override all normally self-inserting keys to be undefined. Normally, as an exception, digits and minus-sign are set to make prefix args, but optional second arg NODIGITS non-nil treats them like other chars." - (define-key map [remap self-insert-command] 'undefined) + (define-key map [remap self-insert-command] #'undefined) (or nodigits (let (loop) - (define-key map "-" 'negative-argument) + (define-key map "-" #'negative-argument) ;; Make plain numbers do numeric args. (setq loop ?0) (while (<= loop ?9) - (define-key map (char-to-string loop) 'digit-argument) + (define-key map (char-to-string loop) #'digit-argument) (setq loop (1+ loop)))))) (defun make-composed-keymap (maps &optional parent) @@ -966,8 +1004,8 @@ a menu, so this function is not useful for non-menu keymaps." (setq key (if (<= (length key) 1) (aref key 0) (setq keymap (lookup-key keymap - (apply 'vector - (butlast (mapcar 'identity key))))) + (apply #'vector + (butlast (mapcar #'identity key))))) (aref key (1- (length key))))) (let ((tail keymap) done inserted) (while (and (not done) tail) @@ -1095,7 +1133,7 @@ Subkeymaps may be modified but are not canonicalized." (push (cons key item) bindings))) map))) ;; Create the new map. - (setq map (funcall (if ranges 'make-keymap 'make-sparse-keymap) prompt)) + (setq map (funcall (if ranges #'make-keymap #'make-sparse-keymap) prompt)) (dolist (binding ranges) ;; Treat char-ranges specially. FIXME: need to merge as well. (define-key map (vector (car binding)) (cdr binding))) @@ -1285,6 +1323,7 @@ in a cleaner way with command remapping, like this: (define-key map "l" #'downcase-word) (define-key map "c" #'capitalize-word) (define-key map "x" #'execute-extended-command) + (define-key map "X" #'execute-extended-command-for-buffer) map) "Default keymap for ESC (meta) commands. The normal global definition of the character ESC indirects to this keymap.") @@ -1655,6 +1694,12 @@ The return value has the form (WIDTH . HEIGHT). POSITION should be a list of the form returned by `event-start' and `event-end'." (nth 9 position)) +(defun values--store-value (value) + "Store VALUE in the obsolete `values' variable." + (with-suppressed-warnings ((obsolete values)) + (push value values)) + value) + ;;;; Obsolescent names for functions. @@ -1721,32 +1766,42 @@ be a list of the form returned by `event-start' and `event-end'." (make-obsolete-variable 'load-dangerous-libraries "no longer used." "27.1") +(defvar inhibit--record-char nil + "Obsolete variable. +This was used internally by quail.el and keyboard.c in Emacs 27. +It does nothing in Emacs 28.") +(make-obsolete-variable 'inhibit--record-char nil "28.1") + +;; We can't actually make `values' obsolete, because that will result +;; in warnings when using `values' in let-bindings. +;;(make-obsolete-variable 'values "no longer used" "28.1") + ;;;; 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 'string> 'string-greaterp) -(defalias 'move-marker 'set-marker) -(defalias 'rplaca 'setcar) -(defalias 'rplacd 'setcdr) -(defalias 'beep 'ding) ;preserve lingual purity -(defalias 'indent-to-column 'indent-to) -(defalias 'backward-delete-char 'delete-backward-char) +(defalias 'send-string #'process-send-string) +(defalias 'send-region #'process-send-region) +(defalias 'string= #'string-equal) +(defalias 'string< #'string-lessp) +(defalias 'string> #'string-greaterp) +(defalias 'move-marker #'set-marker) +(defalias 'rplaca #'setcar) +(defalias 'rplacd #'setcdr) +(defalias 'beep #'ding) ;preserve lingual purity +(defalias 'indent-to-column #'indent-to) +(defalias 'backward-delete-char #'delete-backward-char) (defalias 'search-forward-regexp (symbol-function 're-search-forward)) (defalias 'search-backward-regexp (symbol-function 're-search-backward)) -(defalias 'int-to-string 'number-to-string) -(defalias 'store-match-data 'set-match-data) -(defalias 'chmod 'set-file-modes) -(defalias 'mkdir 'make-directory) +(defalias 'int-to-string #'number-to-string) +(defalias 'store-match-data #'set-match-data) +(defalias 'chmod #'set-file-modes) +(defalias 'mkdir #'make-directory) ;; These are the XEmacs names: -(defalias 'point-at-eol 'line-end-position) -(defalias 'point-at-bol 'line-beginning-position) +(defalias 'point-at-eol #'line-end-position) +(defalias 'point-at-bol #'line-beginning-position) (define-obsolete-function-alias 'user-original-login-name - 'user-login-name "28.1") + #'user-login-name "28.1") ;;;; Hook manipulation functions. @@ -1775,9 +1830,15 @@ This makes the hook buffer-local, and it makes t a member of the buffer-local value. That acts as a flag to run the hook functions of the global value as well as in the local value. -HOOK should be a symbol, and FUNCTION may be any valid function. If -HOOK is void, it is first set to nil. If HOOK's value is a single -function, it is changed to a list of functions." +HOOK should be a symbol. If HOOK is void, it is first set to +nil. If HOOK's value is a single function, it is changed to a +list of functions. + +FUNCTION may be any valid function, but it's recommended to use a +function symbol and not a lambda form. Using a symbol will +ensure that the function is not re-added if the function is +edited, and using lambda forms may also have a negative +performance impact when running `add-hook' and `remove-hook'." (or (boundp hook) (set hook nil)) (or (default-boundp hook) (set-default hook nil)) (unless (numberp depth) (setq depth (if depth 90 0))) @@ -1795,12 +1856,13 @@ function, it is changed to a list of functions." (unless (member function hook-value) (when (stringp function) ;FIXME: Why? (setq function (purecopy function))) + ;; All those `equal' tests performed between functions can end up being + ;; costly since those functions may be large recursive and even cyclic + ;; structures, so we index `hook--depth-alist' with `eq'. (bug#46326) (when (or (get hook 'hook--depth-alist) (not (zerop depth))) ;; Note: The main purpose of the above `when' test is to avoid running ;; this `setf' before `gv' is loaded during bootstrap. - (setf (alist-get function (get hook 'hook--depth-alist) - 0 'remove #'equal) - depth)) + (push (cons function depth) (get hook 'hook--depth-alist))) (setq hook-value (if (< 0 depth) (append hook-value (list function)) @@ -1810,8 +1872,8 @@ function, it is changed to a list of functions." (setq hook-value (sort (if (< 0 depth) hook-value (copy-sequence hook-value)) (lambda (f1 f2) - (< (alist-get f1 depth-alist 0 nil #'equal) - (alist-get f2 depth-alist 0 nil #'equal)))))))) + (< (alist-get f1 depth-alist 0 nil #'eq) + (alist-get f2 depth-alist 0 nil #'eq)))))))) ;; Set the actual variable (if local (progn @@ -1860,7 +1922,7 @@ one will be removed." (if local "Buffer-local" "Global")) fn-alist nil t) - fn-alist nil nil 'string=))) + fn-alist nil nil #'string=))) (list hook function local))) (or (boundp hook) (set hook nil)) (or (default-boundp hook) (set-default hook nil)) @@ -1872,11 +1934,21 @@ one will be removed." (not (and (consp (symbol-value hook)) (memq t (symbol-value hook))))) (setq local t)) - (let ((hook-value (if local (symbol-value hook) (default-value hook)))) + (let ((hook-value (if local (symbol-value hook) (default-value hook))) + (old-fun nil)) ;; Remove the function, for both the list and the non-list cases. (if (or (not (listp hook-value)) (eq (car hook-value) 'lambda)) - (if (equal hook-value function) (setq hook-value nil)) - (setq hook-value (delete function (copy-sequence hook-value)))) + (when (equal hook-value function) + (setq old-fun hook-value) + (setq hook-value nil)) + (when (setq old-fun (car (member function hook-value))) + (setq hook-value (remq old-fun hook-value)))) + (when old-fun + ;; Remove auxiliary depth info to avoid leaks (bug#46414) + ;; and to avoid the list growing too long. + (let* ((depths (get hook 'hook--depth-alist)) + (di (assq old-fun depths))) + (when di (put hook 'hook--depth-alist (delq di depths))))) ;; If the function is on the global hook, we need to shadow it locally ;;(when (and local (member function (default-value hook)) ;; (not (member (cons 'not function) hook-value))) @@ -1929,10 +2001,10 @@ all symbols are bound before any of the VALUEFORMs are evalled." (t `(let* ,(nreverse seqbinds) ,nbody)))))) (defmacro dlet (binders &rest body) - "Like `let*' but using dynamic scoping." + "Like `let' but using dynamic scoping." (declare (indent 1) (debug let)) ;; (defvar FOO) only affects the current scope, but in order for - ;; this not to affect code after the `let*' we need to create a new scope, + ;; this not to affect code after the main `let' we need to create a new scope, ;; which is what the surrounding `let' is for. ;; FIXME: (let () ...) currently doesn't actually create a new scope, ;; which is why we use (let (_) ...). @@ -1940,7 +2012,7 @@ all symbols are bound before any of the VALUEFORMs are evalled." ,@(mapcar (lambda (binder) `(defvar ,(if (consp binder) (car binder) binder))) binders) - (let* ,binders ,@body))) + (let ,binders ,@body))) (defmacro with-wrapper-hook (hook args &rest body) @@ -1973,7 +2045,7 @@ FUN is then called once." (defmacro subr--with-wrapper-hook-no-warnings (hook args &rest body) "Like (with-wrapper-hook HOOK ARGS BODY), but without warnings." - (declare (debug (form sexp body))) + (declare (debug (form sexp def-body))) ;; We need those two gensyms because CL's lexical scoping is not available ;; for function arguments :-( (let ((funs (make-symbol "funs")) @@ -2064,7 +2136,7 @@ can do the job." ,(if append `(setq ,sym (append ,sym (list ,x))) `(push ,x ,sym)))))) - (if (not (macroexp--compiling-p)) + (if (not (macroexp-compiling-p)) code `(progn (macroexp--funcall-if-compiled ',warnfun) @@ -2072,9 +2144,9 @@ can do the job." (if (cond ((null compare-fn) (member element (symbol-value list-var))) - ((eq compare-fn 'eq) + ((eq compare-fn #'eq) (memq element (symbol-value list-var))) - ((eq compare-fn 'eql) + ((eq compare-fn #'eql) (memql element (symbol-value list-var))) (t (let ((lst (symbol-value list-var))) @@ -2292,7 +2364,8 @@ tho trying to avoid AVOIDED-MODES." (defun add-minor-mode (toggle name &optional keymap after toggle-fun) "Register a new minor mode. -This is an XEmacs-compatibility function. Use `define-minor-mode' instead. +This function shouldn't be used directly -- use `define-minor-mode' +instead (which will then call this function). TOGGLE is a symbol that is the name of a buffer-local variable that is toggled on or off to say whether the minor mode is active or not. @@ -2412,7 +2485,11 @@ file name without extension. If TYPE is nil, then any kind of definition is acceptable. If TYPE is `defun', `defvar', or `defface', that specifies function definition, variable definition, or face definition only. -Otherwise TYPE is assumed to be a symbol property." +Otherwise TYPE is assumed to be a symbol property. + +This function only works for symbols defined in Lisp files. For +symbols that are defined in C files, use `help-C-file-name' +instead." (if (and (or (null type) (eq type 'defun)) (symbolp symbol) (autoloadp (symbol-function symbol))) @@ -2499,13 +2576,13 @@ use `start-file-process'." (defun process-lines-handling-status (program status-handler &rest args) "Execute PROGRAM with ARGS, returning its output as a list of lines. -If STATUS-HANDLER is non-NIL, it must be a function with one +If STATUS-HANDLER is non-nil, it must be a function with one argument, which will be called with the exit status of the program before the output is collected. If STATUS-HANDLER is -NIL, an error is signalled if the program returns with a non-zero +nil, an error is signaled if the program returns with a non-zero exit status." (with-temp-buffer - (let ((status (apply 'call-process program nil (current-buffer) nil args))) + (let ((status (apply #'call-process program nil (current-buffer) nil args))) (if status-handler (funcall status-handler status) (unless (eq status 0) @@ -2530,7 +2607,7 @@ Also see `process-lines-ignore-status'." "Execute PROGRAM with ARGS, returning its output as a list of lines. The exit status of the program is ignored. Also see `process-lines'." - (apply #'process-lines-handling-status program #'identity args)) + (apply #'process-lines-handling-status program #'ignore args)) (defun process-live-p (process) "Return non-nil if PROCESS is alive. @@ -2551,7 +2628,7 @@ process." (format "Buffer %S has a running process; kill it? " (buffer-name (current-buffer))))))) -(add-hook 'kill-buffer-query-functions 'process-kill-buffer-query-function) +(add-hook 'kill-buffer-query-functions #'process-kill-buffer-query-function) ;; process plist management @@ -2739,7 +2816,7 @@ by doing (clear-string STRING)." (use-local-map read-passwd-map) (setq-local inhibit-modification-hooks nil) ;bug#15501. (setq-local show-paren-mode nil) ;bug#16091. - (add-hook 'post-command-hook 'read-password--hide-password nil t)) + (add-hook 'post-command-hook #'read-password--hide-password nil t)) (unwind-protect (let ((enable-recursive-minibuffers t) (read-hide-char (or read-hide-char ?*))) @@ -2749,8 +2826,8 @@ by doing (clear-string STRING)." ;; Not sure why but it seems that there might be cases where the ;; minibuffer is not always properly reset later on, so undo ;; whatever we've done here (bug#11392). - (remove-hook 'after-change-functions 'read-password--hide-password - 'local) + (remove-hook 'after-change-functions + #'read-password--hide-password 'local) (kill-local-variable 'post-self-insert-hook) ;; And of course, don't keep the sensitive data around. (erase-buffer)))))))) @@ -2770,9 +2847,9 @@ This function is used by the `interactive' code letter `n'." (when default1 (setq prompt (if (string-match "\\(\\):[ \t]*\\'" prompt) - (replace-match (format " (default %s)" default1) t t prompt 1) + (replace-match (format minibuffer-default-prompt-format default1) t t prompt 1) (replace-regexp-in-string "[ \t]*\\'" - (format " (default %s) " default1) + (format minibuffer-default-prompt-format default1) prompt t t)))) (while (progn @@ -2780,7 +2857,7 @@ This function is used by the `interactive' code letter `n'." prompt nil nil nil (or hist 'read-number-history) (when default (if (consp default) - (mapcar 'number-to-string (delq nil default)) + (mapcar #'number-to-string (delq nil default)) (number-to-string default)))))) (condition-case nil (setq n (cond @@ -2798,6 +2875,11 @@ This function is used by the `interactive' code letter `n'." Otherwise, use the minibuffer.") (defun read-char-choice (prompt chars &optional inhibit-keyboard-quit) + (if (not read-char-choice-use-read-key) + (read-char-from-minibuffer prompt chars) + (read-char-choice-with-read-key prompt chars inhibit-keyboard-quit))) + +(defun read-char-choice-with-read-key (prompt chars &optional inhibit-keyboard-quit) "Read and return one of CHARS, prompting for PROMPT. Any input that is not one of CHARS is ignored. @@ -2807,46 +2889,44 @@ keyboard-quit events while waiting for a valid input. If you bind the variable `help-form' to a non-nil value while calling this function, then pressing `help-char' causes it to evaluate `help-form' and display the result." - (if (not read-char-choice-use-read-key) - (read-char-from-minibuffer prompt chars) - (unless (consp chars) - (error "Called `read-char-choice' without valid char choices")) - (let (char done show-help (helpbuf " *Char Help*")) - (let ((cursor-in-echo-area t) - (executing-kbd-macro executing-kbd-macro) - (esc-flag nil)) - (save-window-excursion ; in case we call help-form-show - (while (not done) - (unless (get-text-property 0 'face prompt) - (setq prompt (propertize prompt 'face 'minibuffer-prompt))) - (setq char (let ((inhibit-quit inhibit-keyboard-quit)) - (read-key prompt))) - (and show-help (buffer-live-p (get-buffer helpbuf)) - (kill-buffer helpbuf)) - (cond - ((not (numberp char))) - ;; If caller has set help-form, that's enough. - ;; They don't explicitly have to add help-char to chars. - ((and help-form - (eq char help-char) - (setq show-help t) - (help-form-show))) - ((memq char chars) - (setq done t)) - ((and executing-kbd-macro (= char -1)) - ;; read-event returns -1 if we are in a kbd macro and - ;; there are no more events in the macro. Attempt to - ;; get an event interactively. - (setq executing-kbd-macro nil)) - ((not inhibit-keyboard-quit) - (cond - ((and (null esc-flag) (eq char ?\e)) - (setq esc-flag t)) - ((memq char '(?\C-g ?\e)) - (keyboard-quit)))))))) - ;; Display the question with the answer. But without cursor-in-echo-area. - (message "%s%s" prompt (char-to-string char)) - char))) + (unless (consp chars) + (error "Called `read-char-choice' without valid char choices")) + (let (char done show-help (helpbuf " *Char Help*")) + (let ((cursor-in-echo-area t) + (executing-kbd-macro executing-kbd-macro) + (esc-flag nil)) + (save-window-excursion ; in case we call help-form-show + (while (not done) + (unless (get-text-property 0 'face prompt) + (setq prompt (propertize prompt 'face 'minibuffer-prompt))) + (setq char (let ((inhibit-quit inhibit-keyboard-quit)) + (read-key prompt))) + (and show-help (buffer-live-p (get-buffer helpbuf)) + (kill-buffer helpbuf)) + (cond + ((not (numberp char))) + ;; If caller has set help-form, that's enough. + ;; They don't explicitly have to add help-char to chars. + ((and help-form + (eq char help-char) + (setq show-help t) + (help-form-show))) + ((memq char chars) + (setq done t)) + ((and executing-kbd-macro (= char -1)) + ;; read-event returns -1 if we are in a kbd macro and + ;; there are no more events in the macro. Attempt to + ;; get an event interactively. + (setq executing-kbd-macro nil)) + ((not inhibit-keyboard-quit) + (cond + ((and (null esc-flag) (eq char ?\e)) + (setq esc-flag t)) + ((memq char '(?\C-g ?\e)) + (keyboard-quit)))))))) + ;; Display the question with the answer. But without cursor-in-echo-area. + (message "%s%s" prompt (char-to-string char)) + char)) (defun sit-for (seconds &optional nodisp obsolete) "Redisplay, then wait for SECONDS seconds. Stop when input is available. @@ -2934,13 +3014,13 @@ If there is a natural number at point, use it as default." (let ((map (make-sparse-keymap))) (set-keymap-parent map minibuffer-local-map) - (define-key map [remap self-insert-command] 'read-char-from-minibuffer-insert-char) + (define-key map [remap self-insert-command] #'read-char-from-minibuffer-insert-char) - (define-key map [remap recenter-top-bottom] 'minibuffer-recenter-top-bottom) - (define-key map [remap scroll-up-command] 'minibuffer-scroll-up-command) - (define-key map [remap scroll-down-command] 'minibuffer-scroll-down-command) - (define-key map [remap scroll-other-window] 'minibuffer-scroll-other-window) - (define-key map [remap scroll-other-window-down] 'minibuffer-scroll-other-window-down) + (define-key map [remap recenter-top-bottom] #'minibuffer-recenter-top-bottom) + (define-key map [remap scroll-up-command] #'minibuffer-scroll-up-command) + (define-key map [remap scroll-down-command] #'minibuffer-scroll-down-command) + (define-key map [remap scroll-other-window] #'minibuffer-scroll-other-window) + (define-key map [remap scroll-other-window-down] #'minibuffer-scroll-other-window-down) map) "Keymap for the `read-char-from-minibuffer' function.") @@ -3003,9 +3083,9 @@ There is no need to explicitly add `help-char' to CHARS; (help-form-show))))) (dolist (char chars) (define-key map (vector char) - 'read-char-from-minibuffer-insert-char)) + #'read-char-from-minibuffer-insert-char)) (define-key map [remap self-insert-command] - 'read-char-from-minibuffer-insert-other) + #'read-char-from-minibuffer-insert-other) (puthash (list help-form (cons help-char chars)) map read-char-from-minibuffer-map-hash) map)) @@ -3038,26 +3118,26 @@ There is no need to explicitly add `help-char' to CHARS; (set-keymap-parent map minibuffer-local-map) (dolist (symbol '(act act-and-show act-and-exit automatic)) - (define-key map (vector 'remap symbol) 'y-or-n-p-insert-y)) + (define-key map (vector 'remap symbol) #'y-or-n-p-insert-y)) - (define-key map [remap skip] 'y-or-n-p-insert-n) + (define-key map [remap skip] #'y-or-n-p-insert-n) (dolist (symbol '(backup undo undo-all edit edit-replacement delete-and-edit ignore self-insert-command)) - (define-key map (vector 'remap symbol) 'y-or-n-p-insert-other)) + (define-key map (vector 'remap symbol) #'y-or-n-p-insert-other)) - (define-key map [remap recenter] 'minibuffer-recenter-top-bottom) - (define-key map [remap scroll-up] 'minibuffer-scroll-up-command) - (define-key map [remap scroll-down] 'minibuffer-scroll-down-command) - (define-key map [remap scroll-other-window] 'minibuffer-scroll-other-window) - (define-key map [remap scroll-other-window-down] 'minibuffer-scroll-other-window-down) + (define-key map [remap recenter] #'minibuffer-recenter-top-bottom) + (define-key map [remap scroll-up] #'minibuffer-scroll-up-command) + (define-key map [remap scroll-down] #'minibuffer-scroll-down-command) + (define-key map [remap scroll-other-window] #'minibuffer-scroll-other-window) + (define-key map [remap scroll-other-window-down] #'minibuffer-scroll-other-window-down) - (define-key map [escape] 'abort-recursive-edit) + (define-key map [escape] #'abort-recursive-edit) (dolist (symbol '(quit exit exit-prefix)) - (define-key map (vector 'remap symbol) 'abort-recursive-edit)) + (define-key map (vector 'remap symbol) #'abort-recursive-edit)) ;; FIXME: try catch-all instead of explicit bindings: - ;; (define-key map [remap t] 'y-or-n-p-insert-other) + ;; (define-key map [remap t] #'y-or-n-p-insert-other) map) "Keymap that defines additional bindings for `y-or-n-p' answers.") @@ -3301,7 +3381,7 @@ to `accept-change-group' or `cancel-change-group'." ;; insertions are ever merged/combined, so we use such a "boundary" ;; only when the last change was an insertion and we use the position ;; of the last insertion. - (when (numberp (caar buffer-undo-list)) + (when (numberp (car-safe (car buffer-undo-list))) (push (cons (caar buffer-undo-list) (caar buffer-undo-list)) buffer-undo-list)))))) @@ -3354,7 +3434,7 @@ This finishes the change group by reverting all of its changes." ;; For compatibility. (define-obsolete-function-alias 'redraw-modeline - 'force-mode-line-update "24.3") + #'force-mode-line-update "24.3") (defun momentary-string-display (string pos &optional exit-char message) "Momentarily display STRING in the buffer at POS. @@ -3498,7 +3578,7 @@ When in a major mode that does not provide its own symbol at point exactly." (let ((tag (funcall (or find-tag-default-function (get major-mode 'find-tag-default-function) - 'find-tag-default)))) + #'find-tag-default)))) (if tag (regexp-quote tag)))) (defun find-tag-default-as-symbol-regexp () @@ -3512,8 +3592,8 @@ symbol at point exactly." (if (and tag-regexp (eq (or find-tag-default-function (get major-mode 'find-tag-default-function) - 'find-tag-default) - 'find-tag-default)) + #'find-tag-default) + #'find-tag-default)) (format "\\_<%s\\_>" tag-regexp) tag-regexp))) @@ -3601,7 +3681,7 @@ See Info node `(elisp)Security Considerations'." "''" ;; Quote everything except POSIX filename characters. ;; This should be safe enough even for really weird shells. - (replace-regexp-in-string + (string-replace "\n" "'\n'" (replace-regexp-in-string "[^-0-9a-zA-Z_./\n]" "\\\\\\&" argument)))) )) @@ -3771,6 +3851,75 @@ Before insertion, process text properties according to (insert-buffer-substring buffer start end) (remove-yank-excluded-properties opoint (point)))) +(defun insert-into-buffer (buffer &optional start end) + "Insert the contents of the current buffer into BUFFER. +If START/END, only insert that region from the current buffer. +Point in BUFFER will be placed after the inserted text." + (let ((current (current-buffer))) + (with-current-buffer buffer + (insert-buffer-substring current start end)))) + +(defun replace-string-in-region (string replacement &optional start end) + "Replace STRING with REPLACEMENT in the region from START to END. +The number of replaced occurrences are returned, or nil if STRING +doesn't exist in the region. + +If START is nil, use the current point. If END is nil, use `point-max'. + +Comparisons and replacements are done with fixed case." + (if start + (when (< start (point-min)) + (error "Start before start of buffer")) + (setq start (point))) + (if end + (when (> end (point-max)) + (error "End after end of buffer")) + (setq end (point-max))) + (save-excursion + (let ((matches 0) + (case-fold-search nil)) + (goto-char start) + (while (search-forward string end t) + (delete-region (match-beginning 0) (match-end 0)) + (insert replacement) + (setq matches (1+ matches))) + (and (not (zerop matches)) + matches)))) + +(defun replace-regexp-in-region (regexp replacement &optional start end) + "Replace REGEXP with REPLACEMENT in the region from START to END. +The number of replaced occurrences are returned, or nil if REGEXP +doesn't exist in the region. + +If START is nil, use the current point. If END is nil, use `point-max'. + +Comparisons and replacements are done with fixed case. + +REPLACEMENT can use the following special elements: + + `\\&' in NEWTEXT means substitute original matched text. + `\\N' means substitute what matched the Nth `\\(...\\)'. + If Nth parens didn't match, substitute nothing. + `\\\\' means insert one `\\'. + `\\?' is treated literally." + (if start + (when (< start (point-min)) + (error "Start before start of buffer")) + (setq start (point))) + (if end + (when (> end (point-max)) + (error "End after end of buffer")) + (setq end (point-max))) + (save-excursion + (let ((matches 0) + (case-fold-search nil)) + (goto-char start) + (while (re-search-forward regexp end t) + (replace-match replacement t) + (setq matches (1+ matches))) + (and (not (zerop matches)) + matches)))) + (defun yank-handle-font-lock-face-property (face start end) "If `font-lock-defaults' is nil, apply FACE as a `face' property. START and END denote the start and end of the text to act on. @@ -3847,7 +3996,7 @@ discouraged." (call-process shell-file-name infile buffer display shell-command-switch - (mapconcat 'identity (cons command args) " "))) + (mapconcat #'identity (cons command args) " "))) (defun process-file-shell-command (command &optional infile buffer display &rest args) @@ -3859,7 +4008,7 @@ Similar to `call-process-shell-command', but calls `process-file'." (with-connection-local-variables (process-file shell-file-name infile buffer display shell-command-switch - (mapconcat 'identity (cons command args) " ")))) + (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. @@ -3890,7 +4039,7 @@ If you quit, the process is killed with SIGINT, or SIGKILL if you quit again." Within a `track-mouse' form, mouse motion generates input events that you can read with `read-event'. Normally, mouse motion is ignored." - (declare (debug t) (indent 0)) + (declare (debug (def-body)) (indent 0)) `(internal--track-mouse (lambda () ,@body))) (defmacro with-current-buffer (buffer-or-name &rest body) @@ -4320,6 +4469,8 @@ the specified region. It must not change Additionally, the buffer modifications of BODY are recorded on the buffer's undo list as a single (apply ...) entry containing the function `undo--wrap-and-run-primitive-undo'." + (if (markerp beg) (setq beg (marker-position beg))) + (if (markerp end) (setq end (marker-position end))) (let ((old-bul buffer-undo-list) (end-marker (copy-marker end t)) result) @@ -4392,7 +4543,7 @@ change `before-change-functions' or `after-change-functions'. Additionally, the buffer modifications of BODY are recorded on the buffer's undo list as a single \(apply ...) entry containing the function `undo--wrap-and-run-primitive-undo'." - (declare (debug t) (indent 2)) + (declare (debug (form form def-body)) (indent 2)) `(combine-change-calls-1 ,beg ,end (lambda () ,@body))) (defun undo--wrap-and-run-primitive-undo (beg end list) @@ -4718,7 +4869,7 @@ It understands Emacs Lisp quoting within STRING, such that (split-string-and-unquote (combine-and-quote-strings strs)) == strs The SEPARATOR regexp defaults to \"\\s-+\"." (let ((sep (or separator "\\s-+")) - (i (string-match "\"" string))) + (i (string-search "\"" string))) (if (null i) (split-string string sep t) ; no quoting: easy (append (unless (eq i 0) (split-string (substring string 0 i) sep t)) @@ -4745,7 +4896,7 @@ Unless optional argument INPLACE is non-nil, return a new string." "Replace FROMSTRING with TOSTRING in INSTRING each time it occurs." (declare (pure t) (side-effect-free t)) (when (equal fromstring "") - (signal 'wrong-length-argument fromstring)) + (signal 'wrong-length-argument '(0))) (let ((start 0) (result nil) pos) @@ -4876,8 +5027,8 @@ FILE, a string, is described in the function `eval-after-load'." "" ;; Note: regexp-opt can't be used here, since we need to call ;; this before Emacs has been fully started. 2006-05-21 - (concat "\\(" (mapconcat 'regexp-quote load-suffixes "\\|") "\\)?")) - "\\(" (mapconcat 'regexp-quote jka-compr-load-suffixes "\\|") + (concat "\\(" (mapconcat #'regexp-quote load-suffixes "\\|") "\\)?")) + "\\(" (mapconcat #'regexp-quote jka-compr-load-suffixes "\\|") "\\)?\\'")) (defun load-history-filename-element (file-regexp) @@ -4893,7 +5044,6 @@ Return nil if there isn't one." load-elt (and loads (car loads))))) load-elt)) -(put 'eval-after-load 'lisp-indent-function 1) (defun eval-after-load (file form) "Arrange that if FILE is loaded, FORM will be run immediately afterwards. If FILE is already loaded, evaluate FORM right now. @@ -4928,7 +5078,8 @@ like `font-lock'. This function makes or adds to an entry on `after-load-alist'. See also `with-eval-after-load'." - (declare (compiler-macro + (declare (indent 1) + (compiler-macro (lambda (whole) (if (eq 'quote (car-safe form)) ;; Quote with lambda so the compiler can look inside. @@ -4966,7 +5117,8 @@ See also `with-eval-after-load'." (funcall func) (let ((lfn load-file-name) ;; Don't use letrec, because equal (in - ;; add/remove-hook) would get trapped in a cycle. + ;; add/remove-hook) could get trapped in a cycle + ;; (bug#46326). (fun (make-symbol "eval-after-load-helper"))) (fset fun (lambda (file) (when (equal file lfn) @@ -4982,7 +5134,7 @@ See also `with-eval-after-load'." FILE is normally a feature name, but it can also be a file name, in case that file does not provide any feature. See `eval-after-load' for more details about the different forms of FILE and their semantics." - (declare (indent 1) (debug t)) + (declare (indent 1) (debug (form def-body))) `(eval-after-load ,file (lambda () ,@body))) (defvar after-load-functions nil @@ -5009,14 +5161,10 @@ This function is called directly from the C code." obarray)) (msg (format "Package %s is deprecated" package)) (fun (lambda (msg) (message "%s" msg)))) - ;; Cribbed from cl--compiling-file. (when (or (not (fboundp 'byte-compile-warning-enabled-p)) (byte-compile-warning-enabled-p 'obsolete package)) (cond - ((and (boundp 'byte-compile--outbuffer) - (bufferp (symbol-value 'byte-compile--outbuffer)) - (equal (buffer-name (symbol-value 'byte-compile--outbuffer)) - " *Compiler Output*")) + ((bound-and-true-p byte-compile-current-file) ;; Don't warn about obsolete files using other obsolete files. (unless (and (stringp byte-compile-current-file) (string-match-p "/obsolete/[^/]*\\'" @@ -5035,7 +5183,7 @@ This function is called directly from the C code." "Display delayed warnings from `delayed-warnings-list'. Used from `delayed-warnings-hook' (which see)." (dolist (warning (nreverse delayed-warnings-list)) - (apply 'display-warning warning)) + (apply #'display-warning warning)) (setq delayed-warnings-list nil)) (defun collapse-delayed-warnings () @@ -5368,7 +5516,7 @@ The properties used on SYMBOL are `composefunc', `sendfunc', `abortfunc', and `hookvar'." (put symbol 'composefunc composefunc) (put symbol 'sendfunc sendfunc) - (put symbol 'abortfunc (or abortfunc 'kill-buffer)) + (put symbol 'abortfunc (or abortfunc #'kill-buffer)) (put symbol 'hookvar (or hookvar 'mail-send-hook))) @@ -5480,7 +5628,7 @@ command is called from a keyboard macro?" ;; Now `frame' should be "the function from which we were called". (pcase (cons frame nextframe) ;; No subr calls `interactive-p', so we can rule that out. - (`((,_ ,(pred (lambda (f) (subrp (indirect-function f)))) . ,_) . ,_) nil) + (`((,_ ,(pred (lambda (f) (subr-primitive-p (indirect-function f)))) . ,_) . ,_) nil) ;; In case #<subr funcall-interactively> without going through the ;; `funcall-interactively' symbol (bug#3984). (`(,_ . (t ,(pred (lambda (f) @@ -5533,7 +5681,7 @@ To test whether a function can be called interactively, use (set symbol tail))))) (define-obsolete-function-alias - 'set-temporary-overlay-map 'set-transient-map "24.4") + 'set-temporary-overlay-map #'set-transient-map "24.4") (defun set-transient-map (map &optional keep-pred on-exit) "Set MAP as a temporary keymap taking precedence over other keymaps. @@ -5558,8 +5706,8 @@ to deactivate this transient map, regardless of KEEP-PRED." (internal-pop-keymap map 'overriding-terminal-local-map) (remove-hook 'pre-command-hook clearfun) (when on-exit (funcall on-exit))))) - ;; Don't use letrec, because equal (in add/remove-hook) would get trapped - ;; in a cycle. + ;; Don't use letrec, because equal (in add/remove-hook) could get trapped + ;; in a cycle. (bug#46326) (fset clearfun (lambda () (with-demoted-errors "set-transient-map PCH: %S" @@ -6161,7 +6309,29 @@ returned list are in the same order as in TREE. ;; Technically, `flatten-list' is a misnomer, but we provide it here ;; for discoverability: -(defalias 'flatten-list 'flatten-tree) +(defalias 'flatten-list #'flatten-tree) + +(defun string-trim-left (string &optional regexp) + "Trim STRING of leading string matching REGEXP. + +REGEXP defaults to \"[ \\t\\n\\r]+\"." + (if (string-match (concat "\\`\\(?:" (or regexp "[ \t\n\r]+") "\\)") string) + (substring string (match-end 0)) + string)) + +(defun string-trim-right (string &optional regexp) + "Trim STRING of trailing string matching REGEXP. + +REGEXP defaults to \"[ \\t\\n\\r]+\"." + (let ((i (string-match-p (concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'") + string))) + (if i (substring string 0 i) string))) + +(defun string-trim (string &optional trim-left trim-right) + "Trim STRING of leading and trailing strings matching TRIM-LEFT and TRIM-RIGHT. + +TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"." + (string-trim-left (string-trim-right string trim-right) trim-left)) ;; The initial anchoring is for better performance in searching matches. (defconst regexp-unmatchable "\\`a\\`" @@ -6203,4 +6373,12 @@ of fill.el (for example `fill-region')." This is intended for internal use only." (internal--fill-string-single-line (apply #'format string objects))) +(defun json-available-p () + "Return non-nil if Emacs has libjansson support." + (and (fboundp 'json-serialize) + (condition-case nil + (json-serialize t) + (:success t) + (json-unavailable nil)))) + ;;; subr.el ends here |