;;; Code:
(eval-when-compile
+ (autoload 'widget-convert "wid-edit")
+ (autoload 'shell-mode "shell")
(require 'cl))
"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)
(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.
(push-mark (point))
(push-mark (point-max) nil t)
(goto-char (point-min)))
+
\f
;; Counting lines, one way or another.
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))
(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 (nth 2 (find-composition (point)))
- " (composed)" ""))))
+ (encoded-string-description encoded coding)))
(format "(0%o, %d, 0x%x)" char char char))))
(if detail
- ;; We show the detailed information of CHAR.
- (message "Char: %s %s %s"
- (if (< char 256)
- (single-key-description char)
- (buffer-substring-no-properties (point) (1+ (point))))
- encoding-msg (split-char char))
- (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-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"
+ ;; 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-no-properties (point) (1+ (point))))
- encoding-msg pos total percent col hscroll)))))))
+ 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.")
(defcustom eval-expression-print-length 12
"*Value to use for `print-length' when printing value in `eval-expression'."
:group 'lisp
- :type 'integer
+ :type '(choice (const nil) integer)
:version "21.1")
(defcustom eval-expression-debug-on-error 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
(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))))
(region-beginning) (region-end)))
(let ((oldbuf (current-buffer)))
(save-excursion
- (set-buffer (get-buffer-create buffer))
- (barf-if-buffer-read-only)
- (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.
;; with intangibility and point-motion hooks enabled this time.
(goto-char opoint)
(setq inhibit-point-motion-hooks nil)
- (goto-char (constrain-to-field new opoint t t))
+ (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 (constrain-to-field new opoint t t))
+ (goto-char (constrain-to-field new opoint nil t
+ 'inhibit-line-move-field-capture))
)))
nil)
(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.
-
-The strings used as comment starts are build from
-`comment-start' without trailing spaces and `comment-padding'."
- ;; 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* ((comment-start
- (substring comment-start 0
- (string-match "[ \t]*$" comment-start)))
- (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.
(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,
\f
(defcustom read-mail-command 'rmail
"*Your preference for a mail reading package.
-This is used by some keybindings which support reading mail."
+This is used by some keybindings which support reading mail.
+See also `mail-user-agent' concerning sending mail."
:type '(choice (function-item rmail)
(function-item gnus)
(function-item mh-rmail)
(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
+Various Emacs Lisp packages (e.g. Reporter) require you to compose an
outgoing email message. This variable lets you specify which
mail-sending package you prefer.
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.
+ See Info node `(emacs)Sending Mail'.
+ `mh-e-user-agent' -- use the Emacs interface to the MH mail system.
+ See Info node `(mh-e)'.
+ `message-user-agent' -- use the Gnus Message package.
+ See Info node `(message)'.
+ `gnus-user-agent' -- like `message-user-agent', but with Gnus
+ paraphernalia, particularly the Gcc: header for
+ archiving.
Additional valid symbols may be available; check with the author of
-your package for details."
+your package for details.
+
+See also `read-mail-command' concerning reading mail."
:type '(radio (function-item :tag "Default Emacs mail"
:format "%t\n"
sendmail-user-agent)
(function-item :tag "Emacs interface to MH"
:format "%t\n"
mh-e-user-agent)
- (function-item :tag "Gnus mail sending package"
+ (function-item :tag "Gnus Message package"
:format "%t\n"
message-user-agent)
+ (function-item :tag "Gnus Message with full Gnus features"
+ :format "%t\n"
+ gnus-user-agent)
(function :tag "Other"))
:group 'mail)
(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 (assoc-ignore-case (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
(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
(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
HCoop / bpt / emacs.git / blobdiff