"Parent major mode from which special major modes should inherit."
(setq buffer-read-only t))
-;; Major mode meant to be the parent of programming modes.
-
-(defvar prog-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map [?\C-\M-q] 'prog-indent-sexp)
- map)
- "Keymap used for programming modes.")
-
-(defun prog-indent-sexp (&optional defun)
- "Indent the expression after point.
-When interactively called with prefix, indent the enclosing defun
-instead."
- (interactive "P")
- (save-excursion
- (when defun
- (end-of-line)
- (beginning-of-defun))
- (let ((start (point))
- (end (progn (forward-sexp 1) (point))))
- (indent-region start end nil))))
-
-(define-derived-mode prog-mode fundamental-mode "Prog"
- "Major mode for editing programming language source code."
- (set (make-local-variable 'require-final-newline) mode-require-final-newline)
- (set (make-local-variable 'parse-sexp-ignore-comments) t)
- (make-local-variable 'prog-prettify-symbols-alist)
- ;; Any programming language is always written left to right.
- (setq bidi-paragraph-direction 'left-to-right))
-
-(defvar prog-prettify-symbols-alist nil)
-
-(defcustom prog-prettify-symbols nil
- "Whether symbols should be prettified.
-When set to an alist in the form `(STRING . CHARACTER)' it will
-augment the mode's native prettify alist."
- :type '(choice
- (const :tag "No thanks" nil)
- (const :tag "Mode defaults" t)
- (alist :tag "Mode defaults augmented with your own list"
- :key-type string :value-type character))
- :group 'languages)
-
-(defun prog--prettify-font-lock-compose-symbol (alist)
- "Compose a sequence of ascii chars into a symbol.
-Regexp match data 0 points to the chars."
- ;; Check that the chars should really be composed into a symbol.
- (let* ((start (match-beginning 0))
- (end (match-end 0))
- (syntaxes (if (eq (char-syntax (char-after start)) ?w)
- '(?w) '(?. ?\\))))
- (if (or (memq (char-syntax (or (char-before start) ?\ )) syntaxes)
- (memq (char-syntax (or (char-after end) ?\ )) syntaxes)
- (nth 8 (syntax-ppss)))
- ;; No composition for you. Let's actually remove any composition
- ;; we may have added earlier and which is now incorrect.
- (remove-text-properties start end '(composition))
- ;; That's a symbol alright, so add the composition.
- (compose-region start end (cdr (assoc (match-string 0) alist)))))
- ;; Return nil because we're not adding any face property.
- nil)
-
-(defun prog-prettify-font-lock-symbols-keywords ()
- (when prog-prettify-symbols
- (let ((alist (append prog-prettify-symbols-alist
- (if (listp prog-prettify-symbols)
- prog-prettify-symbols
- nil))))
- `((,(regexp-opt (mapcar 'car alist) t)
- (0 (prog--prettify-font-lock-compose-symbol ',alist)))))))
-
;; Making and deleting lines.
(defvar hard-newline (propertize "\n" 'hard t 'rear-nonsticky '(hard))
"Propertized string representing a hard newline character.")
-(defun newline (&optional arg)
+(defun newline (&optional arg interactive)
"Insert a newline, and move to left margin of the new line if it's blank.
If option `use-hard-newlines' is non-nil, the newline is marked with the
text-property `hard'.
With ARG, insert that many newlines.
Call `auto-fill-function' if the current column number is greater
-than the value of `fill-column' and ARG is nil."
- (interactive "*P")
+than the value of `fill-column' and ARG is nil.
+A non-nil INTERACTIVE argument means to run the `post-self-insert-hook'."
+ (interactive "*P\np")
(barf-if-buffer-read-only)
;; Call self-insert so that auto-fill, abbrev expansion etc. happens.
;; Set last-command-event to tell self-insert what to insert.
;; starts a page.
(or was-page-start
(move-to-left-margin nil t)))))
- (unwind-protect
- (progn
- (add-hook 'post-self-insert-hook postproc)
+ (if (not interactive)
+ ;; FIXME: For non-interactive uses, many calls actually just want
+ ;; (insert "\n"), so maybe we should do just that, so as to avoid
+ ;; the risk of filling or running abbrevs unexpectedly.
+ (let ((post-self-insert-hook (list postproc)))
(self-insert-command (prefix-numeric-value arg)))
- ;; We first used let-binding to protect the hook, but that was naive
- ;; since add-hook affects the symbol-default value of the variable,
- ;; whereas the let-binding might only protect the buffer-local value.
- (remove-hook 'post-self-insert-hook postproc)))
+ (unwind-protect
+ (progn
+ (add-hook 'post-self-insert-hook postproc)
+ (self-insert-command (prefix-numeric-value arg)))
+ ;; We first used let-binding to protect the hook, but that was naive
+ ;; since add-hook affects the symbol-default value of the variable,
+ ;; whereas the let-binding might only protect the buffer-local value.
+ (remove-hook 'post-self-insert-hook postproc))))
nil)
(defun set-hard-newline-properties (from to)
(delete-horizontal-space t))
(indent-according-to-mode)))
+(defcustom read-quoted-char-radix 8
+ "*Radix for \\[quoted-insert] and other uses of `read-quoted-char'.
+Legitimate radix values are 8, 10 and 16."
+ :type '(choice (const 8) (const 10) (const 16))
+ :group 'editing-basics)
+
+(defun read-quoted-char (&optional prompt)
+ "Like `read-char', but do not allow quitting.
+Also, if the first character read is an octal digit,
+we read any number of octal digits and return the
+specified character code. Any nondigit terminates the sequence.
+If the terminator is RET, it is discarded;
+any other terminator is used itself as input.
+
+The optional argument PROMPT specifies a string to use to prompt the user.
+The variable `read-quoted-char-radix' controls which radix to use
+for numeric input."
+ (let ((message-log-max nil) done (first t) (code 0) translated)
+ (while (not done)
+ (let ((inhibit-quit first)
+ ;; Don't let C-h get the help message--only help function keys.
+ (help-char nil)
+ (help-form
+ "Type the special character you want to use,
+or the octal character code.
+RET terminates the character code and is discarded;
+any other non-digit terminates the character code and is then used as input."))
+ (setq translated (read-key (and prompt (format "%s-" prompt))))
+ (if inhibit-quit (setq quit-flag nil)))
+ (if (integerp translated)
+ (setq translated (char-resolve-modifiers translated)))
+ (cond ((null translated))
+ ((not (integerp translated))
+ (setq unread-command-events
+ (listify-key-sequence (this-single-command-raw-keys))
+ done t))
+ ((/= (logand translated ?\M-\^@) 0)
+ ;; Turn a meta-character into a character with the 0200 bit set.
+ (setq code (logior (logand translated (lognot ?\M-\^@)) 128)
+ done t))
+ ((and (<= ?0 translated)
+ (< translated (+ ?0 (min 10 read-quoted-char-radix))))
+ (setq code (+ (* code read-quoted-char-radix) (- translated ?0)))
+ (and prompt (setq prompt (message "%s %c" prompt translated))))
+ ((and (<= ?a (downcase translated))
+ (< (downcase translated)
+ (+ ?a -10 (min 36 read-quoted-char-radix))))
+ (setq code (+ (* code read-quoted-char-radix)
+ (+ 10 (- (downcase translated) ?a))))
+ (and prompt (setq prompt (message "%s %c" prompt translated))))
+ ((and (not first) (eq translated ?\C-m))
+ (setq done t))
+ ((not first)
+ (setq unread-command-events
+ (listify-key-sequence (this-single-command-raw-keys))
+ done t))
+ (t (setq code translated
+ done t)))
+ (setq first nil))
+ code))
+
(defun quoted-insert (arg)
"Read next input character and insert it.
This is useful for inserting control characters.
:group 'killing
:version "24.1")
+(defvar region-extract-function
+ (lambda (delete)
+ (when (region-beginning)
+ (if (eq delete 'delete-only)
+ (delete-region (region-beginning) (region-end))
+ (filter-buffer-substring (region-beginning) (region-end) delete))))
+ "Function to get the region's content.
+Called with one argument DELETE.
+If DELETE is `delete-only', then only delete the region and the return value
+is undefined. If DELETE is nil, just return the content as a string.
+If anything else, delete the region and return its content as a string.")
+
(defun delete-backward-char (n &optional killflag)
"Delete the previous N characters (following if N is negative).
If Transient Mark mode is enabled, the mark is active, and N is 1,
(= n 1))
;; If a region is active, kill or delete it.
(if (eq delete-active-region 'kill)
- (kill-region (region-beginning) (region-end))
- (delete-region (region-beginning) (region-end))))
+ (kill-region (region-beginning) (region-end) 'region)
+ (funcall region-extract-function 'delete-only)))
;; In Overwrite mode, maybe untabify while deleting
((null (or (null overwrite-mode)
(<= n 0)
(= n 1))
;; If a region is active, kill or delete it.
(if (eq delete-active-region 'kill)
- (kill-region (region-beginning) (region-end))
- (delete-region (region-beginning) (region-end))))
+ (kill-region (region-beginning) (region-end) 'region)
+ (funcall region-extract-function 'delete-only)))
+
;; Otherwise, do simple deletion.
(t (delete-char n killflag))))
Such arguments are used as in `read-from-minibuffer'.)"
;; Used for interactive spec `x'.
(read-from-minibuffer prompt initial-contents minibuffer-local-map
- t minibuffer-history))
+ t 'minibuffer-history))
(defun eval-minibuffer (prompt &optional initial-contents)
"Return value of Lisp expression read using the minibuffer.
;; add it to the history.
(or (equal newcmd (car command-history))
(setq command-history (cons newcmd command-history)))
- (eval newcmd))
+ (unwind-protect
+ (progn
+ ;; Trick called-interactively-p into thinking that `newcmd' is
+ ;; an interactive call (bug#14136).
+ (add-hook 'called-interactively-p-functions
+ #'repeat-complex-command--called-interactively-skip)
+ (eval newcmd))
+ (remove-hook 'called-interactively-p-functions
+ #'repeat-complex-command--called-interactively-skip)))
(if command-history
(error "Argument %d is beyond length of command history" arg)
(error "There are no previous complex commands to repeat")))))
+(defun repeat-complex-command--called-interactively-skip (i _frame1 frame2)
+ (and (eq 'eval (cadr frame2))
+ (eq 'repeat-complex-command
+ (cadr (backtrace-frame i #'called-interactively-p)))
+ 1))
+
(defvar extended-command-history nil)
(defun read-extended-command ()
Command Output*' is deleted.
Optional fourth arg OUTPUT-BUFFER specifies where to put the
-command's output. If the value is a buffer or buffer name, put
-the output there. Any other value, excluding nil, means to
-insert the output in the current buffer. In either case, the
-output is inserted after point (leaving mark after it).
+command's output. If the value is a buffer or buffer name,
+put the output there. If the value is nil, use the buffer
+`*Shell Command Output*'. Any other value, excluding nil,
+means to insert the output in the current buffer. In either case,
+the output is inserted after point (leaving mark after it).
Optional fifth arg REPLACE, if non-nil, means to insert the
output in place of text from START to END, putting point and mark
(display-buffer (button-get button 'process-buffer)))
(defun list-processes (&optional query-only buffer)
- "Display a list of all processes.
+ "Display a list of all processes that are Emacs sub-processes.
If optional argument QUERY-ONLY is non-nil, only processes with
the query-on-exit flag set are listed.
Any process listed as exited or signaled is actually eliminated
after the listing is made.
Optional argument BUFFER specifies a buffer to use, instead of
\"*Process List*\".
-The return value is always nil."
+The return value is always nil.
+
+This function lists only processes that were launched by Emacs. To
+see other processes running on the system, use `list-system-processes'."
(interactive)
(or (fboundp 'process-list)
(error "Asynchronous subprocesses are not supported on this system"))
nil)
\f
(defvar universal-argument-map
- (let ((map (make-sparse-keymap)))
- (define-key map [t] 'universal-argument-other-key)
- (define-key map (vector meta-prefix-char t) 'universal-argument-other-key)
- (define-key map [switch-frame] nil)
+ (let ((map (make-sparse-keymap))
+ (universal-argument-minus
+ ;; For backward compatibility, minus with no modifiers is an ordinary
+ ;; command if digits have already been entered.
+ `(menu-item "" negative-argument
+ :filter ,(lambda (cmd)
+ (if (integerp prefix-arg) nil cmd)))))
+ (define-key map [switch-frame]
+ (lambda (e) (interactive "e")
+ (handle-switch-frame e) (universal-argument--mode)))
(define-key map [?\C-u] 'universal-argument-more)
- (define-key map [?-] 'universal-argument-minus)
+ (define-key map [?-] universal-argument-minus)
(define-key map [?0] 'digit-argument)
(define-key map [?1] 'digit-argument)
(define-key map [?2] 'digit-argument)
(define-key map [kp-7] 'digit-argument)
(define-key map [kp-8] 'digit-argument)
(define-key map [kp-9] 'digit-argument)
- (define-key map [kp-subtract] 'universal-argument-minus)
+ (define-key map [kp-subtract] universal-argument-minus)
map)
"Keymap used while processing \\[universal-argument].")
-(defvar universal-argument-num-events nil
- "Number of argument-specifying events read by `universal-argument'.
-`universal-argument-other-key' uses this to discard those events
-from (this-command-keys), and reread only the final command.")
-
-(defvar saved-overriding-map t
- "The saved value of `overriding-terminal-local-map'.
-That variable gets restored to this value on exiting \"universal
-argument mode\".")
-
-(defun save&set-overriding-map (map)
- "Set `overriding-terminal-local-map' to MAP."
- (when (eq saved-overriding-map t)
- (setq saved-overriding-map overriding-terminal-local-map)
- (setq overriding-terminal-local-map map)))
-
-(defun restore-overriding-map ()
- "Restore `overriding-terminal-local-map' to its saved value."
- (setq overriding-terminal-local-map saved-overriding-map)
- (setq saved-overriding-map t))
+(defun universal-argument--mode ()
+ (set-temporary-overlay-map universal-argument-map))
(defun universal-argument ()
"Begin a numeric argument for the following command.
These commands include \\[set-mark-command] and \\[start-kbd-macro]."
(interactive)
(setq prefix-arg (list 4))
- (setq universal-argument-num-events (length (this-command-keys)))
- (save&set-overriding-map universal-argument-map))
+ (universal-argument--mode))
-;; 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.
(defun universal-argument-more (arg)
+ ;; 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")
- (if (consp arg)
- (setq prefix-arg (list (* 4 (car arg))))
- (if (eq arg '-)
- (setq prefix-arg (list -4))
- (setq prefix-arg arg)
- (restore-overriding-map)))
- (setq universal-argument-num-events (length (this-command-keys))))
+ (setq prefix-arg (if (consp arg)
+ (list (* 4 (car arg)))
+ (if (eq arg '-)
+ (list -4)
+ arg)))
+ (when (consp prefix-arg) (universal-argument--mode)))
(defun negative-argument (arg)
"Begin a negative numeric argument for the next command.
\\[universal-argument] following digits or minus sign ends the argument."
(interactive "P")
- (cond ((integerp arg)
- (setq prefix-arg (- arg)))
- ((eq arg '-)
- (setq prefix-arg nil))
- (t
- (setq prefix-arg '-)))
- (setq universal-argument-num-events (length (this-command-keys)))
- (save&set-overriding-map universal-argument-map))
+ (setq prefix-arg (cond ((integerp arg) (- arg))
+ ((eq arg '-) nil)
+ (t '-)))
+ (universal-argument--mode))
(defun digit-argument (arg)
"Part of the numeric argument for the next command.
last-command-event
(get last-command-event 'ascii-character)))
(digit (- (logand char ?\177) ?0)))
- (cond ((integerp arg)
- (setq prefix-arg (+ (* arg 10)
- (if (< arg 0) (- digit) digit))))
- ((eq arg '-)
- ;; Treat -0 as just -, so that -01 will work.
- (setq prefix-arg (if (zerop digit) '- (- digit))))
- (t
- (setq prefix-arg digit))))
- (setq universal-argument-num-events (length (this-command-keys)))
- (save&set-overriding-map universal-argument-map))
-
-;; For backward compatibility, minus with no modifiers is an ordinary
-;; command if digits have already been entered.
-(defun universal-argument-minus (arg)
- (interactive "P")
- (if (integerp arg)
- (universal-argument-other-key arg)
- (negative-argument arg)))
-
-;; Anything else terminates the argument and is left in the queue to be
-;; executed as a command.
-(defun universal-argument-other-key (arg)
- (interactive "P")
- (setq prefix-arg arg)
- (let* ((key (this-command-keys))
- (keylist (listify-key-sequence key)))
- (setq unread-command-events
- (append (nthcdr universal-argument-num-events keylist)
- unread-command-events)))
- (reset-this-command-lengths)
- (restore-overriding-map))
+ (setq prefix-arg (cond ((integerp arg)
+ (+ (* arg 10)
+ (if (< arg 0) (- digit) digit)))
+ ((eq arg '-)
+ ;; Treat -0 as just -, so that -01 will work.
+ (if (zerop digit) '- (- digit)))
+ (t
+ digit))))
+ (universal-argument--mode))
\f
(defvar filter-buffer-substring-functions nil
be copied into other buffers."
(funcall filter-buffer-substring-function beg end delete))
+;; FIXME: `with-wrapper-hook' is obsolete
(defun buffer-substring--filter (beg end &optional delete)
(with-wrapper-hook filter-buffer-substring-functions (beg end delete)
(cond
:group 'killing
:version "23.2")
-(defun kill-new (string &optional replace yank-handler)
+(defun kill-new (string &optional replace)
"Make STRING the latest kill in the kill ring.
Set `kill-ring-yank-pointer' to point to it.
If `interprogram-cut-function' is non-nil, apply it to STRING.
argument is not used by `insert-for-yank'. However, since Lisp code
may access and use elements from the kill ring directly, the STRING
argument should still be a \"useful\" string for such uses."
- (if (> (length string) 0)
- (if yank-handler
- (put-text-property 0 (length string)
- 'yank-handler yank-handler string))
- (if yank-handler
- (signal 'args-out-of-range
- (list string "yank-handler specified for empty string"))))
(unless (and kill-do-not-save-duplicates
;; Due to text properties such as 'yank-handler that
;; can alter the contents to yank, comparison using
(setq kill-ring-yank-pointer kill-ring)
(if interprogram-cut-function
(funcall interprogram-cut-function string)))
-(set-advertised-calling-convention
- 'kill-new '(string &optional replace) "23.3")
-(defun kill-append (string before-p &optional yank-handler)
+(defun kill-append (string before-p)
"Append STRING to the end of the latest kill in the kill ring.
If BEFORE-P is non-nil, prepend STRING to the kill.
If `interprogram-cut-function' is set, pass the resulting kill to it."
(let* ((cur (car kill-ring)))
(kill-new (if before-p (concat string cur) (concat cur string))
(or (= (length cur) 0)
- (equal yank-handler (get-text-property 0 'yank-handler cur)))
- yank-handler)))
-(set-advertised-calling-convention 'kill-append '(string before-p) "23.3")
+ (equal nil (get-text-property 0 'yank-handler cur))))))
(defcustom yank-pop-change-selection nil
"Whether rotating the kill ring changes the window system selection.
:type 'boolean
:group 'killing)
-(defun kill-region (beg end &optional yank-handler)
+(defun kill-region (beg end &optional region)
"Kill (\"cut\") text between point and mark.
This deletes the text from the buffer and saves it in the kill ring.
The command \\[yank] can retrieve it from there.
Any command that calls this function is a \"kill command\".
If the previous command was also a kill command,
the text killed this time appends to the text killed last time
-to make one entry in the kill ring."
+to make one entry in the kill ring.
+
+The optional argument REGION if non-nil, indicates that we're not just killing
+some text between BEG and END, but we're killing the region."
;; Pass point first, then mark, because the order matters
;; when calling kill-append.
- (interactive (list (point) (mark)))
+ (interactive (list (point) (mark) 'region))
(unless (and beg end)
(error "The mark is not set now, so there is no region"))
(condition-case nil
- (let ((string (filter-buffer-substring beg end t)))
+ (let ((string (if region
+ (funcall region-extract-function 'delete)
+ (filter-buffer-substring beg end 'delete))))
(when string ;STRING is nil if BEG = END
;; Add that string to the kill ring, one way or another.
(if (eq last-command 'kill-region)
- (kill-append string (< end beg) yank-handler)
- (kill-new string nil yank-handler)))
+ (kill-append string (< end beg))
+ (kill-new string nil)))
(when (or string (eq last-command 'kill-region))
(setq this-command 'kill-region))
(setq deactivate-mark t)
;; We should beep, in case the user just isn't aware of this.
;; However, there's no harm in putting
;; the region's text in the kill ring, anyway.
- (copy-region-as-kill beg end)
+ (copy-region-as-kill beg end region)
;; Set this-command now, so it will be set even if we get an error.
(setq this-command 'kill-region)
;; This should barf, if appropriate, and give us the correct error.
(barf-if-buffer-read-only)
;; If the buffer isn't read-only, the text is.
(signal 'text-read-only (list (current-buffer)))))))
-(set-advertised-calling-convention 'kill-region '(beg end) "23.3")
;; copy-region-as-kill no longer sets this-command, because it's confusing
;; to get two copies of the text when the user accidentally types M-w and
;; then corrects it with the intended C-w.
-(defun copy-region-as-kill (beg end)
+(defun copy-region-as-kill (beg end &optional region)
"Save the region as if killed, but don't kill it.
In Transient Mark mode, deactivate the mark.
If `interprogram-cut-function' is non-nil, also save the text for a window
system cut and paste.
+The optional argument REGION if non-nil, indicates that we're not just copying
+some text between BEG and END, but we're copying the region.
+
This command's old key binding has been given to `kill-ring-save'."
- (interactive "r")
+ (interactive "r\np")
+ (let ((str (if region
+ (funcall region-extract-function nil)
+ (filter-buffer-substring beg end))))
(if (eq last-command 'kill-region)
- (kill-append (filter-buffer-substring beg end) (< end beg))
- (kill-new (filter-buffer-substring beg end)))
+ (kill-append str (< end beg))
+ (kill-new str)))
(setq deactivate-mark t)
nil)
-(defun kill-ring-save (beg end)
+(defun kill-ring-save (beg end &optional region)
"Save the region as if killed, but don't kill it.
In Transient Mark mode, deactivate the mark.
If `interprogram-cut-function' is non-nil, also save the text for a window
If you want to append the killed line to the last killed text,
use \\[append-next-kill] before \\[kill-ring-save].
+The optional argument REGION if non-nil, indicates that we're not just copying
+some text between BEG and END, but we're copying the region.
+
This command is similar to `copy-region-as-kill', except that it gives
visual feedback indicating the extent of the region being copied."
- (interactive "r")
- (copy-region-as-kill beg end)
+ (interactive "r\np")
+ (copy-region-as-kill beg end region)
;; This use of called-interactively-p is correct because the code it
;; controls just gives the user visual feedback.
(if (called-interactively-p 'interactive)
(progn
(barf-if-buffer-read-only)
(read-buffer "Insert buffer: "
- (if (eq (selected-window) (next-window (selected-window)))
+ (if (eq (selected-window) (next-window))
(other-buffer (current-buffer))
- (window-buffer (next-window (selected-window))))
+ (window-buffer (next-window)))
t))))
(push-mark
(save-excursion
(save-excursion
(insert-buffer-substring oldbuf start end)))))
\f
-(put 'mark-inactive 'error-conditions '(mark-inactive error))
-(put 'mark-inactive 'error-message (purecopy "The mark is not active now"))
+(define-error 'mark-inactive (purecopy "The mark is not active now"))
(defvar activate-mark-hook nil
"Hook run when the mark becomes active.
(marker-position (mark-marker))
(signal 'mark-inactive nil)))
+;; Behind display-selections-p.
+(declare-function x-selection-owner-p "xselect.c"
+ (&optional selection terminal))
+(declare-function x-selection-exists-p "xselect.c"
+ (&optional selection terminal))
+
(defun deactivate-mark (&optional force)
"Deactivate the mark.
If Transient Mark mode is disabled, this function normally does
(or (x-selection-owner-p 'PRIMARY)
(null (x-selection-exists-p 'PRIMARY))))
(x-set-selection 'PRIMARY
- (buffer-substring (region-beginning)
- (region-end))))))
+ (funcall region-extract-function nil)))))
(if (and (null force)
(or (eq transient-mark-mode 'lambda)
(and (eq (car-safe transient-mark-mode) 'only)
also checks the value of `use-empty-active-region'."
(and transient-mark-mode mark-active))
-(defvar mark-ring nil
+
+(defvar redisplay-unhighlight-region-function
+ (lambda (rol) (when (overlayp rol) (delete-overlay rol))))
+
+(defvar redisplay-highlight-region-function
+ (lambda (start end window rol)
+ (if (not (overlayp rol))
+ (let ((nrol (make-overlay start end)))
+ (funcall redisplay-unhighlight-region-function rol)
+ (overlay-put nrol 'window window)
+ (overlay-put nrol 'face 'region)
+ nrol)
+ (unless (and (eq (overlay-buffer rol) (current-buffer))
+ (eq (overlay-start rol) start)
+ (eq (overlay-end rol) end))
+ (move-overlay rol start end (current-buffer)))
+ 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"
+ (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)))))))))
+
+(add-function :before pre-redisplay-function
+ #'redisplay--update-region-highlights)
+
+
+(defvar-local mark-ring nil
"The list of former marks of the current buffer, most recent first.")
-(make-variable-buffer-local 'mark-ring)
(put 'mark-ring 'permanent-local t)
(defcustom mark-ring-max 16
(temp-highlight (eq (car-safe transient-mark-mode) 'only)))
(if (null omark)
(error "No mark set in this buffer"))
- (deactivate-mark)
(set-mark (point))
(goto-char omark)
(cond (temp-highlight
(defun next-line (&optional arg try-vscroll)
"Move cursor vertically down ARG lines.
Interactively, vscroll tall lines if `auto-window-vscroll' is enabled.
+Non-interactively, use TRY-VSCROLL to control whether to vscroll tall
+lines: if either `auto-window-vscroll' or TRY-VSCROLL is nil, this
+function will not vscroll.
+
+ARG defaults to 1.
+
If there is no character in the target line exactly under the current column,
the cursor is positioned after the character in that line which spans this
column, or at the end of the line if it is not long enough.
(defun previous-line (&optional arg try-vscroll)
"Move cursor vertically up ARG lines.
Interactively, vscroll tall lines if `auto-window-vscroll' is enabled.
+Non-interactively, use TRY-VSCROLL to control whether to vscroll tall
+lines: if either `auto-window-vscroll' or TRY-VSCROLL is nil, this
+function will not vscroll.
+
+ARG defaults to 1.
+
If there is no character in the target line exactly over the current column,
the cursor is positioned after the character in that line which spans this
column, or at the end of the line if it is not long enough.
:group 'editing-basics
:version "23.1")
+;; Only used if display-graphic-p.
+(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."
+ (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)))
+ (aref (font-info default-font) 3))
+ (t (frame-char-height)))))
+
+(defun default-line-height ()
+ "Return the pixel height of current buffer's default-face text line.
+
+The value includes `line-spacing', if any, defined for the buffer
+or the frame."
+ (let ((dfh (default-font-height))
+ (lsp (if (display-graphic-p)
+ (or line-spacing
+ (default-value 'line-spacing)
+ (frame-parameter nil 'line-spacing)
+ 0)
+ 0)))
+ (if (floatp lsp)
+ (setq lsp (* dfh lsp)))
+ (+ dfh lsp)))
+
+(defun window-screen-lines ()
+ "Return the number of screen lines in the text area of the selected window.
+
+This is different from `window-text-height' in that this function counts
+lines in units of the height of the font used by the default face displayed
+in the window, not in units of the frame's default font, and also accounts
+for `line-spacing', if any, defined for the window's buffer or frame.
+
+The value is a floating-point number."
+ (let ((canonical (window-text-height))
+ (fch (frame-char-height))
+ (dlh (default-line-height)))
+ (/ (* (float canonical) fch) dlh)))
+
;; Returns non-nil if partial move was done.
(defun line-move-partial (arg noerror to-end)
(if (< arg 0)
;; Move backward (up).
;; If already vscrolled, reduce vscroll
- (let ((vs (window-vscroll nil t)))
- (when (> vs (frame-char-height))
- (set-window-vscroll nil (- vs (frame-char-height)) t)))
+ (let ((vs (window-vscroll nil t))
+ (dlh (default-line-height)))
+ (when (> vs dlh)
+ (set-window-vscroll nil (- vs dlh) t)))
;; Move forward (down).
(let* ((lh (window-line-height -1))
+ (rowh (car lh))
(vpos (nth 1 lh))
(ypos (nth 2 lh))
(rbot (nth 3 lh))
- py vs)
+ (this-lh (window-line-height))
+ (this-height (car this-lh))
+ (this-ypos (nth 2 this-lh))
+ (dlh (default-line-height))
+ (wslines (window-screen-lines))
+ (edges (window-inside-pixel-edges))
+ (winh (- (nth 3 edges) (nth 1 edges) 1))
+ py vs last-line)
+ (if (> (mod wslines 1.0) 0.0)
+ (setq wslines (round (+ wslines 0.5))))
(when (or (null lh)
- (>= rbot (frame-char-height))
- (<= ypos (- (frame-char-height))))
+ (>= rbot dlh)
+ (<= ypos (- dlh))
+ (null this-lh)
+ (<= this-ypos (- dlh)))
(unless lh
(let ((wend (pos-visible-in-window-p t nil t)))
(setq rbot (nth 3 wend)
+ rowh (nth 4 wend)
vpos (nth 5 wend))))
+ (unless this-lh
+ (let ((wstart (pos-visible-in-window-p nil nil t)))
+ (setq this-ypos (nth 2 wstart)
+ this-height (nth 4 wstart))))
+ (setq py
+ (or (nth 1 this-lh)
+ (let ((ppos (posn-at-point))
+ col-row)
+ (setq col-row (posn-actual-col-row ppos))
+ (if col-row
+ (- (cdr col-row) (window-vscroll))
+ (cdr (posn-col-row ppos))))))
+ ;; VPOS > 0 means the last line is only partially visible.
+ ;; But if the part that is visible is at least as tall as the
+ ;; default font, that means the line is actually fully
+ ;; readable, and something like line-spacing is hidden. So in
+ ;; that case we accept the last line in the window as still
+ ;; visible, and consider the margin as starting one line
+ ;; later.
+ (if (and vpos (> vpos 0))
+ (if (and rowh
+ (>= rowh (default-font-height))
+ (< rowh dlh))
+ (setq last-line (min (- wslines scroll-margin) vpos))
+ (setq last-line (min (- wslines scroll-margin 1) (1- vpos)))))
(cond
- ;; If last line of window is fully visible, move forward.
- ((or (null rbot) (= rbot 0))
+ ;; If last line of window is fully visible, and vscrolling
+ ;; more would make this line invisible, move forward.
+ ((and (or (< (setq vs (window-vscroll nil t)) dlh)
+ (null this-height)
+ (<= this-height dlh))
+ (or (null rbot) (= rbot 0)))
nil)
- ;; If cursor is not in the bottom scroll margin, move forward.
- ((and (> vpos 0)
- (< (setq py
- (or (nth 1 (window-line-height))
- (let ((ppos (posn-at-point)))
- (cdr (or (posn-actual-col-row ppos)
- (posn-col-row ppos))))))
- (min (- (window-text-height) scroll-margin 1) (1- vpos))))
+ ;; If cursor is not in the bottom scroll margin, and the
+ ;; current line is is not too tall, move forward.
+ ((and (or (null this-height) (<= this-height winh))
+ vpos
+ (> vpos 0)
+ (< py last-line))
nil)
;; When already vscrolled, we vscroll some more if we can,
;; or clear vscroll and move forward at end of tall image.
- ((> (setq vs (window-vscroll nil t)) 0)
- (when (> rbot 0)
- (set-window-vscroll nil (+ vs (min rbot (frame-char-height))) t)))
+ ((> vs 0)
+ (when (or (and rbot (> rbot 0))
+ (and this-height (> this-height dlh)))
+ (set-window-vscroll nil (+ vs dlh) t)))
;; If cursor just entered the bottom scroll margin, move forward,
- ;; but also vscroll one line so redisplay won't recenter.
- ((and (> vpos 0)
- (= py (min (- (window-text-height) scroll-margin 1)
- (1- vpos))))
- (set-window-vscroll nil (frame-char-height) t)
+ ;; but also optionally vscroll one line so redisplay won't recenter.
+ ((and vpos
+ (> vpos 0)
+ (= py last-line))
+ ;; Don't vscroll if the partially-visible line at window
+ ;; bottom is not too tall (a.k.a. "just one more text
+ ;; line"): in that case, we do want redisplay to behave
+ ;; normally, i.e. recenter or whatever.
+ ;;
+ ;; Note: ROWH + RBOT from the value returned by
+ ;; pos-visible-in-window-p give the total height of the
+ ;; partially-visible glyph row at the end of the window. As
+ ;; we are dealing with floats, we disregard sub-pixel
+ ;; discrepancies between that and DLH.
+ (if (and rowh rbot (>= (- (+ rowh rbot) winh) 1))
+ (set-window-vscroll nil dlh t))
(line-move-1 arg noerror to-end)
t)
;; If there are lines above the last line, scroll-up one line.
- ((> vpos 0)
+ ((and vpos (> vpos 0))
(scroll-up 1)
t)
;; Finally, start vscroll.
(t
- (set-window-vscroll nil (frame-char-height) t)))))))
+ (set-window-vscroll nil dlh t)))))))
;; This is like line-move-1 except that it also performs
;; When the text in the window is scrolled to the left,
;; display-based motion doesn't make sense (because each
;; logical line occupies exactly one screen line).
- (not (> (window-hscroll) 0)))
- (line-move-visual arg noerror)
+ (not (> (window-hscroll) 0))
+ ;; Likewise when the text _was_ scrolled to the left
+ ;; when the current run of vertical motion commands
+ ;; started.
+ (not (and (memq last-command
+ `(next-line previous-line ,this-command))
+ auto-hscroll-mode
+ (numberp temporary-goal-column)
+ (>= temporary-goal-column
+ (- (window-width) hscroll-margin)))))
+ (prog1 (line-move-visual arg noerror)
+ ;; If we moved into a tall line, set vscroll to make
+ ;; scrolling through tall images more smooth.
+ (let ((lh (line-pixel-height))
+ (edges (window-inside-pixel-edges))
+ (dlh (default-line-height))
+ winh)
+ (setq winh (- (nth 3 edges) (nth 1 edges) 1))
+ (if (and (< arg 0)
+ (< (point) (window-start))
+ (> lh winh))
+ (set-window-vscroll
+ nil
+ (- lh dlh) t))))
(line-move-1 arg noerror to-end)))))
;; Display-based alternative to line-move-1.
(visual-line-mode 1))
(define-globalized-minor-mode global-visual-line-mode
- visual-line-mode turn-on-visual-line-mode
- :lighter " vl")
+ visual-line-mode turn-on-visual-line-mode)
\f
(defun transpose-chars (arg)
\f
(defun backward-word (&optional arg)
"Move backward until encountering the beginning of a word.
-With argument ARG, do this that many times."
+With argument ARG, do this that many times.
+If ARG is omitted or nil, move point backward one word."
(interactive "^p")
(forward-word (- (or arg 1))))
(setq selective-display
(and arg (prefix-numeric-value arg)))
(recenter current-vpos))
- (set-window-start (selected-window) (window-start (selected-window)))
+ (set-window-start (selected-window) (window-start))
(princ "selective-display set to " t)
(prin1 selective-display t)
(princ "." t))
(call-interactively `(lambda (arg)
(interactive ,prop)
arg))
- (read
- (read-string prompt nil
- 'set-variable-value-history
- (format "%S" (symbol-value var))))))))
+ (read-from-minibuffer prompt nil
+ read-expression-map t
+ 'set-variable-value-history
+ (format "%S" (symbol-value var)))))))
(list var val current-prefix-arg)))
(and (custom-variable-p variable)
(interactive)
(let ((buf completion-reference-buffer))
(if (one-window-p t)
- (if (window-dedicated-p (selected-window))
- (delete-frame (selected-frame)))
+ (if (window-dedicated-p) (delete-frame))
(delete-window (selected-window))
(if (get-buffer-window buf)
(select-window (get-buffer-window buf))))))
buffer-invisibility-spec)
(setq buffer-invisibility-spec nil)))
\f
+(defvar messages-buffer-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map special-mode-map)
+ (define-key map "g" nil) ; nothing to revert
+ map))
+
+(define-derived-mode messages-buffer-mode special-mode "Messages"
+ "Major mode used in the \"*Messages*\" buffer.")
+
+(defun messages-buffer ()
+ "Return the \"*Messages*\" buffer.
+If it does not exist, create and it switch it to `messages-buffer-mode'."
+ (or (get-buffer "*Messages*")
+ (with-current-buffer (get-buffer-create "*Messages*")
+ (messages-buffer-mode)
+ (current-buffer))))
+
+\f
;; Minibuffer prompt stuff.
;;(defun minibuffer-prompt-modification (start end)
"Alist of packages known to cause problems in this version of 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); see the documentation of
-`after-load-alist', to which this variable adds functions.
+symbol (a feature name), like for `with-eval-after-load'.
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.")
(display-warning package (nth 3 list) :warning)))
(error nil)))
-(mapc (lambda (elem)
- (eval-after-load (car elem) `(bad-package-check ',(car elem))))
- bad-packages-alist)
+(dolist (elem bad-packages-alist)
+ (let ((pkg (car elem)))
+ (with-eval-after-load pkg
+ (bad-package-check pkg))))
+
+\f
+;;; Generic dispatcher commands
+
+;; Macro `define-alternatives' is used to create generic commands.
+;; Generic commands are these (like web, mail, news, encrypt, irc, etc.)
+;; that can have different alternative implementations where choosing
+;; among them is exclusively a matter of user preference.
+;; (define-alternatives COMMAND) creates a new interactive command
+;; M-x COMMAND and a customizable variable COMMAND-alternatives.
+;; Typically, the user will not need to customize this variable; packages
+;; wanting to add alternative implementations should use
+;;
+;; ;;;###autoload (push '("My impl name" . my-impl-symbol) COMMAND-alternatives
+
+(defmacro define-alternatives (command &rest customizations)
+ "Define new command `COMMAND'.
+The variable `COMMAND-alternatives' will contain alternative
+implementations of COMMAND, so that running `C-u M-x COMMAND'
+will allow the user to chose among them.
+CUSTOMIZATIONS, if non-nil, should be composed of alternating
+`defcustom' keywords and values to add to the declaration of
+`COMMAND-alternatives' (typically :group and :version)."
+ (let* ((command-name (symbol-name command))
+ (varalt-name (concat command-name "-alternatives"))
+ (varalt-sym (intern varalt-name))
+ (varimp-sym (intern (concat command-name "--implementation"))))
+ `(progn
+
+ (defcustom ,varalt-sym nil
+ ,(format "Alist of alternative implementations for the `%s' command.
+
+Each entry must be a pair (ALTNAME . ALTFUN), where:
+ALTNAME - The name shown at user to describe the alternative implementation.
+ALTFUN - The function called to implement this alternative."
+ command-name)
+ :type '(alist :key-type string :value-type function)
+ ,@customizations)
+
+ (defvar ,varimp-sym nil "Internal use only.")
+
+ (defun ,command (&optional arg)
+ ,(format "Run generic command `%s'.
+If used for the first time, or with interactive ARG, ask the user which
+implementation to use for `%s'. The variable `%s'
+contains the list of implementations currently supported for this command."
+ command-name command-name varalt-name)
+ (interactive "P")
+ (when (or arg (null ,varimp-sym))
+ (let ((val (completing-read
+ ,(format "Select implementation for command `%s': " command-name)
+ ,varalt-sym nil t)))
+ (unless (string-equal val "")
+ (customize-save-variable ',varimp-sym
+ (cdr (assoc-string val ,varalt-sym))))))
+ (if ,varimp-sym
+ (funcall ,varimp-sym)
+ (message ,(format "No implementation selected for command `%s'"
+ command-name)))))))
(provide 'simple)
HCoop / bpt / emacs.git / blobdiff