X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/1fb87f1f1aa0947ec7b572a0ec1677c18aefc9f0..20aa42e8204f8f0139ba3880cb32ddf88acc9bf4:/lisp/simple.el diff --git a/lisp/simple.el b/lisp/simple.el index 2f09042d81..2781ad02b9 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -458,18 +458,27 @@ A non-nil INTERACTIVE argument means to run the `post-self-insert-hook'." (put-text-property from (point) 'rear-nonsticky (cons 'hard sticky))))) -(defun open-line (n) +(declare-function electric-indent-just-newline "electric") +(defun open-line (n &optional interactive) "Insert a newline and leave point before it. -If there is a fill prefix and/or a `left-margin', insert them -on the new line if the line would have been blank. -With arg N, insert N newlines." - (interactive "*p") +If `electric-indent-mode' is enabled, indent the new line if it's +not empty. +If there is a fill prefix and/or a `left-margin', insert them on +the new line. If the old line would have been blank, insert them +on the old line as well. + +With arg N, insert N newlines. +A non-nil INTERACTIVE argument means to run the `post-self-insert-hook'." + (interactive "*p\np") (let* ((do-fill-prefix (and fill-prefix (bolp))) (do-left-margin (and (bolp) (> (current-left-margin) 0))) (loc (point-marker)) - ;; Don't expand an abbrev before point. + ;; Don't expand an abbrev before point. (abbrev-mode nil)) - (newline n) + (if (and interactive + (looking-at-p "[[:space:]]*$")) + (electric-indent-just-newline n) + (newline n interactive)) (goto-char loc) (while (> n 0) (cond ((bolp) @@ -478,6 +487,7 @@ With arg N, insert N newlines." (forward-line 1) (setq n (1- n))) (goto-char loc) + ;; Necessary in case a margin or prefix was inserted. (end-of-line))) (defun split-line (&optional arg) @@ -693,7 +703,8 @@ any other non-digit terminates the character code and is then used as input.")) (cond ((null translated)) ((not (integerp translated)) (setq unread-command-events - (listify-key-sequence (this-single-command-raw-keys)) + (nconc (listify-key-sequence (this-single-command-raw-keys)) + unread-command-events) done t)) ((/= (logand translated ?\M-\^@) 0) ;; Turn a meta-character into a character with the 0200 bit set. @@ -713,7 +724,8 @@ any other non-digit terminates the character code and is then used as input.")) (setq done t)) ((not first) (setq unread-command-events - (listify-key-sequence (this-single-command-raw-keys)) + (nconc (listify-key-sequence (this-single-command-raw-keys)) + unread-command-events) done t)) (t (setq code translated done t))) @@ -893,8 +905,8 @@ With numeric arg N, put point N/10 of the way from the beginning. If the buffer is narrowed, this command uses the beginning of the accessible part of the buffer. -If Transient Mark mode is disabled, leave mark at previous -position, unless a \\[universal-argument] prefix is supplied." +Push mark at previous position, unless either a \\[universal-argument] prefix +is supplied, or Transient Mark mode is enabled and the mark is active." (declare (interactive-only "use `(goto-char (point-min))' instead.")) (interactive "^P") (or (consp arg) @@ -917,8 +929,8 @@ With numeric arg N, put point N/10 of the way from the end. If the buffer is narrowed, this command uses the end of the accessible part of the buffer. -If Transient Mark mode is disabled, leave mark at previous -position, unless a \\[universal-argument] prefix is supplied." +Push mark at previous position, unless either a \\[universal-argument] prefix +is supplied, or Transient Mark mode is enabled and the mark is active." (declare (interactive-only "use `(goto-char (point-max))' instead.")) (interactive "^P") (or (consp arg) (region-active-p) (push-mark)) @@ -1255,10 +1267,7 @@ in *Help* buffer. See also the command `describe-char'." (end (point-max)) (pos (point)) (total (buffer-size)) - (percent (if (> total 50000) - ;; Avoid overflow from multiplying by 100! - (/ (+ (/ total 200) (1- pos)) (max (/ total 100) 1)) - (/ (+ (/ total 2) (* 100 (1- pos))) (max total 1)))) + (percent (round (* 100.0 (1- pos)) (max 1 total))) (hscroll (if (= (window-hscroll) 0) "" (format " Hscroll=%d" (window-hscroll)))) @@ -1448,7 +1457,7 @@ this command arranges for all errors to enter the debugger." ;; Bind debug-on-error to something unique so that we can ;; detect when evalled code changes it. (let ((debug-on-error old-value)) - (push (eval exp lexical-binding) values) + (push (eval (macroexpand-all exp) lexical-binding) values) (setq new-value debug-on-error)) ;; If evalled code has changed the value of debug-on-error, ;; propagate that change to the global binding. @@ -1690,11 +1699,11 @@ invoking, give a prefix argument to `execute-extended-command'." (symbol-name function) typed)))) (when binding (with-temp-message - (format "You can run the command `%s' with %s" - function - (if (stringp binding) - (concat "M-x " binding " RET") - (key-description binding))) + (format-message "You can run the command `%s' with %s" + function + (if (stringp binding) + (concat "M-x " binding " RET") + (key-description binding))) (sit-for (if (numberp suggest-key-bindings) suggest-key-bindings 2)))))))) @@ -1712,9 +1721,13 @@ The argument SPECIAL, if non-nil, means that this command is executing a special event, so ignore the prefix argument and don't clear it." (setq debug-on-next-call nil) (let ((prefixarg (unless special + ;; FIXME: This should probably be done around + ;; pre-command-hook rather than here! (prog1 prefix-arg (setq current-prefix-arg prefix-arg) - (setq prefix-arg nil))))) + (setq prefix-arg nil) + (when current-prefix-arg + (prefix-command-update)))))) (if (and (symbolp cmd) (get cmd 'disabled) disabled-command-function) @@ -1776,6 +1789,7 @@ in this use of the minibuffer.") (defun minibuffer-avoid-prompt (_new _old) "A point-motion hook for the minibuffer, that moves point out of the prompt." + (declare (obsolete cursor-intangible-mode "25.1")) (constrain-to-field nil (point-max))) (defcustom minibuffer-history-case-insensitive-variables nil @@ -1940,7 +1954,9 @@ The argument NABS specifies the absolute history position." (user-error (if minibuffer-default "End of defaults; no next item" "End of history; no default available"))) - (if (> nabs (length (symbol-value minibuffer-history-variable))) + (if (> nabs (if (listp (symbol-value minibuffer-history-variable)) + (length (symbol-value minibuffer-history-variable)) + 0)) (user-error "Beginning of history; no preceding item")) (unless (memq last-command '(next-history-element previous-history-element)) @@ -1990,7 +2006,14 @@ When point moves over the bottom line of multi-line minibuffer, puts ARGth next element of the minibuffer history in the minibuffer." (interactive "^p") (or arg (setq arg 1)) - (let ((old-point (point))) + (let* ((old-point (point)) + ;; Remember the original goal column of possibly multi-line input + ;; excluding the length of the prompt on the first line. + (prompt-end (minibuffer-prompt-end)) + (old-column (unless (and (eolp) (> (point) prompt-end)) + (if (= (line-number-at-pos) 1) + (max (- (current-column) (1- prompt-end)) 0) + (current-column))))) (condition-case nil (with-no-warnings (next-line arg)) @@ -1998,7 +2021,14 @@ next element of the minibuffer history in the minibuffer." ;; Restore old position since `line-move-visual' moves point to ;; the end of the line when it fails to go to the next line. (goto-char old-point) - (next-history-element arg))))) + (next-history-element arg) + ;; Restore the original goal column on the last line + ;; of possibly multi-line input. + (goto-char (point-max)) + (when old-column + (if (= (line-number-at-pos) 1) + (move-to-column (+ old-column (1- (minibuffer-prompt-end)))) + (move-to-column old-column))))))) (defun previous-line-or-history-element (&optional arg) "Move cursor vertically up ARG lines, or to the previous history element. @@ -2006,7 +2036,14 @@ When point moves over the top line of multi-line minibuffer, puts ARGth previous element of the minibuffer history in the minibuffer." (interactive "^p") (or arg (setq arg 1)) - (let ((old-point (point))) + (let* ((old-point (point)) + ;; Remember the original goal column of possibly multi-line input + ;; excluding the length of the prompt on the first line. + (prompt-end (minibuffer-prompt-end)) + (old-column (unless (and (eolp) (> (point) prompt-end)) + (if (= (line-number-at-pos) 1) + (max (- (current-column) (1- prompt-end)) 0) + (current-column))))) (condition-case nil (with-no-warnings (previous-line arg)) @@ -2014,7 +2051,15 @@ previous element of the minibuffer history in the minibuffer." ;; Restore old position since `line-move-visual' moves point to ;; the beginning of the line when it fails to go to the previous line. (goto-char old-point) - (previous-history-element arg))))) + (previous-history-element arg) + ;; Restore the original goal column on the first line + ;; of possibly multi-line input. + (goto-char (minibuffer-prompt-end)) + (if old-column + (if (= (line-number-at-pos) 1) + (move-to-column (+ old-column (1- (minibuffer-prompt-end)))) + (move-to-column old-column)) + (goto-char (line-end-position))))))) (defun next-complete-history-element (n) "Get next history element which completes the minibuffer before the point. @@ -2723,6 +2768,143 @@ with < or <= based on USE-<." '(0 . 0))) '(0 . 0))) +;;; Default undo-boundary addition +;; +;; This section adds a new undo-boundary at either after a command is +;; called or in some cases on a timer called after a change is made in +;; any buffer. +(defvar-local undo-auto--last-boundary-cause nil + "Describe the cause of the last undo-boundary. + +If `explicit', the last boundary was caused by an explicit call to +`undo-boundary', that is one not called by the code in this +section. + +If it is equal to `timer', then the last boundary was inserted +by `undo-auto--boundary-timer'. + +If it is equal to `command', then the last boundary was inserted +automatically after a command, that is by the code defined in +this section. + +If it is equal to a list, then the last boundary was inserted by +an amalgamating command. The car of the list is the number of +times an amalgamating command has been called, and the cdr are the +buffers that were changed during the last command.") + +(defvar undo-auto--current-boundary-timer nil + "Current timer which will run `undo-auto--boundary-timer' or nil. + +If set to non-nil, this will effectively disable the timer.") + +(defvar undo-auto--this-command-amalgamating nil + "Non-nil if `this-command' should be amalgamated. +This variable is set to nil by `undo-auto--boundaries' and is set +by `undo-auto--amalgamate'." ) + +(defun undo-auto--needs-boundary-p () + "Return non-nil if `buffer-undo-list' needs a boundary at the start." + (car-safe buffer-undo-list)) + +(defun undo-auto--last-boundary-amalgamating-number () + "Return the number of amalgamating last commands or nil. +Amalgamating commands are, by default, either +`self-insert-command' and `delete-char', but can be any command +that calls `undo-auto--amalgamate'." + (car-safe undo-auto--last-boundary-cause)) + +(defun undo-auto--ensure-boundary (cause) + "Add an `undo-boundary' to the current buffer if needed. +REASON describes the reason that the boundary is being added; see +`undo-auto--last-boundary' for more information." + (when (and + (undo-auto--needs-boundary-p)) + (let ((last-amalgamating + (undo-auto--last-boundary-amalgamating-number))) + (undo-boundary) + (setq undo-auto--last-boundary-cause + (if (eq 'amalgamate cause) + (cons + (if last-amalgamating (1+ last-amalgamating) 0) + undo-auto--undoably-changed-buffers) + cause))))) + +(defun undo-auto--boundaries (cause) + "Check recently changed buffers and add a boundary if necessary. +REASON describes the reason that the boundary is being added; see +`undo-last-boundary' for more information." + (dolist (b undo-auto--undoably-changed-buffers) + (when (buffer-live-p b) + (with-current-buffer b + (undo-auto--ensure-boundary cause)))) + (setq undo-auto--undoably-changed-buffers nil)) + +(defun undo-auto--boundary-timer () + "Timer which will run `undo--auto-boundary-timer'." + (setq undo-auto--current-boundary-timer nil) + (undo-auto--boundaries 'timer)) + +(defun undo-auto--boundary-ensure-timer () + "Ensure that the `undo-auto-boundary-timer' is set." + (unless undo-auto--current-boundary-timer + (setq undo-auto--current-boundary-timer + (run-at-time 10 nil #'undo-auto--boundary-timer)))) + +(defvar undo-auto--undoably-changed-buffers nil + "List of buffers that have changed recently. + +This list is maintained by `undo-auto--undoable-change' and +`undo-auto--boundaries' and can be affected by changes to their +default values. + +See also `undo-auto--buffer-undoably-changed'.") + +(defun undo-auto--add-boundary () + "Add an `undo-boundary' in appropriate buffers." + (undo-auto--boundaries + (if undo-auto--this-command-amalgamating + 'amalgamate + 'command)) + (setq undo-auto--this-command-amalgamating nil)) + +(defun undo-auto--amalgamate () + "Amalgamate undo if necessary. +This function can be called after an amalgamating command. It +removes the previous `undo-boundary' if a series of such calls +have been made. By default `self-insert-command' and +`delete-char' are the only amalgamating commands, although this +function could be called by any command wishing to have this +behaviour." + (let ((last-amalgamating-count + (undo-auto--last-boundary-amalgamating-number))) + (setq undo-auto--this-command-amalgamating t) + (when + last-amalgamating-count + (if + (and + (< last-amalgamating-count 20) + (eq this-command last-command)) + ;; Amalgamate all buffers that have changed. + (dolist (b (cdr undo-auto--last-boundary-cause)) + (when (buffer-live-p b) + (with-current-buffer + b + (when + ;; The head of `buffer-undo-list' is nil. + ;; `car-safe' doesn't work because + ;; `buffer-undo-list' need not be a list! + (and (listp buffer-undo-list) + (not (car buffer-undo-list))) + (setq buffer-undo-list + (cdr buffer-undo-list)))))) + (setq undo-auto--last-boundary-cause 0))))) + +(defun undo-auto--undoable-change () + "Called after every undoable buffer change." + (add-to-list 'undo-auto--undoably-changed-buffers (current-buffer)) + (undo-auto--boundary-ensure-timer)) +;; End auto-boundary section + (defcustom undo-ask-before-discard nil "If non-nil ask about discarding undo info for the current command. Normally, Emacs discards the undo info for the current command if @@ -2765,16 +2947,18 @@ This variable only matters if `undo-ask-before-discard' is non-nil.") ;; but we don't want to ask the question again. (setq undo-extra-outer-limit (+ size 50000)) (if (let (use-dialog-box track-mouse executing-kbd-macro ) - (yes-or-no-p (format "Buffer `%s' undo info is %d bytes long; discard it? " - (buffer-name) size))) + (yes-or-no-p (format-message + "Buffer `%s' undo info is %d bytes long; discard it? " + (buffer-name) size))) (progn (setq buffer-undo-list nil) (setq undo-extra-outer-limit nil) t) nil)) (display-warning '(undo discard-info) (concat - (format "Buffer `%s' undo info was %d bytes long.\n" - (buffer-name) size) + (format-message + "Buffer `%s' undo info was %d bytes long.\n" + (buffer-name) size) "The undo info was discarded because it exceeded \ `undo-outer-limit'. @@ -3286,7 +3470,7 @@ display the error buffer if there were any errors. When called interactively, this is t." (interactive (let (string) (unless (mark) - (error "The mark is not set now, so there is no region")) + (user-error "The mark is not set now, so there is no region")) ;; Do this before calling region-beginning ;; and region-end, in case subprocess output ;; relocates them while we are in the minibuffer. @@ -3456,9 +3640,9 @@ value passed." (defvar process-file-side-effects t "Whether a call of `process-file' changes remote files. -By default, this variable is always set to `t', meaning that a +By default, this variable is always set to t, meaning that a call of `process-file' could potentially change any file on a -remote host. When set to `nil', a file handler could optimize +remote host. When set to nil, a file handler could optimize its behavior with respect to remote file attribute caching. You should only ever change this variable with a let-binding; @@ -3489,7 +3673,7 @@ support pty association, if PROGRAM is nil." (defvar tabulated-list-sort-key) (declare-function tabulated-list-init-header "tabulated-list" ()) (declare-function tabulated-list-print "tabulated-list" - (&optional remember-pos)) + (&optional remember-pos update)) (defvar process-menu-query-only nil) @@ -3532,8 +3716,9 @@ Also, delete any process that is exited or signaled." (buf-label (if (buffer-live-p buf) `(,(buffer-name buf) face link - help-echo ,(concat "Visit buffer `" - (buffer-name buf) "'") + help-echo ,(format-message + "Visit buffer `%s'" + (buffer-name buf)) follow-link t process-buffer ,buf action process-menu-visit-buffer) @@ -3592,6 +3777,73 @@ see other processes running on the system, use `list-system-processes'." (display-buffer buffer) nil) +;;;; Prefix commands + +(setq prefix-command--needs-update nil) +(setq prefix-command--last-echo nil) + +(defun internal-echo-keystrokes-prefix () + ;; BEWARE: Called directly from the C code. + (if (not prefix-command--needs-update) + prefix-command--last-echo + (setq prefix-command--last-echo + (let ((strs nil)) + (run-hook-wrapped 'prefix-command-echo-keystrokes-functions + (lambda (fun) (push (funcall fun) strs))) + (setq strs (delq nil strs)) + (when strs (mapconcat #'identity strs " ")))))) + +(defvar prefix-command-echo-keystrokes-functions nil + "Abnormal hook which constructs the description of the current prefix state. +Each function is called with no argument, should return a string or nil.") + +(defun prefix-command-update () + "Update state of prefix commands. +Call it whenever you change the \"prefix command state\"." + (setq prefix-command--needs-update t)) + +(defvar prefix-command-preserve-state-hook nil + "Normal hook run when a command needs to preserve the prefix.") + +(defun prefix-command-preserve-state () + "Pass the current prefix command state to the next command. +Should be called by all prefix commands. +Runs `prefix-command-preserve-state-hook'." + (run-hooks 'prefix-command-preserve-state-hook) + ;; If the current command is a prefix command, we don't want the next (real) + ;; command to have `last-command' set to, say, `universal-argument'. + (setq this-command last-command) + (setq real-this-command real-last-command) + (prefix-command-update)) + +(defun reset-this-command-lengths () + (declare (obsolete prefix-command-preserve-state "25.1")) + nil) + +;;;;; The main prefix command. + +;; FIXME: Declaration of `prefix-arg' should be moved here!? + +(add-hook 'prefix-command-echo-keystrokes-functions + #'universal-argument--description) +(defun universal-argument--description () + (when prefix-arg + (concat "C-u" + (pcase prefix-arg + (`(-) " -") + (`(,(and (pred integerp) n)) + (let ((str "")) + (while (and (> n 4) (= (mod n 4) 0)) + (setq str (concat str " C-u")) + (setq n (/ n 4))) + (if (= n 4) str (format " %s" prefix-arg)))) + (_ (format " %s" prefix-arg)))))) + +(add-hook 'prefix-command-preserve-state-hook + #'universal-argument--preserve) +(defun universal-argument--preserve () + (setq prefix-arg current-prefix-arg)) + (defvar universal-argument-map (let ((map (make-sparse-keymap)) (universal-argument-minus @@ -3630,7 +3882,8 @@ see other processes running on the system, use `list-system-processes'." "Keymap used while processing \\[universal-argument].") (defun universal-argument--mode () - (set-transient-map universal-argument-map)) + (prefix-command-update) + (set-transient-map universal-argument-map nil)) (defun universal-argument () "Begin a numeric argument for the following command. @@ -3643,6 +3896,7 @@ For some commands, just \\[universal-argument] by itself serves as a flag which is different in effect from any particular numeric argument. These commands include \\[set-mark-command] and \\[start-kbd-macro]." (interactive) + (prefix-command-preserve-state) (setq prefix-arg (list 4)) (universal-argument--mode)) @@ -3650,6 +3904,7 @@ These commands include \\[set-mark-command] and \\[start-kbd-macro]." ;; A subsequent C-u means to multiply the factor by 4 if we've typed ;; nothing but C-u's; otherwise it means to terminate the prefix arg. (interactive "P") + (prefix-command-preserve-state) (setq prefix-arg (if (consp arg) (list (* 4 (car arg))) (if (eq arg '-) @@ -3661,6 +3916,7 @@ These commands include \\[set-mark-command] and \\[start-kbd-macro]." "Begin a negative numeric argument for the next command. \\[universal-argument] following digits or minus sign ends the argument." (interactive "P") + (prefix-command-preserve-state) (setq prefix-arg (cond ((integerp arg) (- arg)) ((eq arg '-) nil) (t '-))) @@ -3670,6 +3926,7 @@ These commands include \\[set-mark-command] and \\[start-kbd-macro]." "Part of the numeric argument for the next command. \\[universal-argument] following digits or minus sign ends the argument." (interactive "P") + (prefix-command-preserve-state) (let* ((char (if (integerp last-command-event) last-command-event (get last-command-event 'ascii-character))) @@ -3985,7 +4242,7 @@ some text between BEG and END, but we're killing the region." ;; calling `kill-append'. (interactive (list (mark) (point) 'region)) (unless (and beg end) - (error "The mark is not set now, so there is no region")) + (user-error "The mark is not set now, so there is no region")) (condition-case nil (let ((string (if region (funcall region-extract-function 'delete) @@ -4776,13 +5033,14 @@ run `deactivate-mark-hook'." ;; the region prior to the last command modifying the buffer. ;; Set the selection to that, or to the current region. (cond (saved-region-selection - (gui-set-selection 'PRIMARY saved-region-selection) + (if (gui-backend-selection-owner-p 'PRIMARY) + (gui-set-selection 'PRIMARY saved-region-selection)) (setq saved-region-selection nil)) ;; If another program has acquired the selection, region ;; deactivation should not clobber it (Bug#11772). ((and (/= (region-beginning) (region-end)) - (or (gui-call gui-selection-owner-p 'PRIMARY) - (null (gui-call gui-selection-exists-p 'PRIMARY)))) + (or (gui-backend-selection-owner-p 'PRIMARY) + (null (gui-backend-selection-exists-p 'PRIMARY)))) (gui-set-selection 'PRIMARY (funcall region-extract-function nil))))) (when mark-active (force-mode-line-update)) ;Refresh toolbar (bug#16382). @@ -4837,6 +5095,45 @@ store it in a Lisp variable. Example: (setq mark-active nil) (set-marker (mark-marker) nil))) +(defun save-mark-and-excursion--save () + (cons + (let ((mark (mark-marker))) + (and (marker-position mark) (copy-marker mark))) + mark-active)) + +(defun save-mark-and-excursion--restore (saved-mark-info) + (let ((saved-mark (car saved-mark-info)) + (omark (marker-position (mark-marker))) + (nmark nil) + (saved-mark-active (cdr saved-mark-info))) + ;; Mark marker + (if (null saved-mark) + (set-marker (mark-marker) nil) + (setf nmark (marker-position saved-mark)) + (set-marker (mark-marker) nmark) + (set-marker saved-mark nil)) + ;; Mark active + (let ((cur-mark-active mark-active)) + (setq mark-active saved-mark-active) + ;; If mark is active now, and either was not active or was at a + ;; different place, run the activate hook. + (if saved-mark-active + (when (or (not cur-mark-active) + (not (eq omark nmark))) + (run-hooks 'activate-mark-hook)) + ;; If mark has ceased to be active, run deactivate hook. + (when cur-mark-active + (run-hooks 'deactivate-mark-hook)))))) + +(defmacro save-mark-and-excursion (&rest body) + "Like `save-excursion', but also save and restore the mark state. +This macro does what `save-excursion' did before Emacs 25.1." + (let ((saved-marker-sym (make-symbol "saved-marker"))) + `(let ((,saved-marker-sym (save-mark-and-excursion--save))) + (unwind-protect + (save-excursion ,@body) + (save-mark-and-excursion--restore ,saved-marker-sym))))) + (defcustom use-empty-active-region nil "Whether \"region-aware\" commands should act on empty regions. If nil, region-aware commands treat empty regions as inactive. @@ -4876,7 +5173,7 @@ also checks the value of `use-empty-active-region'." ;; without the mark being set (e.g. bug#17324). We really should fix ;; that problem, but in the mean time, let's make sure we don't say the ;; region is active when there's no mark. - (mark))) + (progn (cl-assert (mark)) t))) (defvar redisplay-unhighlight-region-function @@ -4902,37 +5199,41 @@ also checks the value of `use-empty-active-region'." rol))) (defun redisplay--update-region-highlight (window) - (with-current-buffer (window-buffer window) - (let ((rol (window-parameter window 'internal-region-overlay))) - (if (not (region-active-p)) - (funcall redisplay-unhighlight-region-function rol) - (let* ((pt (window-point window)) - (mark (mark)) - (start (min pt mark)) - (end (max pt mark)) - (new - (funcall redisplay-highlight-region-function - start end window rol))) - (unless (equal new rol) - (set-window-parameter window 'internal-region-overlay - new))))))) - -(defun redisplay--update-region-highlights (windows) - (with-demoted-errors "redisplay--update-region-highlights: %S" + (let ((rol (window-parameter window 'internal-region-overlay))) + (if (not (and (region-active-p) + (or highlight-nonselected-windows + (eq window (selected-window)) + (and (window-minibuffer-p) + (eq window (minibuffer-selected-window)))))) + (funcall redisplay-unhighlight-region-function rol) + (let* ((pt (window-point window)) + (mark (mark)) + (start (min pt mark)) + (end (max pt mark)) + (new + (funcall redisplay-highlight-region-function + start end window rol))) + (unless (equal new rol) + (set-window-parameter window 'internal-region-overlay + new)))))) + +(defvar pre-redisplay-functions (list #'redisplay--update-region-highlight) + "Hook run just before redisplay. +It is called in each window that is to be redisplayed. It takes one argument, +which is the window that will be redisplayed. When run, the `current-buffer' +is set to the buffer displayed in that window.") + +(defun redisplay--pre-redisplay-functions (windows) + (with-demoted-errors "redisplay--pre-redisplay-functions: %S" (if (null windows) - (redisplay--update-region-highlight (selected-window)) - (unless (listp windows) (setq windows (window-list-1 nil nil t))) - (if highlight-nonselected-windows - (mapc #'redisplay--update-region-highlight windows) - (let ((msw (and (window-minibuffer-p) (minibuffer-selected-window)))) - (dolist (w windows) - (if (or (eq w (selected-window)) (eq w msw)) - (redisplay--update-region-highlight w) - (funcall redisplay-unhighlight-region-function - (window-parameter w 'internal-region-overlay))))))))) + (with-current-buffer (window-buffer (selected-window)) + (run-hook-with-args 'pre-redisplay-functions (selected-window))) + (dolist (win (if (listp windows) windows (window-list-1 nil nil t))) + (with-current-buffer (window-buffer win) + (run-hook-with-args 'pre-redisplay-functions win)))))) (add-function :before pre-redisplay-function - #'redisplay--update-region-highlights) + #'redisplay--pre-redisplay-functions) (defvar-local mark-ring nil @@ -5168,10 +5469,11 @@ positive, and disable it otherwise. If called from Lisp, enable Transient Mark mode if ARG is omitted or nil. Transient Mark mode is a global minor mode. When enabled, the -region is highlighted whenever the mark is active. The mark is -\"deactivated\" by changing the buffer, and after certain other -operations that set the mark but whose main purpose is something -else--for example, incremental search, \\[beginning-of-buffer], and \\[end-of-buffer]. +region is highlighted with the `region' face whenever the mark +is active. The mark is \"deactivated\" by changing the buffer, +and after certain other operations that set the mark but whose +main purpose is something else--for example, incremental search, +\\[beginning-of-buffer], and \\[end-of-buffer]. You can also deactivate the mark by typing \\[keyboard-quit] or \\[keyboard-escape-quit]. @@ -5377,7 +5679,10 @@ lines." (declare-function font-info "font.c" (name &optional frame)) (defun default-font-height () - "Return the height in pixels of the current buffer's default face font." + "Return the height in pixels of the current buffer's default face font. + +If the default font is remapped (see `face-remapping-alist'), the +function returns the height of the remapped face." (let ((default-font (face-font 'default))) (cond ((and (display-multi-font-p) @@ -5388,6 +5693,25 @@ lines." (aref (font-info default-font) 3)) (t (frame-char-height))))) +(defun default-font-width () + "Return the width in pixels of the current buffer's default face font. + +If the default font is remapped (see `face-remapping-alist'), the +function returns the width of the remapped face." + (let ((default-font (face-font 'default))) + (cond + ((and (display-multi-font-p) + ;; Avoid calling font-info if the frame's default font was + ;; not changed since the frame was created. That's because + ;; font-info is expensive for some fonts, see bug #14838. + (not (string= (frame-parameter nil 'font) default-font))) + (let* ((info (font-info (face-font 'default))) + (width (aref info 11))) + (if (> width 0) + width + (aref info 10)))) + (t (frame-char-width))))) + (defun default-line-height () "Return the pixel height of current buffer's default-face text line. @@ -5901,7 +6225,11 @@ and `current-column' to be able to ignore invisible text." ;; that will get us to the same place on the screen ;; but with a more reasonable buffer position. (goto-char normal-location) - (let ((line-beg (line-beginning-position))) + (let ((line-beg + ;; We want the real line beginning, so it's consistent + ;; with bolp below, otherwise we might infloop. + (let ((inhibit-field-text-motion t)) + (line-beginning-position)))) (while (and (not (bolp)) (invisible-p (1- (point)))) (goto-char (previous-char-property-change (point) line-beg)))))))) @@ -6572,7 +6900,7 @@ beyond `current-fill-column' automatically breaks the line at a previous space. When `auto-fill-mode' is on, the `auto-fill-function' variable is -non-`nil'. +non-nil. The value of `normal-auto-fill-function' specifies the function to use for `auto-fill-function' when turning Auto Fill mode on." @@ -6771,17 +7099,22 @@ If called from Lisp, enable the mode if ARG is omitted or nil." (defcustom blink-matching-paren t "Non-nil means show matching open-paren when close-paren is inserted. -If t, highlight the paren. If `jump', move cursor to its position." +If t, highlight the paren. If `jump', briefly move cursor to its +position. If `jump-offscreen', move cursor there even if the +position is off screen. With any other non-nil value, the +off-screen position of the opening paren will be shown in the +echo area." :type '(choice (const :tag "Disable" nil) (const :tag "Highlight" t) - (const :tag "Move cursor" jump)) + (const :tag "Move cursor" jump) + (const :tag "Move cursor, even if off screen" jump-offscreen)) :group 'paren-blinking) (defcustom blink-matching-paren-on-screen t "Non-nil means show matching open-paren when it is on screen. If nil, don't show it (but the open-paren can still be shown -when it is off screen). +in the echo area when it is off screen). This variable has no effect if `blink-matching-paren' is nil. \(In that case, the open-paren is never shown.) @@ -6885,13 +7218,15 @@ The function should return non-nil if the two tokens do not match.") (minibuffer-message "No matching parenthesis found") (message "No matching parenthesis found")))) ((not blinkpos) nil) - ((pos-visible-in-window-p blinkpos) + ((or + (eq blink-matching-paren 'jump-offscreen) + (pos-visible-in-window-p blinkpos)) ;; Matching open within window, temporarily move to or highlight ;; char after blinkpos but only if `blink-matching-paren-on-screen' ;; is non-nil. (and blink-matching-paren-on-screen (not show-paren-mode) - (if (eq blink-matching-paren 'jump) + (if (memq blink-matching-paren '(jump jump-offscreen)) (save-excursion (goto-char blinkpos) (sit-for blink-matching-delay)) @@ -6902,9 +7237,9 @@ The function should return non-nil if the two tokens do not match.") (sit-for blink-matching-delay)) (delete-overlay blink-matching--overlay))))) (t - (save-excursion - (goto-char blinkpos) - (let ((open-paren-line-string + (let ((open-paren-line-string + (save-excursion + (goto-char blinkpos) ;; Show what precedes the open in its line, if anything. (cond ((save-excursion (skip-chars-backward " \t") (not (bolp))) @@ -6931,9 +7266,10 @@ The function should return non-nil if the two tokens do not match.") "..." (buffer-substring blinkpos (1+ blinkpos)))) ;; There is nothing to show except the char itself. - (t (buffer-substring blinkpos (1+ blinkpos)))))) - (message "Matches %s" - (substring-no-properties open-paren-line-string))))))))) + (t (buffer-substring blinkpos (1+ blinkpos))))))) + (minibuffer-message + "Matches %s" + (substring-no-properties open-paren-line-string)))))))) (defvar blink-paren-function 'blink-matching-open "Function called, if non-nil, whenever a close parenthesis is inserted. @@ -6946,6 +7282,8 @@ More precisely, a char with closeparen syntax is self-inserted.") (not executing-kbd-macro) (not noninteractive) ;; Verify an even number of quoting characters precede the close. + ;; FIXME: Also check if this parenthesis closes a comment as + ;; can happen in Pascal and SML. (= 1 (logand 1 (- (point) (save-excursion (forward-char -1) @@ -7157,7 +7495,7 @@ buffer buried." (push var warn-vars))) (when warn-vars (display-warning 'mail - (format "\ + (format-message "\ The default mail mode is now Message mode. You have the following Mail mode variable%s customized: \n %s\n\nTo use Mail mode, set `mail-user-agent' to sendmail-user-agent. @@ -7208,6 +7546,11 @@ it were the arg to `interactive' (which see) to interactively read VALUE. If VARIABLE has been defined with `defcustom', then the type information in the definition is used to check that VALUE is valid. +Note that this function is at heart equivalent to the basic `set' function. +For a variable defined with `defcustom', it does not pay attention to +any :set property that the variable might have (if you want that, use +\\[customize-set-variable] instead). + With a prefix argument, set VARIABLE to VALUE buffer-locally." (interactive (let* ((default-var (variable-at-point)) @@ -7252,8 +7595,8 @@ With a prefix argument, set VARIABLE to VALUE buffer-locally." (require 'cus-edit) (setq type (widget-convert type)) (unless (widget-apply type :match value) - (error "Value `%S' does not match type %S of %S" - value (car type) variable)))) + (user-error "Value `%S' does not match type %S of %S" + value (car type) variable)))) (if make-local (make-local-variable variable)) @@ -7576,8 +7919,7 @@ Called from `temp-buffer-show-hook'." (when completion-show-help (goto-char (point-min)) (if (display-mouse-p) - (insert (substitute-command-keys - "Click on a completion to select it.\n"))) + (insert "Click on a completion to select it.\n")) (insert (substitute-command-keys "In this buffer, type \\[choose-completion] to \ select the completion near point.\n\n")))))) @@ -8126,7 +8468,7 @@ version and use the one distributed with Emacs.")) Each element has the form (PACKAGE SYMBOL REGEXP STRING). PACKAGE is either a regular expression to match file names, or a symbol (a feature name), like for `with-eval-after-load'. -SYMBOL is either the name of a string variable, or `t'. Upon +SYMBOL is either the name of a string variable, or t. Upon loading PACKAGE, if SYMBOL is t or matches REGEXP, display a warning using STRING as the message.") @@ -8210,21 +8552,55 @@ contains the list of implementations currently supported for this command." (interactive "P") (when (or arg (null ,varimp-sym)) (let ((val (completing-read - ,(format "Select implementation for command `%s': " - command-name) + ,(format-message + "Select implementation for command `%s': " + command-name) ,varalt-sym nil t))) (unless (string-equal val "") (when (null ,varimp-sym) (message - "Use `C-u M-x %s RET' to select another implementation" + "Use C-u M-x %s RET`to select another implementation" ,command-name) (sit-for 3)) (customize-save-variable ',varimp-sym (cdr (assoc-string val ,varalt-sym)))))) (if ,varimp-sym (call-interactively ,varimp-sym) - (message ,(format "No implementation selected for command `%s'" - command-name))))))) + (message "%s" ,(format-message + "No implementation selected for command `%s'" + command-name))))))) + + +;;; Functions for changing capitalization that Do What I Mean +(defun upcase-dwim (arg) + "Upcase words in the region, if active; if not, upcase word at point. +If the region is active, this function calls `upcase-region'. +Otherwise, it calls `upcase-word', with prefix argument passed to it +to upcase ARG words." + (interactive "*p") + (if (use-region-p) + (upcase-region (region-beginning) (region-end)) + (upcase-word arg))) + +(defun downcase-dwim (arg) + "Downcase words in the region, if active; if not, downcase word at point. +If the region is active, this function calls `downcase-region'. +Otherwise, it calls `downcase-word', with prefix argument passed to it +to downcase ARG words." + (interactive "*p") + (if (use-region-p) + (downcase-region (region-beginning) (region-end)) + (downcase-word arg))) + +(defun capitalize-dwim (arg) + "Capitalize words in the region, if active; if not, capitalize word at point. +If the region is active, this function calls `capitalize-region'. +Otherwise, it calls `capitalize-word', with prefix argument passed to it +to capitalize ARG words." + (interactive "*p") + (if (use-region-p) + (capitalize-region (region-beginning) (region-end)) + (capitalize-word arg)))