;;; simple.el --- basic editing commands for Emacs
-;; Copyright (C) 1985, 86, 87, 93, 94, 95, 96, 97, 98, 1999
+;; Copyright (C) 1985, 86, 87, 93, 94, 95, 96, 97, 98, 99, 2000
;; Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;;; Code:
+(eval-when-compile
+ (require 'cl))
+
+
(defgroup killing nil
"Killing and yanking commands"
:group 'editing)
-(defgroup fill-comments nil
- "Indenting and filling of comments."
- :prefix "comment-"
- :group 'fill)
-
(defgroup paren-matching nil
"Highlight (un)matching of parens and expressions."
:group 'matching)
+(defun fundamental-mode ()
+ "Major mode not specialized for anything in particular.
+Other major modes are defined by comparison with this one."
+ (interactive)
+ (kill-all-local-variables))
+\f
+;; Making and deleting lines.
+
(defun newline (&optional arg)
"Insert a newline, and move to left margin of the new line if it's blank.
The newline is marked with the text-property `hard'.
;; try_window_id than inserting at the beginning of a line, and the textual
;; result is the same. So, if we're at beginning of line, pretend to be at
;; the end of the previous line.
- (let ((flag (and (not (bobp))
+ (let ((flag (and (not (bobp))
(bolp)
;; Make sure no functions want to be told about
;; the range of the changes.
- (not after-change-function)
- (not before-change-function)
(not after-change-functions)
(not before-change-functions)
;; Make sure there are no markers here.
(not (get-char-property (1- (point)) 'invisible))
;; Make sure the newline before point has the same
;; properties as the char before it (if any).
- (< (or (previous-property-change (point)) -2)
+ (< (or (previous-property-change (point)) -2)
(- (point) 2))))
(was-page-start (and (bolp)
(looking-at page-delimiter)))
(if (and (listp sticky) (not (memq 'hard sticky)))
(put-text-property from (point) 'rear-nonsticky
(cons 'hard sticky)))))
-
+\f
(defun open-line (arg)
"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
(indent-to col 0)
(goto-char pos)))
-(defun quoted-insert (arg)
- "Read next input character and insert it.
-This is useful for inserting control characters.
-
-If the first character you type after this command is an octal digit,
-you should type a sequence of octal digits which specify a character code.
-Any nondigit terminates the sequence. If the terminator is a RET,
-it is discarded; any other terminator is used itself as input.
-The variable `read-quoted-char-radix' specifies the radix for this feature;
-set it to 10 or 16 to use decimal or hex instead of octal.
-
-In overwrite mode, this function inserts the character anyway, and
-does not handle octal digits specially. This means that if you use
-overwrite as your normal editing mode, you can use this function to
-insert characters when necessary.
-
-In binary overwrite mode, this function does overwrite, and octal
-digits are interpreted as a character code. This is intended to be
-useful for editing binary files."
- (interactive "*p")
- (let ((char (if (or (not overwrite-mode)
- (eq overwrite-mode 'overwrite-mode-binary))
- (read-quoted-char)
- (read-char))))
- ;; Assume character codes 0240 - 0377 stand for characters in some
- ;; single-byte character set, and convert them to Emacs
- ;; characters.
- (if (and enable-multibyte-characters
- (>= char ?\240)
- (<= char ?\377))
- (setq char (unibyte-char-to-multibyte char)))
- (if (> arg 0)
- (if (eq overwrite-mode 'overwrite-mode-binary)
- (delete-char arg)))
- (while (> arg 0)
- (insert-and-inherit char)
- (setq arg (1- arg)))))
-
(defun delete-indentation (&optional arg)
"Join this line to previous and fix up whitespace at join.
If there is a fill prefix, delete it from the beginning of this line.
(fixup-whitespace))))
(defalias 'join-line #'delete-indentation) ; easier to find
-
-(defun fixup-whitespace ()
- "Fixup white space between objects around point.
-Leave one space or none, according to the context."
- (interactive "*")
- (save-excursion
- (delete-horizontal-space)
- (if (or (looking-at "^\\|\\s)")
- (save-excursion (forward-char -1)
- (looking-at "$\\|\\s(\\|\\s'")))
- nil
- (insert ?\ ))))
-
-(defun delete-horizontal-space ()
- "Delete all spaces and tabs around point."
- (interactive "*")
- (skip-chars-backward " \t")
- (delete-region (point) (progn (skip-chars-forward " \t") (point))))
-
-(defun just-one-space ()
- "Delete all spaces and tabs around point, leaving one space."
- (interactive "*")
- (skip-chars-backward " \t")
- (if (= (following-char) ? )
- (forward-char 1)
- (insert ? ))
- (delete-region (point) (progn (skip-chars-forward " \t") (point))))
-
+\f
(defun delete-blank-lines ()
"On blank line, delete all surrounding blank lines, leaving just one.
On isolated blank line, delete that one.
(if (looking-at "^[ \t]*\n\\'")
(delete-region (point) (point-max)))))
-(defun back-to-indentation ()
- "Move point to the first non-whitespace character on this line."
- (interactive)
- (beginning-of-line 1)
- (skip-chars-forward " \t"))
-
(defun newline-and-indent ()
"Insert a newline, then indent according to major mode.
Indentation is done using the value of `indent-line-function'.
(indent-according-to-mode))
(newline)
(indent-according-to-mode))
+\f
+(defun quoted-insert (arg)
+ "Read next input character and insert it.
+This is useful for inserting control characters.
-;; Internal subroutine of delete-char
-(defun kill-forward-chars (arg)
- (if (listp arg) (setq arg (car arg)))
- (if (eq arg '-) (setq arg -1))
- (kill-region (point) (forward-point arg)))
+If the first character you type after this command is an octal digit,
+you should type a sequence of octal digits which specify a character code.
+Any nondigit terminates the sequence. If the terminator is a RET,
+it is discarded; any other terminator is used itself as input.
+The variable `read-quoted-char-radix' specifies the radix for this feature;
+set it to 10 or 16 to use decimal or hex instead of octal.
-;; Internal subroutine of backward-delete-char
-(defun kill-backward-chars (arg)
- (if (listp arg) (setq arg (car arg)))
- (if (eq arg '-) (setq arg -1))
- (kill-region (point) (forward-point (- arg))))
+In overwrite mode, this function inserts the character anyway, and
+does not handle octal digits specially. This means that if you use
+overwrite as your normal editing mode, you can use this function to
+insert characters when necessary.
-(defcustom backward-delete-char-untabify-method 'untabify
- "*The method for untabifying when deleting backward.
-Can be `untabify' -- turn a tab to many spaces, then delete one space.
- `hungry' -- delete all whitespace, both tabs and spaces.
- nil -- just delete one character."
- :type '(choice (const untabify) (const hungry) (const nil))
- :group 'killing)
+In binary overwrite mode, this function does overwrite, and octal
+digits are interpreted as a character code. This is intended to be
+useful for editing binary files."
+ (interactive "*p")
+ (let ((char (if (or (not overwrite-mode)
+ (eq overwrite-mode 'overwrite-mode-binary))
+ (read-quoted-char)
+ (read-char))))
+ ;; Assume character codes 0240 - 0377 stand for characters in some
+ ;; single-byte character set, and convert them to Emacs
+ ;; characters.
+ (if (and enable-multibyte-characters
+ (>= char ?\240)
+ (<= char ?\377))
+ (setq char (unibyte-char-to-multibyte char)))
+ (if (> arg 0)
+ (if (eq overwrite-mode 'overwrite-mode-binary)
+ (delete-char arg)))
+ (while (> arg 0)
+ (insert-and-inherit char)
+ (setq arg (1- arg)))))
+\f
+(defun forward-to-indentation (arg)
+ "Move forward ARG lines and position at first nonblank character."
+ (interactive "p")
+ (forward-line arg)
+ (skip-chars-forward " \t"))
-(defun backward-delete-char-untabify (arg &optional killp)
- "Delete characters backward, changing tabs into spaces.
-The exact behavior depends on `backward-delete-char-untabify-method'.
-Delete ARG chars, and kill (save in kill ring) if KILLP is non-nil.
-Interactively, ARG is the prefix arg (default 1)
-and KILLP is t if a prefix arg was specified."
- (interactive "*p\nP")
- (when (eq backward-delete-char-untabify-method 'untabify)
- (let ((count arg))
- (save-excursion
- (while (and (> count 0) (not (bobp)))
- (if (= (preceding-char) ?\t)
- (let ((col (current-column)))
- (forward-char -1)
- (setq col (- col (current-column)))
- (insert-char ?\ col)
- (delete-char 1)))
- (forward-char -1)
- (setq count (1- count))))))
- (delete-backward-char
- (if (eq backward-delete-char-untabify-method 'hungry)
- (let ((wh (- (point) (save-excursion (skip-chars-backward " \t")
- (point)))))
- (+ arg (if (zerop wh) 0 (1- wh))))
- arg)
- killp))
+(defun backward-to-indentation (arg)
+ "Move backward ARG lines and position at first nonblank character."
+ (interactive "p")
+ (forward-line (- arg))
+ (skip-chars-forward " \t"))
-(defun zap-to-char (arg char)
- "Kill up to and including ARG'th occurrence of CHAR.
-Case is ignored if `case-fold-search' is non-nil in the current buffer.
-Goes backward if ARG is negative; error if CHAR not found."
- (interactive "p\ncZap to char: ")
- (kill-region (point) (progn
- (search-forward (char-to-string char) nil nil arg)
-; (goto-char (if (> arg 0) (1- (point)) (1+ (point))))
- (point))))
+(defun back-to-indentation ()
+ "Move point to the first non-whitespace character on this line."
+ (interactive)
+ (beginning-of-line 1)
+ (skip-chars-forward " \t"))
+
+(defun fixup-whitespace ()
+ "Fixup white space between objects around point.
+Leave one space or none, according to the context."
+ (interactive "*")
+ (save-excursion
+ (delete-horizontal-space)
+ (if (or (looking-at "^\\|\\s)")
+ (save-excursion (forward-char -1)
+ (looking-at "$\\|\\s(\\|\\s'")))
+ nil
+ (insert ?\ ))))
+
+(defun delete-horizontal-space ()
+ "Delete all spaces and tabs around point."
+ (interactive "*")
+ (skip-chars-backward " \t")
+ (delete-region (point) (progn (skip-chars-forward " \t") (point))))
+(defun just-one-space ()
+ "Delete all spaces and tabs around point, leaving one space."
+ (interactive "*")
+ (skip-chars-backward " \t")
+ (if (= (following-char) ? )
+ (forward-char 1)
+ (insert ? ))
+ (delete-region (point) (progn (skip-chars-forward " \t") (point))))
+
+\f
(defun beginning-of-buffer (&optional arg)
"Move point to the beginning of the buffer; leave mark at previous position.
With arg N, put point N/10 of the way from the beginning.
(point-max))))
;; If we went to a place in the middle of the buffer,
;; adjust it to the beginning of a line.
- (if arg (forward-line 1)
- ;; If the end of the buffer is not already on the screen,
- ;; then scroll specially to put it near, but not at, the bottom.
- (if (let ((old-point (point)))
- (save-excursion
- (goto-char (window-start))
- (vertical-motion (window-height))
- (< (point) old-point)))
- (progn
- (overlay-recenter (point))
- (recenter -3)))))
+ (cond (arg (forward-line 1))
+ ((< (point) (window-end nil t))
+ ;; If the end of the buffer is not already on the screen,
+ ;; then scroll specially to put it near, but not at, the bottom.
+ (overlay-recenter (point))
+ (recenter -3))))
(defun mark-whole-buffer ()
"Put point at beginning and mark at end of buffer.
(push-mark (point-max) nil t)
(goto-char (point-min)))
+\f
+;; Counting lines, one way or another.
+
+(defun goto-line (arg)
+ "Goto line ARG, counting from line 1 at beginning of buffer."
+ (interactive "NGoto line: ")
+ (setq arg (prefix-numeric-value arg))
+ (save-restriction
+ (widen)
+ (goto-char 1)
+ (if (eq selective-display t)
+ (re-search-forward "[\n\C-m]" nil 'end (1- arg))
+ (forward-line (1- arg)))))
+
(defun count-lines-region (start end)
"Print number of lines and characters in the region."
(interactive "r")
(1+ (count-lines start (point))))
(message "Line %d" (1+ (count-lines 1 (point)))))))))
-
(defun count-lines (start end)
"Return number of lines between START and END.
This is usually the number of newlines between them,
(1+ done)
done)))
(- (buffer-size) (forward-line (buffer-size)))))))
-
+\f
(defun what-cursor-position (&optional detail)
"Print info on cursor position (on screen and within buffer).
Also describe the character after point, and give its character code
code is shown in hex. If the character is encoded into more than one
byte, just \"...\" is shown.
-With prefix argument, print additional details about that character,
-instead of the cursor position. This includes the character set name,
-the codes that identify the character within that character set. In
-addition, the encoding is fully shown."
+In addition, with prefix argument, show details about that character
+in *Help* buffer. See also the command `describe-char-after'."
(interactive "P")
(let* ((char (following-char))
(beg (point-min))
(col (current-column)))
(if (= pos end)
(if (or (/= beg 1) (/= end (1+ total)))
- (message "point=%d of %d(%d%%) <%d - %d> column %d %s"
+ (message "point=%d of %d (%d%%) <%d - %d> column %d %s"
pos total percent beg end col hscroll)
- (message "point=%d of %d(%d%%) column %d %s"
+ (message "point=%d of %d (%d%%) column %d %s"
pos total percent col hscroll))
(let ((coding buffer-file-coding-system)
encoded encoding-msg)
(setq encoded (and (>= char 128) (encode-coding-char char coding)))
(setq encoding-msg
(if encoded
- (format "(0%o, %d, 0x%x, ext %s)"
+ (format "(0%o, %d, 0x%x, file %s)"
char char char
- (if (and (not detail)
- (> (length encoded) 1))
+ (if (> (length encoded) 1)
"..."
- (concat
- (encoded-string-description encoded coding)
- (if (cmpcharp char) "..." ""))))
+ (encoded-string-description encoded coding)))
(format "(0%o, %d, 0x%x)" char char char))))
(if detail
- ;; We show the detailed information of CHAR.
- (let ((internal
- (if (cmpcharp char)
- ;; For a composite character, we show the
- ;; components only.
- (concat "(composed \""
- (decompose-composite-char char)
- "\")")
- (split-char char))))
- (message "Char: %s %s %s"
- (if (< char 256)
- (single-key-description char)
- (buffer-substring (point) (1+ (point))))
- encoding-msg internal))
- (if (or (/= beg 1) (/= end (1+ total)))
- (message "Char: %s %s point=%d of %d(%d%%) <%d - %d> column %d %s"
- (if (< char 256)
- (single-key-description char)
- (buffer-substring (point) (1+ (point))))
- encoding-msg pos total percent beg end col hscroll)
- (message "Char: %s %s point=%d of %d(%d%%) column %d %s"
+ ;; We show the detailed information about CHAR.
+ (describe-char-after (point)))
+ (if (or (/= beg 1) (/= end (1+ total)))
+ (message "Char: %s %s point=%d of %d (%d%%) <%d - %d> column %d %s"
(if (< char 256)
(single-key-description char)
- (buffer-substring (point) (1+ (point))))
- encoding-msg pos total percent col hscroll)))))))
-
-(defun fundamental-mode ()
- "Major mode not specialized for anything in particular.
-Other major modes are defined by comparison with this one."
- (interactive)
- (kill-all-local-variables))
-
+ (buffer-substring-no-properties (point) (1+ (point))))
+ encoding-msg pos total percent beg end col hscroll)
+ (message "Char: %s %s point=%d of %d (%d%%) column %d %s"
+ (if (< char 256)
+ (single-key-description char)
+ (buffer-substring-no-properties (point) (1+ (point))))
+ encoding-msg pos total percent col hscroll))))))
+\f
(defvar read-expression-map (cons 'keymap minibuffer-local-map)
"Minibuffer keymap used for reading Lisp expressions.")
(define-key read-expression-map "\M-\t" 'lisp-complete-symbol)
(defvar read-expression-history nil)
+(defcustom eval-expression-print-level 4
+ "*Value to use for `print-level' when printing value in `eval-expression'."
+ :group 'lisp
+ :type 'integer
+ :version "21.1")
+
+(defcustom eval-expression-print-length 12
+ "*Value to use for `print-length' when printing value in `eval-expression'."
+ :group 'lisp
+ :type '(choice (const nil) integer)
+ :version "21.1")
+
+(defcustom eval-expression-debug-on-error t
+ "*Non-nil means set `debug-on-error' when evaluating in `eval-expression'.
+If nil, don't change the value of `debug-on-error'."
+ :group 'lisp
+ :type 'boolean
+ :version "21.1")
+
;; We define this, rather than making `eval' interactive,
;; for the sake of completion of names like eval-region, eval-current-buffer.
(defun eval-expression (eval-expression-arg
nil read-expression-map t
'read-expression-history)
current-prefix-arg))
- (setq values (cons (eval eval-expression-arg) values))
- (prin1 (car values)
- (if eval-expression-insert-value (current-buffer) t)))
+
+ (if (null eval-expression-debug-on-error)
+ (setq values (cons (eval eval-expression-arg) values))
+ (let ((old-value (make-symbol "t")) new-value)
+ ;; Bind debug-on-error to something unique so that we can
+ ;; detect when evaled code changes it.
+ (let ((debug-on-error old-value))
+ (setq values (cons (eval eval-expression-arg) values))
+ (setq new-value debug-on-error))
+ ;; If evaled code has changed the value of debug-on-error,
+ ;; propagate that change to the global binding.
+ (unless (eq old-value new-value)
+ (setq debug-on-error new-value))))
+
+ (let ((print-length eval-expression-print-length)
+ (print-level eval-expression-print-level))
+ (prin1 (car values)
+ (if eval-expression-insert-value (current-buffer) t))))
(defun edit-and-eval-command (prompt command)
"Prompting with PROMPT, let user edit COMMAND and eval result.
(prefix-numeric-value current-prefix-arg))))
(if (and (zerop minibuffer-history-position)
(null minibuffer-text-before-history))
- (setq minibuffer-text-before-history (buffer-string)))
+ (setq minibuffer-text-before-history (field-string (point-max))))
(let ((history (symbol-value minibuffer-history-variable))
(case-fold-search
(if (isearch-no-upper-case-p regexp t) ; assume isearch.el is dumped
(nth (1- pos) history)))
(setq n (+ n (if (< n 0) 1 -1)))))
(setq minibuffer-history-position pos)
- (erase-buffer)
+ (goto-char (point-max))
+ (delete-field)
(let ((elt (nth (1- pos) history)))
(insert (if (eq minibuffer-history-sexp-flag (minibuffer-depth))
(let ((print-level nil))
(prin1-to-string elt))
elt)))
- (goto-char (point-min)))
+ (goto-char (field-beginning)))
(if (or (eq (car (car command-history)) 'previous-matching-history-element)
(eq (car (car command-history)) 'next-matching-history-element))
(setq command-history (cdr command-history))))
(or (zerop n)
(let ((narg (- minibuffer-history-position n))
(minimum (if minibuffer-default -1 0))
- elt)
+ elt minibuffer-returned-to-present)
(if (and (zerop minibuffer-history-position)
(null minibuffer-text-before-history))
- (setq minibuffer-text-before-history (buffer-string)))
+ (setq minibuffer-text-before-history (field-string (point-max))))
(if (< narg minimum)
(if minibuffer-default
(error "End of history; no next item")
(error "End of history; no default available")))
(if (> narg (length (symbol-value minibuffer-history-variable)))
(error "Beginning of history; no preceding item"))
- (erase-buffer)
+ (goto-char (point-max))
+ (delete-field)
(setq minibuffer-history-position narg)
(cond ((= narg -1)
(setq elt minibuffer-default))
((= narg 0)
(setq elt (or minibuffer-text-before-history ""))
+ (setq minibuffer-returned-to-present t)
(setq minibuffer-text-before-history nil))
(t (setq elt (nth (1- minibuffer-history-position)
(symbol-value minibuffer-history-variable)))))
(insert
- (if (eq minibuffer-history-sexp-flag (minibuffer-depth))
+ (if (and (eq minibuffer-history-sexp-flag (minibuffer-depth))
+ (not minibuffer-returned-to-present))
(let ((print-level nil))
(prin1-to-string elt))
elt))
- (goto-char (point-min)))))
+ (goto-char (field-beginning)))))
(defun previous-history-element (n)
"Inserts the previous element of the minibuffer history into the minibuffer."
(next-history-element (- n)))
(defun next-complete-history-element (n)
- "Get next element of history which is a completion of minibuffer contents."
+ "Get next history element which completes the minibuffer before the point.
+The contents of the minibuffer after the point are deleted, and replaced
+by the new completion."
(interactive "p")
(let ((point-at-start (point)))
(next-matching-history-element
- (concat "^" (regexp-quote (buffer-substring (point-min) (point)))) n)
+ (concat
+ "^" (regexp-quote (buffer-substring (field-beginning) (point))))
+ n)
;; next-matching-history-element always puts us at (point-min).
;; Move to the position we were at before changing the buffer contents.
;; This is still sensical, because the text before point has not changed.
(defun previous-complete-history-element (n)
"\
-Get previous element of history which is a completion of minibuffer contents."
+Get previous history element which completes the minibuffer before the point.
+The contents of the minibuffer after the point are deleted, and replaced
+by the new completion."
(interactive "p")
(next-complete-history-element (- n)))
-\f
-(defun goto-line (arg)
- "Goto line ARG, counting from line 1 at beginning of buffer."
- (interactive "NGoto line: ")
- (setq arg (prefix-numeric-value arg))
- (save-restriction
- (widen)
- (goto-char 1)
- (if (eq selective-display t)
- (re-search-forward "[\n\C-m]" nil 'end (1- arg))
- (forward-line (1- arg)))))
+;; These two functions are for compatibility with the old subrs of the
+;; same name.
+
+(defun minibuffer-prompt-width ()
+ "Return the display width of the minibuffer prompt.
+Return 0 if current buffer is not a mini-buffer."
+ ;; Return the width of everything before the field at the end of
+ ;; the buffer; this should be 0 for normal buffers.
+ (1- (field-beginning (point-max))))
+
+(defun minibuffer-prompt-end ()
+ "Return the buffer position of the end of the minibuffer prompt.
+Return 0 if current buffer is not a mini-buffer."
+ (field-beginning (point-max)))
+
+\f
;Put this on C-x u, so we can force that rather than C-_ into startup msg
(defalias 'advertised-undo 'undo)
are ignored. If BEG and END are nil, all undo elements are used."
(if (eq buffer-undo-list t)
(error "No undo information in this buffer"))
- (setq pending-undo-list
+ (setq pending-undo-list
(if (and beg end (not (= beg end)))
(undo-make-selective-list (min beg end) (max beg end))
buffer-undo-list)))
(let ((text-pos (abs (cdr undo-elt)))
(point-at-end (< (cdr undo-elt) 0 )))
(if (>= text-pos position)
- (setcdr undo-elt (* (if point-at-end -1 1)
+ (setcdr undo-elt (* (if point-at-end -1 1)
(- text-pos offset))))))
((integerp (car undo-elt))
;; (BEGIN . END)
(if (and output-buffer
(not (or (bufferp output-buffer) (stringp output-buffer))))
(let ((error-file
- (if error-buffer
- (concat (file-name-directory temp-file-name-pattern)
- (make-temp-name "scor"))
+ (if error-buffer
+ (make-temp-file
+ (expand-file-name "scor"
+ (or small-temporary-file-directory
+ temporary-file-directory)))
nil)))
(barf-if-buffer-read-only)
- (push-mark)
+ (push-mark nil t)
;; We do not use -f for csh; we will not support broken use of
;; .cshrcs. Even the BSD csh manual says to use
;; "if ($?prompt) exit" before things which are not useful
;; non-interactively. Besides, if someone wants their other
;; aliases for shell commands then they can still have them.
- (call-process shell-file-name nil
+ (call-process shell-file-name nil
(if error-file
(list t error-file)
t)
(erase-buffer)
(display-buffer buffer)
(setq default-directory directory)
- (setq proc (start-process "Shell" buffer shell-file-name
+ (setq proc (start-process "Shell" buffer shell-file-name
shell-command-switch command))
(setq mode-line-process '(":%s"))
(require 'shell) (shell-mode)
;; in the buffer itself.
(defun shell-command-sentinel (process signal)
(if (memq (process-status process) '(exit signal))
- (message "%s: %s."
+ (message "%s: %s."
(car (cdr (cdr (process-command process))))
(substring signal 0 -1))))
current-prefix-arg
shell-command-default-error-buffer)))
(let ((error-file
- (if error-buffer
- (concat (file-name-directory temp-file-name-pattern)
- (make-temp-name "scor"))
+ (if error-buffer
+ (make-temp-file
+ (expand-file-name "scor"
+ (or small-temporary-file-directory
+ temporary-file-directory)))
nil))
exit-status)
(if (or replace
(delete-region (point-min) (min start end))
(setq exit-status
(call-process-region (point-min) (point-max)
- shell-file-name t
+ shell-file-name t
(if error-file
(list t error-file)
t)
command)))
;; Clear the output buffer, then run the command with
;; output there.
- (save-excursion
- (set-buffer buffer)
- (setq buffer-read-only nil)
- (erase-buffer))
+ (let ((directory default-directory))
+ (save-excursion
+ (set-buffer buffer)
+ (setq buffer-read-only nil)
+ (if (not output-buffer)
+ (setq default-directory directory))
+ (erase-buffer)))
(setq exit-status
(call-process-region start end shell-file-name nil
(if error-file
(list buffer error-file)
buffer)
nil shell-command-switch command)))
- (setq success (and exit-status (zerop exit-status)))
+ (setq success (and exit-status (equal 0 exit-status)))
;; Report the amount of output.
(let ((lines (save-excursion
(set-buffer buffer)
(goto-char (point-min))
(buffer-substring (point)
(progn (end-of-line) (point))))))
- (t
+ (t
(save-excursion
(set-buffer buffer)
(goto-char (point-min)))
(display-buffer (current-buffer))))
(delete-file error-file))
exit-status))
-
+
(defun shell-command-to-string (command)
"Execute shell command COMMAND and return its output as a string."
(with-output-to-string
(define-key map [?7] 'digit-argument)
(define-key map [?8] 'digit-argument)
(define-key map [?9] 'digit-argument)
+ (define-key map [kp-0] 'digit-argument)
+ (define-key map [kp-1] 'digit-argument)
+ (define-key map [kp-2] 'digit-argument)
+ (define-key map [kp-3] 'digit-argument)
+ (define-key map [kp-4] 'digit-argument)
+ (define-key map [kp-5] 'digit-argument)
+ (define-key map [kp-6] '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)
map)
"Keymap used while processing \\[universal-argument].")
"Part of the numeric argument for the next command.
\\[universal-argument] following digits or minus sign ends the argument."
(interactive "P")
- (let ((digit (- (logand last-command-char ?\177) ?0)))
+ (let* ((char (if (integerp last-command-char)
+ last-command-char
+ (get last-command-char 'ascii-character)))
+ (digit (- (logand char ?\177) ?0)))
(cond ((integerp arg)
(setq prefix-arg (+ (* arg 10)
(if (< arg 0) (- digit) digit))))
;; 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)
- (setq overriding-terminal-local-map nil))
-\f
-(defun forward-to-indentation (arg)
- "Move forward ARG lines and position at first nonblank character."
- (interactive "p")
- (forward-line arg)
- (skip-chars-forward " \t"))
-
-(defun backward-to-indentation (arg)
- "Move backward ARG lines and position at first nonblank character."
- (interactive "p")
- (forward-line (- arg))
- (skip-chars-forward " \t"))
-
-(defcustom kill-whole-line nil
- "*If non-nil, `kill-line' with no arg at beg of line kills the whole line."
- :type 'boolean
- :group 'killing)
-
-(defun kill-line (&optional arg)
- "Kill the rest of the current line; if no nonblanks there, kill thru newline.
-With prefix argument, kill that many lines from point.
-Negative arguments kill lines backward.
-
-When calling from a program, nil means \"no arg\",
-a number counts as a prefix arg.
-
-To kill a whole line, when point is not at the beginning, type \
-\\[beginning-of-line] \\[kill-line] \\[kill-line].
-
-If `kill-whole-line' is non-nil, then this command kills the whole line
-including its terminating newline, when used at the beginning of a line
-with no argument. As a consequence, you can always kill a whole line
-by typing \\[beginning-of-line] \\[kill-line]."
- (interactive "P")
- (kill-region (point)
- ;; It is better to move point to the other end of the kill
- ;; before killing. That way, in a read-only buffer, point
- ;; moves across the text that is copied to the kill ring.
- ;; The choice has no effect on undo now that undo records
- ;; the value of point from before the command was run.
- (progn
- (if arg
- (forward-visible-line (prefix-numeric-value arg))
- (if (eobp)
- (signal 'end-of-buffer nil))
- (if (or (looking-at "[ \t]*$") (and kill-whole-line (bolp)))
- (forward-visible-line 1)
- (end-of-visible-line)))
- (point))))
-
-(defun forward-visible-line (arg)
- "Move forward by ARG lines, ignoring currently invisible newlines only.
-If ARG is negative, move backward -ARG lines.
-If ARG is zero, move to the beginning of the current line."
- (condition-case nil
- (if (> arg 0)
- (while (> arg 0)
- (or (zerop (forward-line 1))
- (signal 'end-of-buffer nil))
- ;; If the following character is currently invisible,
- ;; skip all characters with that same `invisible' property value,
- ;; then find the next newline.
- (while (and (not (eobp))
- (let ((prop
- (get-char-property (point) 'invisible)))
- (if (eq buffer-invisibility-spec t)
- prop
- (or (memq prop buffer-invisibility-spec)
- (assq prop buffer-invisibility-spec)))))
- (goto-char
- (if (get-text-property (point) 'invisible)
- (or (next-single-property-change (point) 'invisible)
- (point-max))
- (next-overlay-change (point))))
- (or (zerop (forward-line 1))
- (signal 'end-of-buffer nil)))
- (setq arg (1- arg)))
- (let ((first t))
- (while (or first (< arg 0))
- (if (zerop arg)
- (beginning-of-line)
- (or (zerop (forward-line -1))
- (signal 'beginning-of-buffer nil)))
- (while (and (not (bobp))
- (let ((prop
- (get-char-property (1- (point)) 'invisible)))
- (if (eq buffer-invisibility-spec t)
- prop
- (or (memq prop buffer-invisibility-spec)
- (assq prop buffer-invisibility-spec)))))
- (goto-char
- (if (get-text-property (1- (point)) 'invisible)
- (or (previous-single-property-change (point) 'invisible)
- (point-min))
- (previous-overlay-change (point))))
- (or (zerop (forward-line -1))
- (signal 'beginning-of-buffer nil)))
- (setq first nil)
- (setq arg (1+ arg)))))
- ((beginning-of-buffer end-of-buffer)
- nil)))
+ (if (integerp arg)
+ (universal-argument-other-key arg)
+ (negative-argument arg)))
-(defun end-of-visible-line ()
- "Move to end of current visible line."
- (end-of-line)
- ;; If the following character is currently invisible,
- ;; skip all characters with that same `invisible' property value,
- ;; then find the next newline.
- (while (and (not (eobp))
- (let ((prop
- (get-char-property (point) 'invisible)))
- (if (eq buffer-invisibility-spec t)
- prop
- (or (memq prop buffer-invisibility-spec)
- (assq prop buffer-invisibility-spec)))))
- (if (get-text-property (point) 'invisible)
- (goto-char (next-single-property-change (point) 'invisible))
- (goto-char (next-overlay-change (point))))
- (end-of-line)))
+;; 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)
+ (setq overriding-terminal-local-map nil))
\f
;;;; Window system cut and paste hooks.
If N is zero, `interprogram-paste-function' is set, and calling it
returns a string, then that string is added to the front of the
kill ring and returned as the latest kill.
-If optional arg DO-NOT-MOVE is non-nil, then don't actually move the
+If optional arg DO-NOT-MOVE is non-nil, then don't actually move the
yanking point; just return the Nth kill forward."
(let ((interprogram-paste (and (= n 0)
interprogram-paste-function
to make one entry in the kill ring."
(interactive "r")
(condition-case nil
- ;; Don't let the undo list be truncated before we can even access it.
- (let ((undo-strong-limit (+ (- (max beg end) (min beg end)) 100))
- (old-list buffer-undo-list)
- tail
- ;; If we can't rely on finding the killed text
- ;; in the undo list, save it now as a string.
- (string (if (or (eq buffer-undo-list t)
- (= beg end))
- (buffer-substring beg end))))
- (delete-region beg end)
- ;; Search back in buffer-undo-list for this string,
- ;; in case a change hook made property changes.
- (setq tail buffer-undo-list)
- (unless string
- (while (not (stringp (car (car tail))))
- (setq tail (cdr tail)))
- ;; If we did not already make the string to use,
- ;; use the same one that undo made for us.
- (setq string (car (car tail))))
- ;; Add that string to the kill ring, one way or another.
- (if (eq last-command 'kill-region)
- (kill-append string (< end beg))
- (kill-new string))
+ (let ((string (delete-and-extract-region beg end)))
+ (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))
+ (kill-new string)))
(setq this-command 'kill-region))
((buffer-read-only text-read-only)
;; The code above failed because the buffer, or some of the characters
(if (eq last-command 'kill-region)
(kill-append (buffer-substring beg end) (< end beg))
(kill-new (buffer-substring beg end)))
- (if transient-mark-mode
+ (if transient-mark-mode
(setq deactivate-mark t))
nil)
(setq this-command 'kill-region)
(message "If the next command is a kill, it will append"))
(setq last-command 'kill-region)))
+\f
+;; Yanking.
(defun yank-pop (arg)
"Replace just-yanked stretch of killed text with a different stretch.
With argument, rotate that many kills forward (or backward, if negative)."
(interactive "p")
(current-kill arg))
+\f
+;; Some kill commands.
+
+;; Internal subroutine of delete-char
+(defun kill-forward-chars (arg)
+ (if (listp arg) (setq arg (car arg)))
+ (if (eq arg '-) (setq arg -1))
+ (kill-region (point) (forward-point arg)))
+
+;; Internal subroutine of backward-delete-char
+(defun kill-backward-chars (arg)
+ (if (listp arg) (setq arg (car arg)))
+ (if (eq arg '-) (setq arg -1))
+ (kill-region (point) (forward-point (- arg))))
+
+(defcustom backward-delete-char-untabify-method 'untabify
+ "*The method for untabifying when deleting backward.
+Can be `untabify' -- turn a tab to many spaces, then delete one space;
+ `hungry' -- delete all whitespace, both tabs and spaces;
+ `all' -- delete all whitespace, including tabs, spaces and newlines;
+ nil -- just delete one character."
+ :type '(choice (const untabify) (const hungry) (const all) (const nil))
+ :group 'killing)
+
+(defun backward-delete-char-untabify (arg &optional killp)
+ "Delete characters backward, changing tabs into spaces.
+The exact behavior depends on `backward-delete-char-untabify-method'.
+Delete ARG chars, and kill (save in kill ring) if KILLP is non-nil.
+Interactively, ARG is the prefix arg (default 1)
+and KILLP is t if a prefix arg was specified."
+ (interactive "*p\nP")
+ (when (eq backward-delete-char-untabify-method 'untabify)
+ (let ((count arg))
+ (save-excursion
+ (while (and (> count 0) (not (bobp)))
+ (if (= (preceding-char) ?\t)
+ (let ((col (current-column)))
+ (forward-char -1)
+ (setq col (- col (current-column)))
+ (insert-char ?\ col)
+ (delete-char 1)))
+ (forward-char -1)
+ (setq count (1- count))))))
+ (delete-backward-char
+ (let ((skip (cond ((eq backward-delete-char-untabify-method 'hungry) " \t")
+ ((eq backward-delete-char-untabify-method 'all)
+ " \t\n\r"))))
+ (if skip
+ (let ((wh (- (point) (save-excursion (skip-chars-backward skip)
+ (point)))))
+ (+ arg (if (zerop wh) 0 (1- wh))))
+ arg))
+ killp))
+
+(defun zap-to-char (arg char)
+ "Kill up to and including ARG'th occurrence of CHAR.
+Case is ignored if `case-fold-search' is non-nil in the current buffer.
+Goes backward if ARG is negative; error if CHAR not found."
+ (interactive "p\ncZap to char: ")
+ (kill-region (point) (progn
+ (search-forward (char-to-string char) nil nil arg)
+; (goto-char (if (> arg 0) (1- (point)) (1+ (point))))
+ (point))))
+\f
+;; kill-line and its subroutines.
+
+(defcustom kill-whole-line nil
+ "*If non-nil, `kill-line' with no arg at beg of line kills the whole line."
+ :type 'boolean
+ :group 'killing)
+
+(defun kill-line (&optional arg)
+ "Kill the rest of the current line; if no nonblanks there, kill thru newline.
+With prefix argument, kill that many lines from point.
+Negative arguments kill lines backward.
+
+When calling from a program, nil means \"no arg\",
+a number counts as a prefix arg.
+
+To kill a whole line, when point is not at the beginning, type \
+\\[beginning-of-line] \\[kill-line] \\[kill-line].
+
+If `kill-whole-line' is non-nil, then this command kills the whole line
+including its terminating newline, when used at the beginning of a line
+with no argument. As a consequence, you can always kill a whole line
+by typing \\[beginning-of-line] \\[kill-line]."
+ (interactive "P")
+ (kill-region (point)
+ ;; It is better to move point to the other end of the kill
+ ;; before killing. That way, in a read-only buffer, point
+ ;; moves across the text that is copied to the kill ring.
+ ;; The choice has no effect on undo now that undo records
+ ;; the value of point from before the command was run.
+ (progn
+ (if arg
+ (forward-visible-line (prefix-numeric-value arg))
+ (if (eobp)
+ (signal 'end-of-buffer nil))
+ (if (or (looking-at "[ \t]*$") (and kill-whole-line (bolp)))
+ (forward-visible-line 1)
+ (end-of-visible-line)))
+ (point))))
+
+(defun forward-visible-line (arg)
+ "Move forward by ARG lines, ignoring currently invisible newlines only.
+If ARG is negative, move backward -ARG lines.
+If ARG is zero, move to the beginning of the current line."
+ (condition-case nil
+ (if (> arg 0)
+ (while (> arg 0)
+ (or (zerop (forward-line 1))
+ (signal 'end-of-buffer nil))
+ ;; If the following character is currently invisible,
+ ;; skip all characters with that same `invisible' property value,
+ ;; then find the next newline.
+ (while (and (not (eobp))
+ (let ((prop
+ (get-char-property (point) 'invisible)))
+ (if (eq buffer-invisibility-spec t)
+ prop
+ (or (memq prop buffer-invisibility-spec)
+ (assq prop buffer-invisibility-spec)))))
+ (goto-char
+ (if (get-text-property (point) 'invisible)
+ (or (next-single-property-change (point) 'invisible)
+ (point-max))
+ (next-overlay-change (point))))
+ (or (zerop (forward-line 1))
+ (signal 'end-of-buffer nil)))
+ (setq arg (1- arg)))
+ (let ((first t))
+ (while (or first (< arg 0))
+ (if (zerop arg)
+ (beginning-of-line)
+ (or (zerop (forward-line -1))
+ (signal 'beginning-of-buffer nil)))
+ (while (and (not (bobp))
+ (let ((prop
+ (get-char-property (1- (point)) 'invisible)))
+ (if (eq buffer-invisibility-spec t)
+ prop
+ (or (memq prop buffer-invisibility-spec)
+ (assq prop buffer-invisibility-spec)))))
+ (goto-char
+ (if (get-text-property (1- (point)) 'invisible)
+ (or (previous-single-property-change (point) 'invisible)
+ (point-min))
+ (previous-overlay-change (point))))
+ (or (zerop (forward-line -1))
+ (signal 'beginning-of-buffer nil)))
+ (setq first nil)
+ (setq arg (1+ arg)))))
+ ((beginning-of-buffer end-of-buffer)
+ nil)))
+(defun end-of-visible-line ()
+ "Move to end of current visible line."
+ (end-of-line)
+ ;; If the following character is currently invisible,
+ ;; skip all characters with that same `invisible' property value,
+ ;; then find the next newline.
+ (while (and (not (eobp))
+ (let ((prop
+ (get-char-property (point) 'invisible)))
+ (if (eq buffer-invisibility-spec t)
+ prop
+ (or (memq prop buffer-invisibility-spec)
+ (assq prop buffer-invisibility-spec)))))
+ (if (get-text-property (point) 'invisible)
+ (goto-char (next-single-property-change (point) 'invisible))
+ (goto-char (next-overlay-change (point))))
+ (end-of-line)))
\f
(defun insert-buffer (buffer)
"Insert after point the contents of BUFFER.
Puts mark after the inserted text.
-BUFFER may be a buffer or a buffer name."
+BUFFER may be a buffer or a buffer name.
+
+This function is meant for the user to run interactively.
+Don't call it from programs!"
(interactive
(list
(progn
(region-beginning) (region-end)))
(let ((oldbuf (current-buffer)))
(save-excursion
- (set-buffer (get-buffer-create buffer))
- (insert-buffer-substring oldbuf start end))))
+ (let* ((append-to (get-buffer-create buffer))
+ (windows (get-buffer-window-list append-to t t))
+ point)
+ (set-buffer append-to)
+ (setq point (point))
+ (barf-if-buffer-read-only)
+ (insert-buffer-substring oldbuf start end)
+ (dolist (window windows)
+ (when (= (window-point window) point)
+ (set-window-point window (point))))))))
(defun prepend-to-buffer (buffer start end)
"Prepend to specified buffer the text of the region.
(let ((oldbuf (current-buffer)))
(save-excursion
(set-buffer (get-buffer-create buffer))
+ (barf-if-buffer-read-only)
(save-excursion
(insert-buffer-substring oldbuf start end)))))
(let ((oldbuf (current-buffer)))
(save-excursion
(set-buffer (get-buffer-create buffer))
+ (barf-if-buffer-read-only)
(erase-buffer)
(save-excursion
(insert-buffer-substring oldbuf start end)))))
((beginning-of-buffer end-of-buffer) (ding)))
(line-move (- arg)))
nil)
-
+\f
(defcustom track-eol nil
"*Non-nil means vertical motion starting at end of line keeps to ends of lines.
This means moving to the end of each line moved onto.
;; with intangibility and point-motion hooks enabled this time.
(goto-char opoint)
(setq inhibit-point-motion-hooks nil)
- (goto-char new)
+ (goto-char (constrain-to-field new opoint nil t
+ 'inhibit-line-move-field-capture))
;; If intangibility processing moved us to a different line,
;; readjust the horizontal position within the line we ended up at.
(when (or (< (point) line-beg) (> (point) line-end))
(setq new (point)))
(goto-char (point-min))
(setq inhibit-point-motion-hooks nil)
- (goto-char new)
+ (goto-char (constrain-to-field new opoint nil t
+ 'inhibit-line-move-field-capture))
)))
nil)
goal-column))
nil)
\f
-;;; Partial support for horizontal autoscrolling. Someday, this feature
-;;; will be built into the C level and all the (hscroll-point-visible) calls
-;;; will go away.
-
-(defcustom hscroll-step 0
- "*The number of columns to try scrolling a window by when point moves out.
-If that fails to bring point back on frame, point is centered instead.
-If this is zero, point is always centered after it moves off frame."
- :type '(choice (const :tag "Alway Center" 0)
- (integer :format "%v" 1))
- :group 'editing-basics)
-
-(defun hscroll-point-visible ()
- "Scrolls the selected window horizontally to make point visible."
- (save-excursion
- (set-buffer (window-buffer))
- (if (not (or truncate-lines
- (> (window-hscroll) 0)
- (and truncate-partial-width-windows
- (< (window-width) (frame-width)))))
- ;; Point is always visible when lines are wrapped.
- ()
- ;; If point is on the invisible part of the line before window-start,
- ;; then hscrolling can't bring it back, so reset window-start first.
- (and (< (point) (window-start))
- (let ((ws-bol (save-excursion
- (goto-char (window-start))
- (beginning-of-line)
- (point))))
- (and (>= (point) ws-bol)
- (set-window-start nil ws-bol))))
- (let* ((here (hscroll-window-column))
- (left (min (window-hscroll) 1))
- (right (1- (window-width))))
- ;; Allow for the truncation glyph, if we're not exactly at eol.
- (if (not (and (= here right)
- (= (following-char) ?\n)))
- (setq right (1- right)))
- (cond
- ;; If too far away, just recenter. But don't show too much
- ;; white space off the end of the line.
- ((or (< here (- left hscroll-step))
- (> here (+ right hscroll-step)))
- (let ((eol (save-excursion (end-of-line) (hscroll-window-column))))
- (scroll-left (min (- here (/ (window-width) 2))
- (- eol (window-width) -5)))))
- ;; Within range. Scroll by one step (or maybe not at all).
- ((< here left)
- (scroll-right hscroll-step))
- ((> here right)
- (scroll-left hscroll-step)))))))
-
-;; This function returns the window's idea of the display column of point,
-;; assuming that the window is already known to be truncated rather than
-;; wrapped, and that we've already handled the case where point is on the
-;; part of the line before window-start. We ignore window-width; if point
-;; is beyond the right margin, we want to know how far. The return value
-;; includes the effects of window-hscroll, window-start, and the prompt
-;; string in the minibuffer. It may be negative due to hscroll.
-(defun hscroll-window-column ()
- (let* ((hscroll (window-hscroll))
- (startpos (save-excursion
- (beginning-of-line)
- (if (= (point) (save-excursion
- (goto-char (window-start))
- (beginning-of-line)
- (point)))
- (goto-char (window-start)))
- (point)))
- (hpos (+ (if (and (eq (selected-window) (minibuffer-window))
- (= 1 (window-start))
- (= startpos (point-min)))
- (minibuffer-prompt-width)
- 0)
- (min 0 (- 1 hscroll))))
- val)
- (car (cdr (compute-motion startpos (cons hpos 0)
- (point) (cons 0 1)
- 1000000 (cons hscroll 0) nil)))))
-
-
-;; rms: (1) The definitions of arrow keys should not simply restate
-;; what keys they are. The arrow keys should run the ordinary commands.
-;; (2) The arrow keys are just one of many common ways of moving point
-;; within a line. Real horizontal autoscrolling would be a good feature,
-;; but supporting it only for arrow keys is too incomplete to be desirable.
-
-;;;;; Make arrow keys do the right thing for improved terminal support
-;;;;; When we implement true horizontal autoscrolling, right-arrow and
-;;;;; left-arrow can lose the (if truncate-lines ...) clause and become
-;;;;; aliases. These functions are bound to the corresponding keyboard
-;;;;; events in loaddefs.el.
-
-;;(defun right-arrow (arg)
-;; "Move right one character on the screen (with prefix ARG, that many chars).
-;;Scroll right if needed to keep point horizontally onscreen."
-;; (interactive "P")
-;; (forward-char arg)
-;; (hscroll-point-visible))
-
-;;(defun left-arrow (arg)
-;; "Move left one character on the screen (with prefix ARG, that many chars).
-;;Scroll left if needed to keep point horizontally onscreen."
-;; (interactive "P")
-;; (backward-char arg)
-;; (hscroll-point-visible))
(defun scroll-other-window-down (lines)
"Scroll the \"other window\" down.
(delete-region (point) (+ (point) len1))
(insert word2)))
\f
-(defcustom comment-column 32
- "*Column to indent right-margin comments to.
-Setting this variable automatically makes it local to the current buffer.
-Each mode establishes a different default value for this variable; you
-can set the value for a particular mode using that mode's hook."
- :type 'integer
- :group 'fill-comments)
-(make-variable-buffer-local 'comment-column)
-
-(defcustom comment-start nil
- "*String to insert to start a new comment, or nil if no comment syntax."
- :type '(choice (const :tag "None" nil)
- string)
- :group 'fill-comments)
-
-(defcustom comment-start-skip nil
- "*Regexp to match the start of a comment plus everything up to its body.
-If there are any \\(...\\) pairs, the comment delimiter text is held to begin
-at the place matched by the close of the first pair."
- :type '(choice (const :tag "None" nil)
- regexp)
- :group 'fill-comments)
-
-(defcustom comment-end ""
- "*String to insert to end a new comment.
-Should be an empty string if comments are terminated by end-of-line."
- :type 'string
- :group 'fill-comments)
-
(defvar comment-indent-hook nil
"Obsolete variable for function to compute desired indentation for a comment.
This function is called with no args with point at the beginning of
the comment's starting delimiter.")
-
-(defvar comment-indent-function
- '(lambda () comment-column)
- "Function to compute desired indentation for a comment.
-This function is called with no args with point at the beginning of
-the comment's starting delimiter.")
-
-(defcustom block-comment-start nil
- "*String to insert to start a new comment on a line by itself.
-If nil, use `comment-start' instead.
-Note that the regular expression `comment-start-skip' should skip this string
-as well as the `comment-start' string."
- :type '(choice (const :tag "Use comment-start" nil)
- string)
- :group 'fill-comments)
-
-(defcustom block-comment-end nil
- "*String to insert to end a new comment on a line by itself.
-Should be an empty string if comments are terminated by end-of-line.
-If nil, use `comment-end' instead."
- :type '(choice (const :tag "Use comment-end" nil)
- string)
- :group 'fill-comments)
-
-(defun indent-for-comment ()
- "Indent this line's comment to comment column, or insert an empty comment."
- (interactive "*")
- (let* ((empty (save-excursion (beginning-of-line)
- (looking-at "[ \t]*$")))
- (starter (or (and empty block-comment-start) comment-start))
- (ender (or (and empty block-comment-end) comment-end)))
- (cond
- ((null starter)
- (error "No comment syntax defined"))
- ((null comment-start-skip)
- (error "This mode doesn't define `comment-start-skip'"))
- (t (let* ((eolpos (save-excursion (end-of-line) (point)))
- cpos indent begpos)
- (beginning-of-line)
- (if (re-search-forward comment-start-skip eolpos 'move)
- (progn (setq cpos (point-marker))
- ;; Find the start of the comment delimiter.
- ;; If there were paren-pairs in comment-start-skip,
- ;; position at the end of the first pair.
- (if (match-end 1)
- (goto-char (match-end 1))
- ;; If comment-start-skip matched a string with
- ;; internal whitespace (not final whitespace) then
- ;; the delimiter start at the end of that
- ;; whitespace. Otherwise, it starts at the
- ;; beginning of what was matched.
- (skip-syntax-backward " " (match-beginning 0))
- (skip-syntax-backward "^ " (match-beginning 0)))))
- (setq begpos (point))
- ;; Compute desired indent.
- (if (= (current-column)
- (setq indent (if comment-indent-hook
- (funcall comment-indent-hook)
- (funcall comment-indent-function))))
- (goto-char begpos)
- ;; If that's different from current, change it.
- (skip-chars-backward " \t")
- (delete-region (point) begpos)
- (indent-to indent))
- ;; An existing comment?
- (if cpos
- (progn (goto-char cpos)
- (set-marker cpos nil))
- ;; No, insert one.
- (insert starter)
- (save-excursion
- (insert ender))))))))
-
-(defun set-comment-column (arg)
- "Set the comment column based on point.
-With no arg, set the comment column to the current column.
-With just minus as arg, kill any comment on this line.
-With any other arg, set comment column to indentation of the previous comment
- and then align or create a comment on this line at that column."
- (interactive "P")
- (if (eq arg '-)
- (kill-comment nil)
- (if arg
- (progn
- (save-excursion
- (beginning-of-line)
- (re-search-backward comment-start-skip)
- (beginning-of-line)
- (re-search-forward comment-start-skip)
- (goto-char (match-beginning 0))
- (setq comment-column (current-column))
- (message "Comment column set to %d" comment-column))
- (indent-for-comment))
- (setq comment-column (current-column))
- (message "Comment column set to %d" comment-column))))
-
-(defun kill-comment (arg)
- "Kill the comment on this line, if any.
-With argument, kill comments on that many lines starting with this one."
- ;; this function loses in a lot of situations. it incorrectly recognises
- ;; comment delimiters sometimes (ergo, inside a string), doesn't work
- ;; with multi-line comments, can kill extra whitespace if comment wasn't
- ;; through end-of-line, et cetera.
- (interactive "P")
- (or comment-start-skip (error "No comment syntax defined"))
- (let ((count (prefix-numeric-value arg)) endc)
- (while (> count 0)
- (save-excursion
- (end-of-line)
- (setq endc (point))
- (beginning-of-line)
- (and (string< "" comment-end)
- (setq endc
- (progn
- (re-search-forward (regexp-quote comment-end) endc 'move)
- (skip-chars-forward " \t")
- (point))))
- (beginning-of-line)
- (if (re-search-forward comment-start-skip endc t)
- (progn
- (goto-char (match-beginning 0))
- (skip-chars-backward " \t")
- (kill-region (point) endc)
- ;; to catch comments a line beginnings
- (indent-according-to-mode))))
- (if arg (forward-line 1))
- (setq count (1- count)))))
-
-(defvar comment-padding 1
- "Number of spaces `comment-region' puts between comment chars and text.
-
-Extra spacing between the comment characters and the comment text
-makes the comment easier to read. Default is 1. Nil means 0 and is
-more efficient.")
-
-(defun comment-region (beg end &optional arg)
- "Comment or uncomment each line in the region.
-With just C-u prefix arg, uncomment each line in region.
-Numeric prefix arg ARG means use ARG comment characters.
-If ARG is negative, delete that many comment characters instead.
-Comments are terminated on each line, even for syntax in which newline does
-not end the comment. Blank lines do not get comments."
- ;; if someone wants it to only put a comment-start at the beginning and
- ;; comment-end at the end then typing it, C-x C-x, closing it, C-x C-x
- ;; is easy enough. No option is made here for other than commenting
- ;; every line.
- (interactive "r\nP")
- (or comment-start (error "No comment syntax is defined"))
- (if (> beg end) (let (mid) (setq mid beg beg end end mid)))
- (save-excursion
- (save-restriction
- (let ((cs comment-start) (ce comment-end)
- (cp (when comment-padding
- (make-string comment-padding ? )))
- numarg)
- (if (consp arg) (setq numarg t)
- (setq numarg (prefix-numeric-value arg))
- ;; For positive arg > 1, replicate the comment delims now,
- ;; then insert the replicated strings just once.
- (while (> numarg 1)
- (setq cs (concat cs comment-start)
- ce (concat ce comment-end))
- (setq numarg (1- numarg))))
- ;; Loop over all lines from BEG to END.
- (narrow-to-region beg end)
- (goto-char beg)
- (if (or (eq numarg t) (< numarg 0))
- (while (not (eobp))
- (let (found-comment)
- ;; Delete comment start from beginning of line.
- (if (eq numarg t)
- (while (looking-at (regexp-quote cs))
- (setq found-comment t)
- (delete-char (length cs)))
- (let ((count numarg))
- (while (and (> 1 (setq count (1+ count)))
- (looking-at (regexp-quote cs)))
- (setq found-comment t)
- (delete-char (length cs)))))
- ;; Delete comment padding from beginning of line
- (when (and found-comment comment-padding
- (looking-at (regexp-quote cp)))
- (delete-char comment-padding))
- ;; Delete comment end from end of line.
- (if (string= "" ce)
- nil
- (if (eq numarg t)
- (progn
- (end-of-line)
- ;; This is questionable if comment-end ends in
- ;; whitespace. That is pretty brain-damaged,
- ;; though.
- (while (progn (skip-chars-backward " \t")
- (and (>= (- (point) (point-min)) (length ce))
- (save-excursion
- (backward-char (length ce))
- (looking-at (regexp-quote ce)))))
- (delete-char (- (length ce)))))
- (let ((count numarg))
- (while (> 1 (setq count (1+ count)))
- (end-of-line)
- ;; this is questionable if comment-end ends in whitespace
- ;; that is pretty brain-damaged though
- (skip-chars-backward " \t")
- (if (>= (- (point) (point-min)) (length ce))
- (save-excursion
- (backward-char (length ce))
- (if (looking-at (regexp-quote ce))
- (delete-char (length ce)))))))))
- (forward-line 1)))
-
- (when comment-padding
- (setq cs (concat cs cp)))
- (while (not (eobp))
- ;; Insert at beginning and at end.
- (if (looking-at "[ \t]*$") ()
- (insert cs)
- (if (string= "" ce) ()
- (end-of-line)
- (insert ce)))
- (search-forward "\n" nil 'move)))))))
\f
(defun backward-word (arg)
"Move backward until encountering the end of a word.
(null (setq fc (current-fill-column)))
(and (eq justify 'left)
(<= (current-column) fc))
- (save-excursion (beginning-of-line)
+ (save-excursion (beginning-of-line)
(setq bol (point))
(and auto-fill-inhibit-regexp
(looking-at auto-fill-inhibit-regexp))))
(funcall comment-line-break-function t)))
;; Now do justification, if required
(if (not (eq justify 'left))
- (save-excursion
+ (save-excursion
(end-of-line 0)
(justify-current-line justify nil t)))
;; If making the new line didn't reduce the hpos of
(setq give-up t))))
;; Justify last line.
(justify-current-line justify t t)
- t)))
+ t)))
(defvar normal-auto-fill-function 'do-auto-fill
"The function to use for `auto-fill-function' if Auto Fill mode is turned on.
(defun turn-on-auto-fill ()
"Unconditionally turn on Auto Fill mode."
(auto-fill-mode 1))
+
+(defun turn-off-auto-fill ()
+ "Unconditionally turn off Auto Fill mode."
+ (auto-fill-mode -1))
+
(custom-add-option 'text-mode-hook 'turn-on-auto-fill)
(defun set-fill-column (arg)
(message "Fill column set to %d (was %d)" arg fill-column)
(setq fill-column arg)))
\f
-(defcustom comment-multi-line nil
- "*Non-nil means \\[indent-new-comment-line] should continue same comment
-on new line, with no new terminator or starter.
-This is obsolete because you might as well use \\[newline-and-indent]."
- :type 'boolean
- :group 'fill-comments)
-
-(defun indent-new-comment-line (&optional soft)
- "Break line at point and indent, continuing comment if within one.
-This indents the body of the continued comment
-under the previous comment line.
-
-This command is intended for styles where you write a comment per line,
-starting a new comment (and terminating it if necessary) on each line.
-If you want to continue one comment across several lines, use \\[newline-and-indent].
-
-If a fill column is specified, it overrides the use of the comment column
-or comment indentation.
-
-The inserted newline is marked hard if `use-hard-newlines' is true,
-unless optional argument SOFT is non-nil."
- (interactive)
- (let (comcol comstart)
- (skip-chars-backward " \t")
- (delete-region (point)
- (progn (skip-chars-forward " \t")
- (point)))
- (if soft (insert-and-inherit ?\n) (newline 1))
- (if fill-prefix
- (progn
- (indent-to-left-margin)
- (insert-and-inherit fill-prefix))
- (if (not comment-multi-line)
- (save-excursion
- (if (and comment-start-skip
- (let ((opoint (1- (point)))
- inside)
- (forward-line -1)
- ;; Determine (more or less) whether
- ;; target position is inside a comment.
- (while (and (re-search-forward comment-start-skip opoint t)
- (not (setq inside (or (equal comment-end "")
- (not (search-forward comment-end opoint t)))))))
- inside))
- ;; The old line has a comment and point was inside the comment.
- ;; Set WIN to the pos of the comment-start.
- ;; But if the comment is empty, look at preceding lines
- ;; to find one that has a nonempty comment.
-
- ;; If comment-start-skip contains a \(...\) pair,
- ;; the real comment delimiter starts at the end of that pair.
- (let ((win (or (match-end 1) (match-beginning 0))))
- (while (and (eolp) (not (bobp))
- (let (opoint)
- (beginning-of-line)
- (setq opoint (point))
- (forward-line -1)
- (re-search-forward comment-start-skip opoint t)))
- (setq win (or (match-end 1) (match-beginning 0))))
- ;; Indent this line like what we found.
- (goto-char win)
- (setq comcol (current-column))
- (setq comstart
- (buffer-substring (point) (match-end 0)))))))
- (if comcol
- (let ((comment-column comcol)
- (comment-start comstart)
- (comment-end comment-end))
- (and comment-end (not (equal comment-end ""))
- ; (if (not comment-multi-line)
- (progn
- (forward-char -1)
- (insert comment-end)
- (forward-char 1))
- ; (setq comment-column (+ comment-column (length comment-start))
- ; comment-start "")
- ; )
- )
- (if (not (eolp))
- (setq comment-end ""))
- (insert-and-inherit ?\n)
- (forward-char -1)
- (indent-for-comment)
- (save-excursion
- ;; Make sure we delete the newline inserted above.
- (end-of-line)
- (delete-char 1)))
- (indent-according-to-mode)))))
-\f
(defun set-selective-display (arg)
"Set `selective-display' to ARG; clear it if no arg.
When the value of `selective-display' is a number > 0,
(bury-buffer))))
(define-key global-map "\e\e\e" 'keyboard-escape-quit)
+
+(defcustom input-mode-8-bit t
+ "Control acceptance of 8-bit keyboard input.
+This may be useful for inputting non-ASCII characters if your keyboard
+can generate them. It is not necessary to change this under a window
+system which can distinguish 8-bit characters and Meta keys.
+Setting this variable directly does not take effect;
+use either M-x customize or the function `set-input-mode'."
+ :set (lambda (symbol value)
+ (let ((mode (current-input-mode)))
+ (set-input-mode (nth 0 mode) (nth 1 mode) value)))
+ :initialize 'custom-initialize-default
+ :type '(choice (const :tag "8-bit input for a Meta key" t)
+ (const :tag "Direct 8-bit character input" 0)
+ (const :tag "Assume top bit is parity and ignore" nil))
+ :version "21.1"
+ :link '(custom-manual "Single-Byte European Support")
+ :group 'keyboard)
\f
+(defcustom read-mail-command 'rmail
+ "*Your preference for a mail reading package.
+This is used by some keybindings which support reading mail."
+ :type '(choice (function-item rmail)
+ (function-item gnus)
+ (function-item mh-rmail)
+ (function :tag "Other"))
+ :version "21.1"
+ :group 'mail)
+
(defcustom mail-user-agent 'sendmail-user-agent
"*Your preference for a mail composition package.
Various Emacs Lisp packages (e.g. reporter) require you to compose an
Valid values include:
- sendmail-user-agent -- use the default Emacs Mail package
- mh-e-user-agent -- use the Emacs interface to the MH mail system
- message-user-agent -- use the GNUS mail sending package
+ `sendmail-user-agent' -- use the default Emacs Mail package
+ `mh-e-user-agent' -- use the Emacs interface to the MH mail system
+ `message-user-agent' -- use the GNUS mail sending package
Additional valid symbols may be available; check with the author of
your package for details."
(put symbol 'abortfunc (or abortfunc 'kill-buffer))
(put symbol 'hookvar (or hookvar 'mail-send-hook)))
-(defun assoc-ignore-case (key alist)
- "Like `assoc', but ignores differences in case and text representation.
-KEY must be a string. Upper-case and lower-case letters are treated as equal.
-Unibyte strings are converted to multibyte for comparison."
- (let (element)
- (while (and alist (not element))
- (if (eq t (compare-strings key 0 nil (car (car alist)) 0 nil t))
- (setq element (car alist)))
- (setq alist (cdr alist)))
- element))
-
-(defun assoc-ignore-representation (key alist)
- "Like `assoc', but ignores differences in text representation.
-KEY must be a string.
-Unibyte strings are converted to multibyte for comparison."
- (let (element)
- (while (and alist (not element))
- (if (eq t (compare-strings key 0 nil (car (car alist)) 0 nil))
- (setq element (car alist)))
- (setq alist (cdr alist)))
- element))
-
(define-mail-user-agent 'sendmail-user-agent
'sendmail-user-agent-compose
'mail-send-and-exit)
(same-window-regexps nil))
(funcall switch-function "*mail*")))
(let ((cc (cdr (assoc-ignore-case "cc" other-headers)))
- (in-reply-to (cdr (assoc-ignore-case "in-reply-to" other-headers))))
+ (in-reply-to (cdr (assoc-ignore-case "in-reply-to" other-headers)))
+ (body (cdr (assoc-ignore-case "body" other-headers))))
(or (mail continue to subject in-reply-to cc yank-action send-actions)
continue
(error "Message aborted"))
(save-excursion
(rfc822-goto-eoh)
(while other-headers
- (if (not (member (car (car other-headers)) '("in-reply-to" "cc")))
+ (unless (member-ignore-case (car (car other-headers))
+ '("in-reply-to" "cc" "body"))
(insert (car (car other-headers)) ": "
(cdr (car other-headers)) "\n"))
(setq other-headers (cdr other-headers)))
+ (when body
+ (forward-line 1)
+ (insert body))
t)))
(define-mail-user-agent 'mh-e-user-agent
(require 'wid-edit)
(setq type (widget-convert type))
(unless (widget-apply type :match val)
- (error "Value `%S' does not match type %S of %S"
+ (error "Value `%S' does not match type %S of %S"
val (car type) var))))
(set var val))
\f
;; unless it is reading a file name and CHOICE is a directory,
;; or completion-no-auto-exit is non-nil.
(defun choose-completion-string (choice &optional buffer base-size)
- (let ((buffer (or buffer completion-reference-buffer)))
+ (let ((buffer (or buffer completion-reference-buffer))
+ (mini-p (string-match "\\` \\*Minibuf-[0-9]+\\*\\'" (buffer-name buffer))))
;; If BUFFER is a minibuffer, barf unless it's the currently
;; active minibuffer.
- (if (and (string-match "\\` \\*Minibuf-[0-9]+\\*\\'" (buffer-name buffer))
+ (if (and mini-p
(or (not (active-minibuffer-window))
(not (equal buffer
(window-buffer (active-minibuffer-window))))))
;; Insert the completion into the buffer where completion was requested.
(set-buffer buffer)
(if base-size
- (delete-region (+ base-size (point-min)) (point))
+ (delete-region (+ base-size (if mini-p
+ (minibuffer-prompt-end)
+ (point-min)))
+ (point))
(choose-completion-delete-max-match choice))
(insert choice)
(remove-text-properties (- (point) (length choice)) (point)
;; If this is reading a file name, and the file name chosen
;; is a directory, don't exit the minibuffer.
(if (and (eq minibuffer-completion-table 'read-file-name-internal)
- (file-directory-p (buffer-string)))
+ (file-directory-p (field-string (point-max))))
(select-window (active-minibuffer-window))
(exit-minibuffer))))))
(set-buffer mainbuf)
(goto-char (point-max))
(skip-chars-backward (format "^%c" directory-sep-char))
- (- (point) (point-min))))
+ (- (point) (minibuffer-prompt-end))))
;; Otherwise, in minibuffer, the whole input is being completed.
(save-match-data
(if (string-match "\\` \\*Minibuf-[0-9]+\\*\\'"
(buffer-name mainbuf))
(setq completion-base-size 0))))
(goto-char (point-min))
- (if window-system
+ (if (display-mouse-p)
(insert (substitute-command-keys
"Click \\[mouse-choose-completion] on a completion to select it.\n")))
(insert (substitute-command-keys
(kp-divide ?/)
(kp-equal ?=)))
+;;;;
+;;;; forking a twin copy of a buffer.
+;;;;
+
+(defvar clone-buffer-hook nil
+ "Normal hook to run in the new buffer at the end of `clone-buffer'.")
+
+(defun clone-process (process &optional newname)
+ "Create a twin copy of PROCESS.
+If NEWNAME is nil, it defaults to PROCESS' name;
+NEWNAME is modified by adding or incrementing <N> at the end as necessary.
+If PROCESS is associated with a buffer, the new process will be associated
+ with the current buffer instead.
+Returns nil if PROCESS has already terminated."
+ (setq newname (or newname (process-name process)))
+ (if (string-match "<[0-9]+>\\'" newname)
+ (setq newname (substring newname 0 (match-beginning 0))))
+ (when (memq (process-status process) '(run stop open))
+ (let* ((process-connection-type (process-tty-name process))
+ (old-kwoq (process-kill-without-query process nil))
+ (new-process
+ (if (memq (process-status process) '(open))
+ (apply 'open-network-stream newname
+ (if (process-buffer process) (current-buffer))
+ (process-contact process))
+ (apply 'start-process newname
+ (if (process-buffer process) (current-buffer))
+ (process-command process)))))
+ (process-kill-without-query new-process old-kwoq)
+ (process-kill-without-query process old-kwoq)
+ (set-process-inherit-coding-system-flag
+ new-process (process-inherit-coding-system-flag process))
+ (set-process-filter new-process (process-filter process))
+ (set-process-sentinel new-process (process-sentinel process))
+ new-process)))
+
+;; things to maybe add (currently partly covered by `funcall mode':
+;; - syntax-table
+;; - overlays
+(defun clone-buffer (&optional newname display-flag)
+ "Create a twin copy of the current buffer.
+If NEWNAME is nil, it defaults to the current buffer's name;
+NEWNAME is modified by adding or incrementing <N> at the end as necessary.
+
+If DISPLAY-FLAG is non-nil, the new buffer is shown with `pop-to-buffer'.
+This runs the normal hook `clone-buffer-hook' in the new buffer
+after it has been set up properly in other respects."
+ (interactive (list (if current-prefix-arg (read-string "Name: "))
+ t))
+ (if buffer-file-name
+ (error "Cannot clone a file-visiting buffer"))
+ (if (get major-mode 'no-clone)
+ (error "Cannot clone a buffer in %s mode" mode-name))
+ (setq newname (or newname (buffer-name)))
+ (if (string-match "<[0-9]+>\\'" newname)
+ (setq newname (substring newname 0 (match-beginning 0))))
+ (let ((buf (current-buffer))
+ (ptmin (point-min))
+ (ptmax (point-max))
+ (pt (point))
+ (mk (if mark-active (mark t)))
+ (modified (buffer-modified-p))
+ (mode major-mode)
+ (lvars (buffer-local-variables))
+ (process (get-buffer-process (current-buffer)))
+ (new (generate-new-buffer (or newname (buffer-name)))))
+ (save-restriction
+ (widen)
+ (with-current-buffer new
+ (insert-buffer-substring buf)))
+ (with-current-buffer new
+ (narrow-to-region ptmin ptmax)
+ (goto-char pt)
+ (if mk (set-mark mk))
+ (set-buffer-modified-p modified)
+
+ ;; Clone the old buffer's process, if any.
+ (when process (clone-process process))
+
+ ;; Now set up the major mode.
+ (funcall mode)
+
+ ;; Set up other local variables.
+ (mapcar (lambda (v)
+ (condition-case () ;in case var is read-only
+ (if (symbolp v)
+ (makunbound v)
+ (set (make-local-variable (car v)) (cdr v)))
+ (error nil)))
+ lvars)
+
+ ;; Run any hooks (typically set up by the major mode
+ ;; for cloning to work properly).
+ (run-hooks 'clone-buffer-hook))
+ (if display-flag (pop-to-buffer new))
+ new))
+
+
+(defun clone-indirect-buffer (newname display-flag &optional norecord)
+ "Create an indirect buffer that is a twin copy of the current buffer.
+
+Give the indirect buffer name NEWNAME. Interactively, read NEW-NAME
+from the minibuffer when invoked with a prefix arg. If NEWNAME is nil
+or if not called with a prefix arg, NEWNAME defaults to the current
+buffer's name. The name is modified by adding a `<N>' suffix to it
+or by incrementing the N in an existing suffix.
+
+DISPLAY-FLAG non-nil means show the new buffer with `pop-to-buffer'.
+This is always done when called interactively.
+
+Optional last arg NORECORD non-nil means do not put this buffer at the
+front of the list of recently selected ones."
+ (interactive (list (if current-prefix-arg
+ (read-string "BName of indirect buffer: "))
+ t))
+ (setq newname (or newname (buffer-name)))
+ (if (string-match "<[0-9]+>\\'" newname)
+ (setq newname (substring newname 0 (match-beginning 0))))
+ (let* ((name (generate-new-buffer-name newname))
+ (buffer (make-indirect-buffer (current-buffer) name t)))
+ (when display-flag
+ (pop-to-buffer buffer))
+ buffer))
+
+
+(defun clone-indirect-buffer-other-window (buffer &optional norecord)
+ "Create an indirect buffer that is a twin copy of BUFFER.
+Select the new buffer in another window.
+Optional second arg NORECORD non-nil means do not put this buffer at
+the front of the list of recently selected ones."
+ (interactive "bClone buffer in other window: ")
+ (let ((popup-windows t))
+ (set-buffer buffer)
+ (clone-indirect-buffer nil t norecord)))
+
+(define-key ctl-x-4-map "c" 'clone-indirect-buffer-other-window)
+
+\f
+;;; Syntax stuff.
+
+(defconst syntax-code-table
+ '((?\ 0 "whitespace")
+ (?- 0 "whitespace")
+ (?. 1 "punctuation")
+ (?w 2 "word")
+ (?_ 3 "symbol")
+ (?\( 4 "open parenthesis")
+ (?\) 5 "close parenthesis")
+ (?\' 6 "expression prefix")
+ (?\" 7 "string quote")
+ (?$ 8 "paired delimiter")
+ (?\\ 9 "escape")
+ (?/ 10 "character quote")
+ (?< 11 "comment start")
+ (?> 12 "comment end")
+ (?@ 13 "inherit")
+ (nil 14 "comment fence")
+ (nil 15 "string fence"))
+ "Alist of forms (CHAR CODE DESCRIPTION) mapping characters to syntax info.
+CHAR is a character that is allowed as first char in the string
+specifying the syntax when calling `modify-syntax-entry'. CODE is the
+corresponing syntax code as it is stored in a syntax cell, and
+can be used as value of a `syntax-table' property.
+DESCRIPTION is the descriptive string for the syntax.")
+
+(defconst syntax-flag-table
+ '((?1 . #b10000000000000000)
+ (?2 . #b100000000000000000)
+ (?3 . #b1000000000000000000)
+ (?4 . #b10000000000000000000)
+ (?p . #b100000000000000000000)
+ (?b . #b1000000000000000000000)
+ (?n . #b10000000000000000000000))
+ "Alist of pairs (CHAR . FLAG) mapping characters to syntax flags.
+CHAR is a character that is allowed as second or following character
+in the string argument to `modify-syntax-entry' specifying the syntax.
+FLAG is the corresponding syntax flag value that is stored in a
+syntax table.")
+
+(defun string-to-syntax (string)
+ "Convert a syntax specification STRING into syntax cell form.
+STRING should be a string as it is allowed as argument of
+`modify-syntax-entry'. Value is the equivalent cons cell
+\(CODE . MATCHING-CHAR) that can be used as value of a `syntax-table'
+text property."
+ (let* ((first-char (aref string 0))
+ (code (or (nth 1 (assq first-char syntax-code-table))
+ (error "Invalid syntax specification `%s'" string)))
+ (length (length string))
+ (i 1)
+ matching-char)
+ ;; Determine the matching character, if any.
+ (when (and (> length 1)
+ (memq first-char '(?\( ?\))))
+ (setq matching-char (aref string i)
+ i (1+ i)))
+ ;; Add any flags to the syntax code.
+ (while (< i length)
+ (let ((flag (or (assq (aref string i) syntax-flag-table)
+ (error "Invalid syntax flag in `%s'" string))))
+ (setq code (logior flag code))
+ (setq i (1+ i))))
+
+ (cons code matching-char)))
+
;;; simple.el ends here