CASK = cask
EMACS = emacs
DEPENDENCIES = .cask/
+ SCOPIFIER_PORT = $$(lsof -t -i :6969)
+ KILL_SCOPIFIER = if [ -n "${SCOPIFIER_PORT}" ]; then kill ${SCOPIFIER_PORT}; fi
all: uncompile compile test
${CASK}
test: ${DEPENDENCIES}
+ ${KILL_SCOPIFIER}
${CASK} exec ${EMACS} -Q -batch \
-L . \
-l ert \
-f ert-run-tests-batch-and-exit
cover: ${DEPENDENCIES}
+ ${KILL_SCOPIFIER}
${CASK} exec ${EMACS} -Q -batch \
-L . \
-l ert \
- Light and dark (customizable) color schemes.
- JavaScript support:
- - Very fast for files under 1000 lines.
- Script, function and block scopes (and even `catch` block scopes).
+ - Very fast for files under 1000 lines.
- Emacs Lisp support:
- - `defun`, `lambda`, `let`, `let*`, quotes, backticks, commas.
+ - `defun`, `lambda`, `let`, `let*`, `cond`, `condition-case`, quotes,
+ backquotes (and splicing).
+ - 25,000 lines per second!
## Installation
comments using `font-lock`.
- `context-coloring-syntactic-strings` (default: `t`): If non-nil, also color
strings using `font-lock`.
- - `context-coloring-delay` (default: `0.25`; supported modes: `js-mode`,
- `js3-mode`, `emacs-lisp-mode`): Delay between a buffer update and
+ - `context-coloring-default-delay` (default: `0.25`; supported modes: `js-mode`,
+ `js3-mode`): Default (sometimes overridden) delay between a buffer update and
colorization.
- `context-coloring-js-block-scopes` (default: `nil`; supported modes:
`js2-mode`): If non-nil, also color block scopes in the scope hierarchy in
"Resolve PATH from this file's directory."
(expand-file-name path context-coloring-benchmark-path))
- (defun context-coloring-benchmark-log-results (result-file fixture)
- "Log benchmarking results to RESULT-FILE for fixture FIXTURE."
- (elp-results)
- (let ((results-buffer (current-buffer)))
- (with-temp-buffer
- (insert (concat fixture "\n"))
- (prepend-to-buffer results-buffer (point-min) (point-max)))
- (with-temp-buffer
- (insert "\n")
- (append-to-buffer results-buffer (point-min) (point-max))))
- (make-directory (context-coloring-benchmark-resolve-path "./logs") t)
- (append-to-file nil nil result-file))
-
- (defun context-coloring-benchmark-next-tick (function)
- "Defer execution of FUNCTION to clear the stack and to ensure
- asynchrony."
- (run-at-time 0.001 nil function))
-
- (defun context-coloring-benchmark-next (list continue stop)
- "Run the next test in LIST by calling CONTINUE. When LIST is
- exhausted, call STOP instead."
- (if (null list)
- (progn
- (context-coloring-benchmark-next-tick stop))
- (context-coloring-benchmark-next-tick
+ (defun context-coloring-benchmark-next-tick (callback)
+ "Run CALLBACK in the next turn of the event loop."
+ (run-with-timer nil nil callback))
+
+ (defun context-coloring-benchmark-series (sequence callback)
+ "Call each function in SEQUENCE, then call CALLBACK. Each
+ function is passed a single callback parameter for it to call
+ when it is done."
+ (cond
+ ((null sequence)
+ (funcall callback))
+ (t
+ (funcall
+ (car sequence)
(lambda ()
- (funcall
- continue
- (car list)
+ (context-coloring-benchmark-next-tick
(lambda ()
- (context-coloring-benchmark-next (cdr list) continue stop)))))))
-
- (defun context-coloring-benchmark-async (title setup teardown fixtures callback)
+ (context-coloring-benchmark-series
+ (cdr sequence)
+ callback))))))))
+
+ (defun context-coloring-benchmark-mapc (sequence iteratee callback)
+ "For each element in SEQUENCE, call ITERATEE, finally call
+ CALLBACK. ITERATEE is passed the current element and a callback
+ for it to call when it is done."
+ (cond
+ ((null sequence)
+ (funcall callback))
+ (t
+ (funcall
+ iteratee
+ (car sequence)
+ (lambda ()
+ (context-coloring-benchmark-next-tick
+ (lambda ()
+ (context-coloring-benchmark-mapc
+ (cdr sequence)
+ iteratee
+ callback))))))))
+
+ (defun context-coloring-benchmark-log-results (result-file fixture statistics)
+ "Log benchmarking results to RESULT-FILE for fixture FIXTURE
+ with STATISTICS."
+ (let ((results (prog1
+ (progn
+ (elp-results)
+ (buffer-substring-no-properties (point-min) (point-max)))
+ (kill-buffer))))
+ (make-directory (context-coloring-benchmark-resolve-path "./logs") t)
+ (append-to-file
+ (with-temp-buffer
+ (goto-char (point-min))
+ (insert (format "For fixture \"%s\":\n" fixture))
+ (insert "\n")
+ (insert "General statistics:\n")
+ (insert (format "File size: %s bytes\n" (plist-get statistics :file-size)))
+ (insert (format "Lines: %s\n" (plist-get statistics :lines)))
+ (insert (format "Words: %s\n" (plist-get statistics :words)))
+ (insert (format "Colorization times: %s\n"
+ (context-coloring-join
+ (mapcar (lambda (number)
+ (format "%.4f" number))
+ (plist-get statistics :colorization-times)) ", ")))
+ (insert (format "Average colorization time: %.4f\n"
+ (plist-get statistics :average-colorization-time)))
+ (insert "\n")
+ (insert "Function statistics:\n")
+ (insert "(Function Name / Call Count / Elapsed Time / Average Time):\n")
+ (insert results)
+ (insert "\n")
+ (buffer-substring-no-properties (point-min) (point-max)))
+ nil result-file)))
+
+ (defun context-coloring-benchmark (title setup teardown fixtures callback)
"Execute a benchmark titled TITLE with SETUP and TEARDOWN
callbacks. Measure the performance of all FIXTURES, calling
CALLBACK when all are done."
(funcall setup)
+ (elp-instrument-package "context-coloring-")
(let ((result-file (context-coloring-benchmark-resolve-path
(format "./logs/results-%s-%s.log"
title (format-time-string "%s")))))
- (context-coloring-benchmark-next
+ (context-coloring-benchmark-mapc
fixtures
- (lambda (path next)
+ (lambda (path callback)
(let ((fixture (context-coloring-benchmark-resolve-path path))
+ colorization-start-time
+ (colorization-times '())
advice)
(setq
advice
original-function
(lambda ()
(setq count (+ count 1))
+ (push (- (float-time) colorization-start-time) colorization-times)
;; Test 5 times.
- (if (= count 5)
- (progn
- (advice-remove 'context-coloring-colorize advice)
- (kill-buffer)
- (context-coloring-benchmark-log-results
- result-file
- fixture)
- (funcall next))
- (funcall 'context-coloring-colorize)))))))
- (advice-add 'context-coloring-colorize :around advice)
+ (cond
+ ((= count 5)
+ (advice-remove #'context-coloring-colorize advice)
+ (context-coloring-benchmark-log-results
+ result-file
+ fixture
+ (list
+ :file-size (nth 7 (file-attributes fixture))
+ :lines (count-lines (point-min) (point-max))
+ :words (count-words (point-min) (point-max))
+ :colorization-times colorization-times
+ :average-colorization-time (/ (apply #'+ colorization-times) 5)))
+ (kill-buffer)
+ (funcall callback))
+ (t
+ (setq colorization-start-time (float-time))
+ (context-coloring-colorize))))))))
+ (advice-add #'context-coloring-colorize :around advice)
+ (setq colorization-start-time (float-time))
(find-file fixture)))
(lambda ()
(funcall teardown)
- (when callback (funcall callback))))))
+ (funcall callback)))))
(defconst context-coloring-benchmark-js-fixtures
'("./fixtures/jquery-2.1.1.js"
"./fixtures/mkdirp-0.5.0.js")
"Arbitrary JavaScript files for performance scrutiny.")
- (defun context-coloring-benchmark-js-mode-setup ()
- "Preparation logic for `js-mode'."
- (add-hook 'js-mode-hook 'context-coloring-mode)
- (elp-instrument-package "context-coloring-"))
-
- (defun context-coloring-benchmark-js-mode-teardown ()
- "Cleanup logic for `js-mode'."
- (remove-hook 'js-mode-hook 'context-coloring-mode))
-
(defun context-coloring-benchmark-js-mode-run (callback)
"Benchmark `js-mode', then call CALLBACK."
- (context-coloring-benchmark-async
+ (context-coloring-benchmark
"js-mode"
- 'context-coloring-benchmark-js-mode-setup
- 'context-coloring-benchmark-js-mode-teardown
+ (lambda ()
+ "Preparation logic for `js-mode'."
+ (add-hook 'js-mode-hook #'context-coloring-mode))
+ (lambda ()
+ "Cleanup logic for `js-mode'."
+ (remove-hook 'js-mode-hook #'context-coloring-mode))
context-coloring-benchmark-js-fixtures
callback))
- (defun context-coloring-benchmark-js2-mode-setup ()
- "Preparation logic for `js2-mode'."
- (setq js2-mode-show-parse-errors nil)
- (setq js2-mode-show-strict-warnings nil)
- (add-to-list 'auto-mode-alist '("\\.js\\'" . js2-mode))
- (add-hook 'js2-mode-hook 'context-coloring-mode)
- (elp-instrument-package "context-coloring-"))
-
- (defun context-coloring-benchmark-js2-mode-teardown ()
- "Cleanup logic for `js2-mode'."
- (remove-hook 'js2-mode-hook 'context-coloring-mode)
- (setq auto-mode-alist (delete '("\\.js\\'" . js2-mode)
- auto-mode-alist))
- (setq js2-mode-show-strict-warnings t)
- (setq js2-mode-show-parse-errors t))
-
(defun context-coloring-benchmark-js2-mode-run (callback)
"Benchmark `js2-mode', then call CALLBACK."
- (context-coloring-benchmark-async
+ (context-coloring-benchmark
"js2-mode"
- 'context-coloring-benchmark-js2-mode-setup
- 'context-coloring-benchmark-js2-mode-teardown
+ (lambda ()
+ "Preparation logic for `js2-mode'."
+ (setq js2-mode-show-parse-errors nil)
+ (setq js2-mode-show-strict-warnings nil)
+ (add-to-list 'auto-mode-alist '("\\.js\\'" . js2-mode))
+ (add-hook 'js2-mode-hook #'context-coloring-mode))
+ (lambda ()
+ "Cleanup logic for `js2-mode'."
+ (remove-hook 'js2-mode-hook #'context-coloring-mode)
+ (setq auto-mode-alist (delete '("\\.js\\'" . js2-mode)
+ auto-mode-alist))
+ (setq js2-mode-show-strict-warnings t)
+ (setq js2-mode-show-parse-errors t))
context-coloring-benchmark-js-fixtures
callback))
+ (defconst context-coloring-benchmark-emacs-lisp-fixtures
+ '("./fixtures/lisp.el"
+ "./fixtures/faces.el"
+ "./fixtures/subr.el"
+ "./fixtures/simple.el")
+ "Arbitrary Emacs Lisp files for performance scrutiny.")
+
+ (defun context-coloring-benchmark-emacs-lisp-mode-run (callback)
+ "Benchmark `emacs-lisp-mode', then call CALLBACK."
+ (context-coloring-benchmark
+ "emacs-lisp-mode"
+ (lambda ()
+ "Preparation logic for `emacs-lisp-mode'."
+ (add-hook 'emacs-lisp-mode-hook #'context-coloring-mode))
+ (lambda ()
+ "Cleanup logic for `emacs-lisp-mode'."
+ (remove-hook 'emacs-lisp-mode-hook #'context-coloring-mode))
+ context-coloring-benchmark-emacs-lisp-fixtures
+ callback))
+
(defun context-coloring-benchmark-run ()
"Benchmark all modes, then exit."
- (context-coloring-benchmark-next
- '(context-coloring-benchmark-js-mode-run
- context-coloring-benchmark-js2-mode-run)
- (lambda (function next)
- (funcall function next))
+ (context-coloring-benchmark-series
+ (list
+ #'context-coloring-benchmark-js-mode-run
+ #'context-coloring-benchmark-js2-mode-run
+ #'context-coloring-benchmark-emacs-lisp-mode-run)
(lambda ()
(kill-emacs))))
--- /dev/null
+ ;;; faces.el --- Lisp faces
+
+ ;; Copyright (C) 1992-1996, 1998-2015 Free Software Foundation, Inc.
+
+ ;; Maintainer: emacs-devel@gnu.org
+ ;; Keywords: internal
+ ;; Package: emacs
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+
+ ;;; Code:
+
+ (defcustom term-file-prefix (purecopy "term/")
+ "If non-nil, Emacs startup performs terminal-specific initialization.
+ It does this by: (load (concat term-file-prefix (getenv \"TERM\")))
+
+ You may set this variable to nil in your init file if you do not wish
+ the terminal-initialization file to be loaded."
+ :type '(choice (const :tag "No terminal-specific initialization" nil)
+ (string :tag "Name of directory with term files"))
+ :group 'terminals)
+
+ (declare-function xw-defined-colors "term/common-win" (&optional frame))
+
+ (defvar help-xref-stack-item)
+
+ (defvar face-name-history nil
+ "History list for some commands that read face names.
+ Maximum length of the history list is determined by the value
+ of `history-length', which see.")
+
+ \f
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;; Font selection.
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (defgroup font-selection nil
+ "Influencing face font selection."
+ :group 'faces)
+
+
+ (defcustom face-font-selection-order
+ '(:width :height :weight :slant)
+ "A list specifying how face font selection chooses fonts.
+ Each of the four symbols `:width', `:height', `:weight', and `:slant'
+ must appear once in the list, and the list must not contain any other
+ elements. Font selection first tries to find a best matching font
+ for those face attributes that appear before in the list. For
+ example, if `:slant' appears before `:height', font selection first
+ tries to find a font with a suitable slant, even if this results in
+ a font height that isn't optimal."
+ :tag "Font selection order"
+ :type '(list symbol symbol symbol symbol)
+ :group 'font-selection
+ :set #'(lambda (symbol value)
+ (set-default symbol value)
+ (internal-set-font-selection-order value)))
+
+
+ ;; In the absence of Fontconfig support, Monospace and Sans Serif are
+ ;; unavailable, and we fall back on the courier and helv families,
+ ;; which are generally available.
+ (defcustom face-font-family-alternatives
+ (mapcar (lambda (arg) (mapcar 'purecopy arg))
+ '(("Monospace" "courier" "fixed")
+ ("courier" "CMU Typewriter Text" "fixed")
+ ("Sans Serif" "helv" "helvetica" "arial" "fixed")
+ ("helv" "helvetica" "arial" "fixed")))
+ "Alist of alternative font family names.
+ Each element has the form (FAMILY ALTERNATIVE1 ALTERNATIVE2 ...).
+ If fonts of family FAMILY can't be loaded, try ALTERNATIVE1, then
+ ALTERNATIVE2 etc."
+ :tag "Alternative font families to try"
+ :type '(repeat (repeat string))
+ :group 'font-selection
+ :set #'(lambda (symbol value)
+ (set-default symbol value)
+ (internal-set-alternative-font-family-alist value)))
+
+
+ ;; This is defined originally in xfaces.c.
+ (defcustom face-font-registry-alternatives
+ (mapcar (lambda (arg) (mapcar 'purecopy arg))
+ (if (featurep 'w32)
+ '(("iso8859-1" "ms-oemlatin")
+ ("gb2312.1980" "gb2312" "gbk" "gb18030")
+ ("jisx0208.1990" "jisx0208.1983" "jisx0208.1978")
+ ("ksc5601.1989" "ksx1001.1992" "ksc5601.1987")
+ ("muletibetan-2" "muletibetan-0"))
+ '(("gb2312.1980" "gb2312.80&gb8565.88" "gbk" "gb18030")
+ ("jisx0208.1990" "jisx0208.1983" "jisx0208.1978")
+ ("ksc5601.1989" "ksx1001.1992" "ksc5601.1987")
+ ("muletibetan-2" "muletibetan-0"))))
+ "Alist of alternative font registry names.
+ Each element has the form (REGISTRY ALTERNATIVE1 ALTERNATIVE2 ...).
+ If fonts of registry REGISTRY can be loaded, font selection
+ tries to find a best matching font among all fonts of registry
+ REGISTRY, ALTERNATIVE1, ALTERNATIVE2, and etc."
+ :tag "Alternative font registries to try"
+ :type '(repeat (repeat string))
+ :version "21.1"
+ :group 'font-selection
+ :set #'(lambda (symbol value)
+ (set-default symbol value)
+ (internal-set-alternative-font-registry-alist value)))
+
+ \f
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;; Creation, copying.
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+ (defun face-list ()
+ "Return a list of all defined faces."
+ (mapcar #'car face-new-frame-defaults))
+
+ (defun make-face (face &optional no-init-from-resources)
+ "Define a new face with name FACE, a symbol.
+ Do not call this directly from Lisp code; use `defface' instead.
+
+ If FACE is already known as a face, leave it unmodified. Return FACE.
+
+ NO-INIT-FROM-RESOURCES has been deprecated and is no longer used
+ and will go away. Handling of conditional X resources application
+ has been pushed down to make-x-resource-internal itself."
+ (interactive (list (read-from-minibuffer
+ "Make face: " nil nil t 'face-name-history)))
+ (unless (facep face)
+ ;; Make frame-local faces (this also makes the global one).
+ (dolist (frame (frame-list))
+ (internal-make-lisp-face face frame))
+ ;; Add the face to the face menu.
+ (when (fboundp 'facemenu-add-new-face)
+ (facemenu-add-new-face face))
+ ;; Define frame-local faces for all frames from X resources.
+ (make-face-x-resource-internal face))
+ face)
+
+ ;; Handling of whether to apply X resources or not, has been pushed down
+ ;; to make-face-x-resource-internal itself, thus the optional arg is no
+ ;; longer evaluated at all and going away.
+ (set-advertised-calling-convention 'make-face '(face) "24.4")
+
+ (defun make-empty-face (face)
+ "Define a new, empty face with name FACE.
+ Do not call this directly from Lisp code; use `defface' instead."
+ (interactive (list (read-from-minibuffer
+ "Make empty face: " nil nil t 'face-name-history)))
+ (make-face face))
+
+ (defun copy-face (old-face new-face &optional frame new-frame)
+ "Define a face named NEW-FACE, which is a copy of OLD-FACE.
+ This function does not copy face customization data, so NEW-FACE
+ will not be made customizable. Most Lisp code should not call
+ this function; use `defface' with :inherit instead.
+
+ If NEW-FACE already exists as a face, modify it to be like
+ OLD-FACE. If NEW-FACE doesn't already exist, create it.
+
+ If the optional argument FRAME is a frame, change NEW-FACE on
+ FRAME only. If FRAME is t, copy the frame-independent default
+ specification for OLD-FACE to NEW-FACE. If FRAME is nil, copy
+ the defaults as well as the faces on each existing frame.
+
+ If the optional fourth argument NEW-FRAME is given, copy the
+ information from face OLD-FACE on frame FRAME to NEW-FACE on
+ frame NEW-FRAME. In this case, FRAME must not be nil."
+ (let ((inhibit-quit t))
+ (if (null frame)
+ (progn
+ (when new-frame
+ (error "Copying face %s from all frames to one frame"
+ old-face))
+ (make-empty-face new-face)
+ (dolist (frame (frame-list))
+ (copy-face old-face new-face frame))
+ (copy-face old-face new-face t))
+ (make-empty-face new-face)
+ (internal-copy-lisp-face old-face new-face frame new-frame))
+ new-face))
+
+ \f
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;; Predicates, type checks.
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (defun facep (face)
+ "Return non-nil if FACE is a face name; nil otherwise.
+ A face name can be a string or a symbol."
+ (internal-lisp-face-p face))
+
+
+ (defun check-face (face)
+ "Signal an error if FACE doesn't name a face.
+ Value is FACE."
+ (unless (facep face)
+ (error "Not a face: %s" face))
+ face)
+
+
+ ;; The ID returned is not to be confused with the internally used IDs
+ ;; of realized faces. The ID assigned to Lisp faces is used to
+ ;; support faces in display table entries.
+
+ (defun face-id (face &optional _frame)
+ "Return the internal ID of face with name FACE.
+ If FACE is a face-alias, return the ID of the target face.
+ The optional argument FRAME is ignored, since the internal face ID
+ of a face name is the same for all frames."
+ (check-face face)
+ (or (get face 'face)
+ (face-id (get face 'face-alias))))
+
+ (defun face-equal (face1 face2 &optional frame)
+ "Non-nil if faces FACE1 and FACE2 are equal.
+ Faces are considered equal if all their attributes are equal.
+ If the optional argument FRAME is given, report on FACE1 and FACE2 in that frame.
+ If FRAME is t, report on the defaults for FACE1 and FACE2 (for new frames).
+ If FRAME is omitted or nil, use the selected frame."
+ (internal-lisp-face-equal-p face1 face2 frame))
+
+
+ (defun face-differs-from-default-p (face &optional frame)
+ "Return non-nil if FACE displays differently from the default face.
+ If the optional argument FRAME is given, report on face FACE in that frame.
+ If FRAME is t, report on the defaults for face FACE (for new frames).
+ If FRAME is omitted or nil, use the selected frame."
+ (let ((attrs
+ (delq :inherit (mapcar 'car face-attribute-name-alist)))
+ (differs nil))
+ (while (and attrs (not differs))
+ (let* ((attr (pop attrs))
+ (attr-val (face-attribute face attr frame t)))
+ (when (and
+ (not (eq attr-val 'unspecified))
+ (display-supports-face-attributes-p (list attr attr-val)
+ frame))
+ (setq differs attr))))
+ differs))
+
+
+ (defun face-nontrivial-p (face &optional frame)
+ "True if face FACE has some non-nil attribute.
+ If the optional argument FRAME is given, report on face FACE in that frame.
+ If FRAME is t, report on the defaults for face FACE (for new frames).
+ If FRAME is omitted or nil, use the selected frame."
+ (not (internal-lisp-face-empty-p face frame)))
+
+
+ \f
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;; Setting face attributes from X resources.
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (defcustom face-x-resources
+ (mapcar
+ (lambda (arg)
+ ;; FIXME; can we purecopy some of the conses too?
+ (cons (car arg)
+ (cons (purecopy (car (cdr arg))) (purecopy (cdr (cdr arg))))))
+ '((:family (".attributeFamily" . "Face.AttributeFamily"))
+ (:foundry (".attributeFoundry" . "Face.AttributeFoundry"))
+ (:width (".attributeWidth" . "Face.AttributeWidth"))
+ (:height (".attributeHeight" . "Face.AttributeHeight"))
+ (:weight (".attributeWeight" . "Face.AttributeWeight"))
+ (:slant (".attributeSlant" . "Face.AttributeSlant"))
+ (:foreground (".attributeForeground" . "Face.AttributeForeground"))
+ (:distant-foreground
+ (".attributeDistantForeground" . "Face.AttributeDistantForeground"))
+ (:background (".attributeBackground" . "Face.AttributeBackground"))
+ (:overline (".attributeOverline" . "Face.AttributeOverline"))
+ (:strike-through (".attributeStrikeThrough" . "Face.AttributeStrikeThrough"))
+ (:box (".attributeBox" . "Face.AttributeBox"))
+ (:underline (".attributeUnderline" . "Face.AttributeUnderline"))
+ (:inverse-video (".attributeInverse" . "Face.AttributeInverse"))
+ (:stipple
+ (".attributeStipple" . "Face.AttributeStipple")
+ (".attributeBackgroundPixmap" . "Face.AttributeBackgroundPixmap"))
+ (:bold (".attributeBold" . "Face.AttributeBold"))
+ (:italic (".attributeItalic" . "Face.AttributeItalic"))
+ (:font (".attributeFont" . "Face.AttributeFont"))
+ (:inherit (".attributeInherit" . "Face.AttributeInherit"))))
+ "List of X resources and classes for face attributes.
+ Each element has the form (ATTRIBUTE ENTRY1 ENTRY2...) where ATTRIBUTE is
+ the name of a face attribute, and each ENTRY is a cons of the form
+ \(RESOURCE . CLASS) with RESOURCE being the resource and CLASS being the
+ X resource class for the attribute."
+ :type '(repeat (cons symbol (repeat (cons string string))))
+ :group 'faces)
+
+
+ (declare-function internal-face-x-get-resource "xfaces.c"
+ (resource class &optional frame))
+
+ (declare-function internal-set-lisp-face-attribute-from-resource "xfaces.c"
+ (face attr value &optional frame))
+
+ (defun set-face-attribute-from-resource (face attribute resource class frame)
+ "Set FACE's ATTRIBUTE from X resource RESOURCE, class CLASS on FRAME.
+ Value is the attribute value specified by the resource, or nil
+ if not present. This function displays a message if the resource
+ specifies an invalid attribute."
+ (let* ((face-name (face-name face))
+ (value (internal-face-x-get-resource (concat face-name resource)
+ class frame)))
+ (when value
+ (condition-case ()
+ (internal-set-lisp-face-attribute-from-resource
+ face attribute (downcase value) frame)
+ (error
+ (message "Face %s, frame %s: invalid attribute %s %s from X resource"
+ face-name frame attribute value))))
+ value))
+
+
+ (defun set-face-attributes-from-resources (face frame)
+ "Set attributes of FACE from X resources for FRAME."
+ (when (memq (framep frame) '(x w32))
+ (dolist (definition face-x-resources)
+ (let ((attribute (car definition)))
+ (dolist (entry (cdr definition))
+ (set-face-attribute-from-resource face attribute (car entry)
+ (cdr entry) frame))))))
+
+
+ (defun make-face-x-resource-internal (face &optional frame)
+ "Fill frame-local FACE on FRAME from X resources.
+ FRAME nil or not specified means do it for all frames.
+
+ If `inhibit-x-resources' is non-nil, this function does nothing."
+ (unless inhibit-x-resources
+ (dolist (frame (if (null frame) (frame-list) (list frame)))
+ ;; `x-create-frame' already took care of correctly handling
+ ;; the reverse video case-- do _not_ touch the default face
+ (unless (and (eq face 'default)
+ (frame-parameter frame 'reverse))
+ (set-face-attributes-from-resources face frame)))))
+
+
+ \f
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;; Retrieving face attributes.
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (defun face-name (face)
+ "Return the name of face FACE."
+ (symbol-name (check-face face)))
+
+
+ (defun face-all-attributes (face &optional frame)
+ "Return an alist stating the attributes of FACE.
+ Each element of the result has the form (ATTR-NAME . ATTR-VALUE).
+ If FRAME is omitted or nil the value describes the default attributes,
+ but if you specify FRAME, the value describes the attributes
+ of FACE on FRAME."
+ (mapcar (lambda (pair)
+ (let ((attr (car pair)))
+ (cons attr (face-attribute face attr (or frame t)))))
+ face-attribute-name-alist))
+
+ (defun face-attribute (face attribute &optional frame inherit)
+ "Return the value of FACE's ATTRIBUTE on FRAME.
+ If the optional argument FRAME is given, report on face FACE in that frame.
+ If FRAME is t, report on the defaults for face FACE (for new frames).
+ If FRAME is omitted or nil, use the selected frame.
+
+ If INHERIT is nil, only attributes directly defined by FACE are considered,
+ so the return value may be `unspecified', or a relative value.
+ If INHERIT is non-nil, FACE's definition of ATTRIBUTE is merged with the
+ faces specified by its `:inherit' attribute; however the return value
+ may still be `unspecified' or relative.
+ If INHERIT is a face or a list of faces, then the result is further merged
+ with that face (or faces), until it becomes specified and absolute.
+
+ To ensure that the return value is always specified and absolute, use a
+ value of `default' for INHERIT; this will resolve any unspecified or
+ relative values by merging with the `default' face (which is always
+ completely specified)."
+ (let ((value (internal-get-lisp-face-attribute face attribute frame)))
+ (when (and inherit (face-attribute-relative-p attribute value))
+ ;; VALUE is relative, so merge with inherited faces
+ (let ((inh-from (face-attribute face :inherit frame)))
+ (unless (or (null inh-from) (eq inh-from 'unspecified))
+ (condition-case nil
+ (setq value
+ (face-attribute-merged-with attribute value inh-from frame))
+ ;; The `inherit' attribute may point to non existent faces.
+ (error nil)))))
+ (when (and inherit
+ (not (eq inherit t))
+ (face-attribute-relative-p attribute value))
+ ;; We should merge with INHERIT as well
+ (setq value (face-attribute-merged-with attribute value inherit frame)))
+ value))
+
+ (defun face-attribute-merged-with (attribute value faces &optional frame)
+ "Merges ATTRIBUTE, initially VALUE, with faces from FACES until absolute.
+ FACES may be either a single face or a list of faces.
+ \[This is an internal function.]"
+ (cond ((not (face-attribute-relative-p attribute value))
+ value)
+ ((null faces)
+ value)
+ ((consp faces)
+ (face-attribute-merged-with
+ attribute
+ (face-attribute-merged-with attribute value (car faces) frame)
+ (cdr faces)
+ frame))
+ (t
+ (merge-face-attribute attribute
+ value
+ (face-attribute faces attribute frame t)))))
+
+
+ (defmacro face-attribute-specified-or (value &rest body)
+ "Return VALUE, unless it's `unspecified', in which case evaluate BODY and return the result."
+ (let ((temp (make-symbol "value")))
+ `(let ((,temp ,value))
+ (if (not (eq ,temp 'unspecified))
+ ,temp
+ ,@body))))
+
+ (defun face-foreground (face &optional frame inherit)
+ "Return the foreground color name of FACE, or nil if unspecified.
+ If the optional argument FRAME is given, report on face FACE in that frame.
+ If FRAME is t, report on the defaults for face FACE (for new frames).
+ If FRAME is omitted or nil, use the selected frame.
+
+ If INHERIT is nil, only a foreground color directly defined by FACE is
+ considered, so the return value may be nil.
+ If INHERIT is t, and FACE doesn't define a foreground color, then any
+ foreground color that FACE inherits through its `:inherit' attribute
+ is considered as well; however the return value may still be nil.
+ If INHERIT is a face or a list of faces, then it is used to try to
+ resolve an unspecified foreground color.
+
+ To ensure that a valid color is always returned, use a value of
+ `default' for INHERIT; this will resolve any unspecified values by
+ merging with the `default' face (which is always completely specified)."
+ (face-attribute-specified-or (face-attribute face :foreground frame inherit)
+ nil))
+
+ (defun face-background (face &optional frame inherit)
+ "Return the background color name of FACE, or nil if unspecified.
+ If the optional argument FRAME is given, report on face FACE in that frame.
+ If FRAME is t, report on the defaults for face FACE (for new frames).
+ If FRAME is omitted or nil, use the selected frame.
+
+ If INHERIT is nil, only a background color directly defined by FACE is
+ considered, so the return value may be nil.
+ If INHERIT is t, and FACE doesn't define a background color, then any
+ background color that FACE inherits through its `:inherit' attribute
+ is considered as well; however the return value may still be nil.
+ If INHERIT is a face or a list of faces, then it is used to try to
+ resolve an unspecified background color.
+
+ To ensure that a valid color is always returned, use a value of
+ `default' for INHERIT; this will resolve any unspecified values by
+ merging with the `default' face (which is always completely specified)."
+ (face-attribute-specified-or (face-attribute face :background frame inherit)
+ nil))
+
+ (defun face-stipple (face &optional frame inherit)
+ "Return the stipple pixmap name of FACE, or nil if unspecified.
+ If the optional argument FRAME is given, report on face FACE in that frame.
+ If FRAME is t, report on the defaults for face FACE (for new frames).
+ If FRAME is omitted or nil, use the selected frame.
+
+ If INHERIT is nil, only a stipple directly defined by FACE is
+ considered, so the return value may be nil.
+ If INHERIT is t, and FACE doesn't define a stipple, then any stipple
+ that FACE inherits through its `:inherit' attribute is considered as
+ well; however the return value may still be nil.
+ If INHERIT is a face or a list of faces, then it is used to try to
+ resolve an unspecified stipple.
+
+ To ensure that a valid stipple or nil is always returned, use a value of
+ `default' for INHERIT; this will resolve any unspecified values by merging
+ with the `default' face (which is always completely specified)."
+ (face-attribute-specified-or (face-attribute face :stipple frame inherit)
+ nil))
+
+
+ (defalias 'face-background-pixmap 'face-stipple)
+
+
+ (defun face-underline-p (face &optional frame inherit)
+ "Return non-nil if FACE specifies a non-nil underlining.
+ If the optional argument FRAME is given, report on face FACE in that frame.
+ If FRAME is t, report on the defaults for face FACE (for new frames).
+ If FRAME is omitted or nil, use the selected frame.
+ Optional argument INHERIT is passed to `face-attribute'."
+ (face-attribute-specified-or
+ (face-attribute face :underline frame inherit) nil))
+
+
+ (defun face-inverse-video-p (face &optional frame inherit)
+ "Return non-nil if FACE specifies a non-nil inverse-video.
+ If the optional argument FRAME is given, report on face FACE in that frame.
+ If FRAME is t, report on the defaults for face FACE (for new frames).
+ If FRAME is omitted or nil, use the selected frame.
+ Optional argument INHERIT is passed to `face-attribute'."
+ (eq (face-attribute face :inverse-video frame inherit) t))
+
+
+ (defun face-bold-p (face &optional frame inherit)
+ "Return non-nil if the font of FACE is bold on FRAME.
+ If the optional argument FRAME is given, report on face FACE in that frame.
+ If FRAME is t, report on the defaults for face FACE (for new frames).
+ If FRAME is omitted or nil, use the selected frame.
+ Optional argument INHERIT is passed to `face-attribute'.
+ Use `face-attribute' for finer control."
+ (let ((bold (face-attribute face :weight frame inherit)))
+ (memq bold '(semi-bold bold extra-bold ultra-bold))))
+
+
+ (defun face-italic-p (face &optional frame inherit)
+ "Return non-nil if the font of FACE is italic on FRAME.
+ If the optional argument FRAME is given, report on face FACE in that frame.
+ If FRAME is t, report on the defaults for face FACE (for new frames).
+ If FRAME is omitted or nil, use the selected frame.
+ Optional argument INHERIT is passed to `face-attribute'.
+ Use `face-attribute' for finer control."
+ (let ((italic (face-attribute face :slant frame inherit)))
+ (memq italic '(italic oblique))))
+
+
+ \f
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;; Face documentation.
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (defun face-documentation (face)
+ "Get the documentation string for FACE.
+ If FACE is a face-alias, get the documentation for the target face."
+ (let ((alias (get face 'face-alias)))
+ (if alias
+ (let ((doc (get alias 'face-documentation)))
+ (format "%s is an alias for the face `%s'.%s" face alias
+ (if doc (format "\n%s" doc)
+ "")))
+ (get face 'face-documentation))))
+
+
+ (defun set-face-documentation (face string)
+ "Set the documentation string for FACE to STRING."
+ ;; Perhaps the text should go in DOC.
+ (put face 'face-documentation (purecopy string)))
+
+
+ (defalias 'face-doc-string 'face-documentation)
+ (defalias 'set-face-doc-string 'set-face-documentation)
+
+
+ \f
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; Setting face attributes.
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+ (defun set-face-attribute (face frame &rest args)
+ "Set attributes of FACE on FRAME from ARGS.
+ This function overrides the face attributes specified by FACE's
+ face spec. It is mostly intended for internal use only.
+
+ If FRAME is nil, set the attributes for all existing frames, as
+ well as the default for new frames. If FRAME is t, change the
+ default for new frames only.
+
+ ARGS must come in pairs ATTRIBUTE VALUE. ATTRIBUTE must be a
+ valid face attribute name. All attributes can be set to
+ `unspecified'; this fact is not further mentioned below.
+
+ The following attributes are recognized:
+
+ `:family'
+
+ VALUE must be a string specifying the font family
+ \(e.g. \"Monospace\") or a fontset.
+
+ `:foundry'
+
+ VALUE must be a string specifying the font foundry,
+ e.g. ``adobe''. If a font foundry is specified, wild-cards `*'
+ and `?' are allowed.
+
+ `:width'
+
+ VALUE specifies the relative proportionate width of the font to use.
+ It must be one of the symbols `ultra-condensed', `extra-condensed',
+ `condensed', `semi-condensed', `normal', `semi-expanded', `expanded',
+ `extra-expanded', or `ultra-expanded'.
+
+ `:height'
+
+ VALUE specifies the relative or absolute height of the font. An
+ absolute height is an integer, and specifies font height in units
+ of 1/10 pt. A relative height is either a floating point number,
+ which specifies a scaling factor for the underlying face height;
+ or a function that takes a single argument (the underlying face
+ height) and returns the new height. Note that for the `default'
+ face, you must specify an absolute height (since there is nothing
+ for it to be relative to).
+
+ `:weight'
+
+ VALUE specifies the weight of the font to use. It must be one of the
+ symbols `ultra-bold', `extra-bold', `bold', `semi-bold', `normal',
+ `semi-light', `light', `extra-light', `ultra-light'.
+
+ `:slant'
+
+ VALUE specifies the slant of the font to use. It must be one of the
+ symbols `italic', `oblique', `normal', `reverse-italic', or
+ `reverse-oblique'.
+
+ `:foreground', `:background'
+
+ VALUE must be a color name, a string.
+
+ `:underline'
+
+ VALUE specifies whether characters in FACE should be underlined.
+ If VALUE is t, underline with foreground color of the face.
+ If VALUE is a string, underline with that color.
+ If VALUE is nil, explicitly don't underline.
+
+ Otherwise, VALUE must be a property list of the form:
+
+ `(:color COLOR :style STYLE)'.
+
+ COLOR can be a either a color name string or `foreground-color'.
+ STYLE can be either `line' or `wave'.
+ If a keyword/value pair is missing from the property list, a
+ default value will be used for the value.
+ The default value of COLOR is the foreground color of the face.
+ The default value of STYLE is `line'.
+
+ `:overline'
+
+ VALUE specifies whether characters in FACE should be overlined. If
+ VALUE is t, overline with foreground color of the face. If VALUE is a
+ string, overline with that color. If VALUE is nil, explicitly don't
+ overline.
+
+ `:strike-through'
+
+ VALUE specifies whether characters in FACE should be drawn with a line
+ striking through them. If VALUE is t, use the foreground color of the
+ face. If VALUE is a string, strike-through with that color. If VALUE
+ is nil, explicitly don't strike through.
+
+ `:box'
+
+ VALUE specifies whether characters in FACE should have a box drawn
+ around them. If VALUE is nil, explicitly don't draw boxes. If
+ VALUE is t, draw a box with lines of width 1 in the foreground color
+ of the face. If VALUE is a string, the string must be a color name,
+ and the box is drawn in that color with a line width of 1. Otherwise,
+ VALUE must be a property list of the form `(:line-width WIDTH
+ :color COLOR :style STYLE)'. If a keyword/value pair is missing from
+ the property list, a default value will be used for the value, as
+ specified below. WIDTH specifies the width of the lines to draw; it
+ defaults to 1. If WIDTH is negative, the absolute value is the width
+ of the lines, and draw top/bottom lines inside the characters area,
+ not around it. COLOR is the name of the color to draw in, default is
+ the foreground color of the face for simple boxes, and the background
+ color of the face for 3D boxes. STYLE specifies whether a 3D box
+ should be draw. If STYLE is `released-button', draw a box looking
+ like a released 3D button. If STYLE is `pressed-button' draw a box
+ that appears like a pressed button. If STYLE is nil, the default if
+ the property list doesn't contain a style specification, draw a 2D
+ box.
+
+ `:inverse-video'
+
+ VALUE specifies whether characters in FACE should be displayed in
+ inverse video. VALUE must be one of t or nil.
+
+ `:stipple'
+
+ If VALUE is a string, it must be the name of a file of pixmap data.
+ The directories listed in the `x-bitmap-file-path' variable are
+ searched. Alternatively, VALUE may be a list of the form (WIDTH
+ HEIGHT DATA) where WIDTH and HEIGHT are the size in pixels, and DATA
+ is a string containing the raw bits of the bitmap. VALUE nil means
+ explicitly don't use a stipple pattern.
+
+ For convenience, attributes `:family', `:foundry', `:width',
+ `:height', `:weight', and `:slant' may also be set in one step
+ from an X font name:
+
+ `:font'
+
+ Set font-related face attributes from VALUE. VALUE must be a
+ valid font name or font object. Setting this attribute will also
+ set the `:family', `:foundry', `:width', `:height', `:weight',
+ and `:slant' attributes.
+
+ `:inherit'
+
+ VALUE is the name of a face from which to inherit attributes, or
+ a list of face names. Attributes from inherited faces are merged
+ into the face like an underlying face would be, with higher
+ priority than underlying faces.
+
+ For backward compatibility, the keywords `:bold' and `:italic'
+ can be used to specify weight and slant respectively. This usage
+ is considered obsolete. For these two keywords, the VALUE must
+ be either t or nil. A value of t for `:bold' is equivalent to
+ setting `:weight' to `bold', and a value of t for `:italic' is
+ equivalent to setting `:slant' to `italic'. But if `:weight' is
+ specified in the face spec, `:bold' is ignored, and if `:slant'
+ is specified, `:italic' is ignored."
+ (setq args (purecopy args))
+ (let ((where (if (null frame) 0 frame))
+ (spec args)
+ family foundry)
+ ;; If we set the new-frame defaults, this face is modified outside Custom.
+ (if (memq where '(0 t))
+ (put (or (get face 'face-alias) face) 'face-modified t))
+ ;; If family and/or foundry are specified, set it first. Certain
+ ;; face attributes, e.g. :weight semi-condensed, are not supported
+ ;; in every font. See bug#1127.
+ (while spec
+ (cond ((eq (car spec) :family)
+ (setq family (cadr spec)))
+ ((eq (car spec) :foundry)
+ (setq foundry (cadr spec))))
+ (setq spec (cddr spec)))
+ (when (or family foundry)
+ (when (and (stringp family)
+ (string-match "\\([^-]*\\)-\\([^-]*\\)" family))
+ (unless foundry
+ (setq foundry (match-string 1 family)))
+ (setq family (match-string 2 family)))
+ (when (or (stringp family) (eq family 'unspecified))
+ (internal-set-lisp-face-attribute face :family (purecopy family)
+ where))
+ (when (or (stringp foundry) (eq foundry 'unspecified))
+ (internal-set-lisp-face-attribute face :foundry (purecopy foundry)
+ where)))
+ (while args
+ (unless (memq (car args) '(:family :foundry))
+ (internal-set-lisp-face-attribute face (car args)
+ (purecopy (cadr args))
+ where))
+ (setq args (cddr args)))))
+
+ (defun make-face-bold (face &optional frame _noerror)
+ "Make the font of FACE be bold, if possible.
+ FRAME nil or not specified means change face on all frames.
+ Argument NOERROR is ignored and retained for compatibility.
+ Use `set-face-attribute' for finer control of the font weight."
+ (interactive (list (read-face-name "Make which face bold"
+ (face-at-point t))))
+ (set-face-attribute face frame :weight 'bold))
+
+
+ (defun make-face-unbold (face &optional frame _noerror)
+ "Make the font of FACE be non-bold, if possible.
+ FRAME nil or not specified means change face on all frames.
+ Argument NOERROR is ignored and retained for compatibility."
+ (interactive (list (read-face-name "Make which face non-bold"
+ (face-at-point t))))
+ (set-face-attribute face frame :weight 'normal))
+
+
+ (defun make-face-italic (face &optional frame _noerror)
+ "Make the font of FACE be italic, if possible.
+ FRAME nil or not specified means change face on all frames.
+ Argument NOERROR is ignored and retained for compatibility.
+ Use `set-face-attribute' for finer control of the font slant."
+ (interactive (list (read-face-name "Make which face italic"
+ (face-at-point t))))
+ (set-face-attribute face frame :slant 'italic))
+
+
+ (defun make-face-unitalic (face &optional frame _noerror)
+ "Make the font of FACE be non-italic, if possible.
+ FRAME nil or not specified means change face on all frames.
+ Argument NOERROR is ignored and retained for compatibility."
+ (interactive (list (read-face-name "Make which face non-italic"
+ (face-at-point t))))
+ (set-face-attribute face frame :slant 'normal))
+
+
+ (defun make-face-bold-italic (face &optional frame _noerror)
+ "Make the font of FACE be bold and italic, if possible.
+ FRAME nil or not specified means change face on all frames.
+ Argument NOERROR is ignored and retained for compatibility.
+ Use `set-face-attribute' for finer control of font weight and slant."
+ (interactive (list (read-face-name "Make which face bold-italic"
+ (face-at-point t))))
+ (set-face-attribute face frame :weight 'bold :slant 'italic))
+
+
+ (defun set-face-font (face font &optional frame)
+ "Change font-related attributes of FACE to those of FONT (a string).
+ FRAME nil or not specified means change face on all frames.
+ This sets the attributes `:family', `:foundry', `:width',
+ `:height', `:weight', and `:slant'. When called interactively,
+ prompt for the face and font."
+ (interactive (read-face-and-attribute :font))
+ (set-face-attribute face frame :font font))
+
+
+ ;; Implementation note: Emulating gray background colors with a
+ ;; stipple pattern is now part of the face realization process, and is
+ ;; done in C depending on the frame on which the face is realized.
+
+ (defun set-face-background (face color &optional frame)
+ "Change the background color of face FACE to COLOR (a string).
+ FRAME nil or not specified means change face on all frames.
+ COLOR can be a system-defined color name (see `list-colors-display')
+ or a hex spec of the form #RRGGBB.
+ When called interactively, prompts for the face and color."
+ (interactive (read-face-and-attribute :background))
+ (set-face-attribute face frame :background (or color 'unspecified)))
+
+
+ (defun set-face-foreground (face color &optional frame)
+ "Change the foreground color of face FACE to COLOR (a string).
+ FRAME nil or not specified means change face on all frames.
+ COLOR can be a system-defined color name (see `list-colors-display')
+ or a hex spec of the form #RRGGBB.
+ When called interactively, prompts for the face and color."
+ (interactive (read-face-and-attribute :foreground))
+ (set-face-attribute face frame :foreground (or color 'unspecified)))
+
+
+ (defun set-face-stipple (face stipple &optional frame)
+ "Change the stipple pixmap of face FACE to STIPPLE.
+ FRAME nil or not specified means change face on all frames.
+ STIPPLE should be a string, the name of a file of pixmap data.
+ The directories listed in the `x-bitmap-file-path' variable are searched.
+
+ Alternatively, STIPPLE may be a list of the form (WIDTH HEIGHT DATA)
+ where WIDTH and HEIGHT are the size in pixels,
+ and DATA is a string, containing the raw bits of the bitmap."
+ (interactive (read-face-and-attribute :stipple))
+ (set-face-attribute face frame :stipple (or stipple 'unspecified)))
+
+
+ (defun set-face-underline (face underline &optional frame)
+ "Specify whether face FACE is underlined.
+ UNDERLINE nil means FACE explicitly doesn't underline.
+ UNDERLINE t means FACE underlines with its foreground color.
+ If UNDERLINE is a string, underline with that color.
+
+ UNDERLINE may also be a list of the form (:color COLOR :style STYLE),
+ where COLOR is a string or `foreground-color', and STYLE is either
+ `line' or `wave'. :color may be omitted, which means to use the
+ foreground color. :style may be omitted, which means to use a line.
+
+ FRAME nil or not specified means change face on all frames.
+ Use `set-face-attribute' to ``unspecify'' underlining."
+ (interactive (read-face-and-attribute :underline))
+ (set-face-attribute face frame :underline underline))
+
+ (define-obsolete-function-alias 'set-face-underline-p
+ 'set-face-underline "24.3")
+
+
+ (defun set-face-inverse-video (face inverse-video-p &optional frame)
+ "Specify whether face FACE is in inverse video.
+ INVERSE-VIDEO-P non-nil means FACE displays explicitly in inverse video.
+ INVERSE-VIDEO-P nil means FACE explicitly is not in inverse video.
+ FRAME nil or not specified means change face on all frames.
+ Use `set-face-attribute' to ``unspecify'' the inverse video attribute."
+ (interactive
+ (let ((list (read-face-and-attribute :inverse-video)))
+ (list (car list) (if (cadr list) t))))
+ (set-face-attribute face frame :inverse-video inverse-video-p))
+
+ (define-obsolete-function-alias 'set-face-inverse-video-p
+ 'set-face-inverse-video "24.4")
+
+ (defun set-face-bold (face bold-p &optional frame)
+ "Specify whether face FACE is bold.
+ BOLD-P non-nil means FACE should explicitly display bold.
+ BOLD-P nil means FACE should explicitly display non-bold.
+ FRAME nil or not specified means change face on all frames.
+ Use `set-face-attribute' or `modify-face' for finer control."
+ (if (null bold-p)
+ (make-face-unbold face frame)
+ (make-face-bold face frame)))
+
+ (define-obsolete-function-alias 'set-face-bold-p 'set-face-bold "24.4")
+
+
+ (defun set-face-italic (face italic-p &optional frame)
+ "Specify whether face FACE is italic.
+ ITALIC-P non-nil means FACE should explicitly display italic.
+ ITALIC-P nil means FACE should explicitly display non-italic.
+ FRAME nil or not specified means change face on all frames.
+ Use `set-face-attribute' or `modify-face' for finer control."
+ (if (null italic-p)
+ (make-face-unitalic face frame)
+ (make-face-italic face frame)))
+
+ (define-obsolete-function-alias 'set-face-italic-p 'set-face-italic "24.4")
+
+
+ (defalias 'set-face-background-pixmap 'set-face-stipple)
+
+
+ (defun invert-face (face &optional frame)
+ "Swap the foreground and background colors of FACE.
+ If FRAME is omitted or nil, it means change face on all frames.
+ If FACE specifies neither foreground nor background color,
+ set its foreground and background to the background and foreground
+ of the default face. Value is FACE."
+ (interactive (list (read-face-name "Invert face" (face-at-point t))))
+ (let ((fg (face-attribute face :foreground frame))
+ (bg (face-attribute face :background frame)))
+ (if (not (and (eq fg 'unspecified) (eq bg 'unspecified)))
+ (set-face-attribute face frame :foreground bg :background fg)
+ (set-face-attribute face frame
+ :foreground
+ (face-attribute 'default :background frame)
+ :background
+ (face-attribute 'default :foreground frame))))
+ face)
+
+ \f
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;; Interactively modifying faces.
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (defvar crm-separator) ; from crm.el
+
+ (defun read-face-name (prompt &optional default multiple)
+ "Read one or more face names, prompting with PROMPT.
+ PROMPT should not end in a space or a colon.
+
+ Return DEFAULT if the user enters the empty string.
+ If DEFAULT is non-nil, it should be a single face or a list of face names
+ \(symbols or strings). In the latter case, return the `car' of DEFAULT
+ \(if MULTIPLE is nil, see below), or DEFAULT (if MULTIPLE is non-nil).
+
+ If MULTIPLE is non-nil, this function uses `completing-read-multiple'
+ to read multiple faces with \"[ \\t]*,[ \\t]*\" as the separator regexp
+ and it returns a list of face names. Otherwise, it reads and returns
+ a single face name."
+ (if (and default (not (stringp default)))
+ (setq default
+ (cond ((symbolp default)
+ (symbol-name default))
+ (multiple
+ (mapconcat (lambda (f) (if (symbolp f) (symbol-name f) f))
+ default ", "))
+ ;; If we only want one, and the default is more than one,
+ ;; discard the unwanted ones.
+ (t (symbol-name (car default))))))
+ (when (and default (not multiple))
+ (require 'crm)
+ ;; For compatibility with `completing-read-multiple' use `crm-separator'
+ ;; to define DEFAULT if MULTIPLE is nil.
+ (setq default (car (split-string default crm-separator t))))
+
+ (let ((prompt (if default
+ (format "%s (default `%s'): " prompt default)
+ (format "%s: " prompt)))
+ aliasfaces nonaliasfaces faces)
+ ;; Build up the completion tables.
+ (mapatoms (lambda (s)
+ (if (facep s)
+ (if (get s 'face-alias)
+ (push (symbol-name s) aliasfaces)
+ (push (symbol-name s) nonaliasfaces)))))
+ (if multiple
+ (progn
+ (dolist (face (completing-read-multiple
+ prompt
+ (completion-table-in-turn nonaliasfaces aliasfaces)
+ nil t nil 'face-name-history default))
+ ;; Ignore elements that are not faces
+ ;; (for example, because DEFAULT was "all faces")
+ (if (facep face) (push (intern face) faces)))
+ (nreverse faces))
+ (let ((face (completing-read
+ prompt
+ (completion-table-in-turn nonaliasfaces aliasfaces)
+ nil t nil 'face-name-history default)))
+ (if (facep face) (intern face))))))
+
+ ;; Not defined without X, but behind window-system test.
+ (defvar x-bitmap-file-path)
+
+ (defun face-valid-attribute-values (attribute &optional frame)
+ "Return valid values for face attribute ATTRIBUTE.
+ The optional argument FRAME is used to determine available fonts
+ and colors. If it is nil or not specified, the selected frame is used.
+ Value is an alist of (NAME . VALUE) if ATTRIBUTE expects a value out
+ of a set of discrete values. Value is `integerp' if ATTRIBUTE expects
+ an integer value."
+ (let ((valid
+ (pcase attribute
+ (`:family
+ (if (window-system frame)
+ (mapcar (lambda (x) (cons x x))
+ (font-family-list))
+ ;; Only one font on TTYs.
+ (list (cons "default" "default"))))
+ (`:foundry
+ (list nil))
+ (`:width
+ (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1)))
+ font-width-table))
+ (`:weight
+ (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1)))
+ font-weight-table))
+ (`:slant
+ (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1)))
+ font-slant-table))
+ (`:inverse-video
+ (mapcar #'(lambda (x) (cons (symbol-name x) x))
+ (internal-lisp-face-attribute-values attribute)))
+ ((or `:underline `:overline `:strike-through `:box)
+ (if (window-system frame)
+ (nconc (mapcar #'(lambda (x) (cons (symbol-name x) x))
+ (internal-lisp-face-attribute-values attribute))
+ (mapcar #'(lambda (c) (cons c c))
+ (defined-colors frame)))
+ (mapcar #'(lambda (x) (cons (symbol-name x) x))
+ (internal-lisp-face-attribute-values attribute))))
+ ((or `:foreground `:background)
+ (mapcar #'(lambda (c) (cons c c))
+ (defined-colors frame)))
+ (`:height
+ 'integerp)
+ (`:stipple
+ (and (memq (window-system frame) '(x ns)) ; No stipple on w32
+ (mapcar #'list
+ (apply #'nconc
+ (mapcar (lambda (dir)
+ (and (file-readable-p dir)
+ (file-directory-p dir)
+ (directory-files dir)))
+ x-bitmap-file-path)))))
+ (`:inherit
+ (cons '("none" . nil)
+ (mapcar #'(lambda (c) (cons (symbol-name c) c))
+ (face-list))))
+ (_
+ (error "Internal error")))))
+ (if (and (listp valid) (not (memq attribute '(:inherit))))
+ (nconc (list (cons "unspecified" 'unspecified)) valid)
+ valid)))
+
+
+ (defconst face-attribute-name-alist
+ '((:family . "font family")
+ (:foundry . "font foundry")
+ (:width . "character set width")
+ (:height . "height in 1/10 pt")
+ (:weight . "weight")
+ (:slant . "slant")
+ (:underline . "underline")
+ (:overline . "overline")
+ (:strike-through . "strike-through")
+ (:box . "box")
+ (:inverse-video . "inverse-video display")
+ (:foreground . "foreground color")
+ (:background . "background color")
+ (:stipple . "background stipple")
+ (:inherit . "inheritance"))
+ "An alist of descriptive names for face attributes.
+ Each element has the form (ATTRIBUTE-NAME . DESCRIPTION) where
+ ATTRIBUTE-NAME is a face attribute name (a keyword symbol), and
+ DESCRIPTION is a descriptive name for ATTRIBUTE-NAME.")
+
+
+ (defun face-descriptive-attribute-name (attribute)
+ "Return a descriptive name for ATTRIBUTE."
+ (cdr (assq attribute face-attribute-name-alist)))
+
+
+ (defun face-read-string (face default name &optional completion-alist)
+ "Interactively read a face attribute string value.
+ FACE is the face whose attribute is read. If non-nil, DEFAULT is the
+ default string to return if no new value is entered. NAME is a
+ descriptive name of the attribute for prompting. COMPLETION-ALIST is an
+ alist of valid values, if non-nil.
+
+ Entering nothing accepts the default string DEFAULT.
+ Value is the new attribute value."
+ ;; Capitalize NAME (we don't use `capitalize' because that capitalizes
+ ;; each word in a string separately).
+ (setq name (concat (upcase (substring name 0 1)) (substring name 1)))
+ (let* ((completion-ignore-case t)
+ (value (completing-read
+ (if default
+ (format "%s for face `%s' (default %s): "
+ name face default)
+ (format "%s for face `%s': " name face))
+ completion-alist nil nil nil nil default)))
+ (if (equal value "") default value)))
+
+
+ (defun face-read-integer (face default name)
+ "Interactively read an integer face attribute value.
+ FACE is the face whose attribute is read. DEFAULT is the default
+ value to return if no new value is entered. NAME is a descriptive
+ name of the attribute for prompting. Value is the new attribute value."
+ (let ((new-value
+ (face-read-string face
+ (format "%s" default)
+ name
+ (list (cons "unspecified" 'unspecified)))))
+ (cond ((equal new-value "unspecified")
+ 'unspecified)
+ ((member new-value '("unspecified-fg" "unspecified-bg"))
+ new-value)
+ (t
+ (string-to-number new-value)))))
+
+
+ ;; FIXME this does allow you to enter the list forms of :box,
+ ;; :stipple, or :underline, because face-valid-attribute-values does
+ ;; not return those forms.
+ (defun read-face-attribute (face attribute &optional frame)
+ "Interactively read a new value for FACE's ATTRIBUTE.
+ Optional argument FRAME nil or unspecified means read an attribute value
+ of a global face. Value is the new attribute value."
+ (let* ((old-value (face-attribute face attribute frame))
+ (attribute-name (face-descriptive-attribute-name attribute))
+ (valid (face-valid-attribute-values attribute frame))
+ new-value)
+ ;; Represent complex attribute values as strings by printing them
+ ;; out. Stipple can be a vector; (WIDTH HEIGHT DATA). Box can be
+ ;; a list `(:width WIDTH :color COLOR)' or `(:width WIDTH :shadow
+ ;; SHADOW)'. Underline can be `(:color COLOR :style STYLE)'.
+ (and (memq attribute '(:box :stipple :underline))
+ (or (consp old-value)
+ (vectorp old-value))
+ (setq old-value (prin1-to-string old-value)))
+ (cond ((listp valid)
+ (let ((default
+ (or (car (rassoc old-value valid))
+ (format "%s" old-value))))
+ (setq new-value
+ (face-read-string face default attribute-name valid))
+ (if (equal new-value default)
+ ;; Nothing changed, so don't bother with all the stuff
+ ;; below. In particular, this avoids a non-tty color
+ ;; from being canonicalized for a tty when the user
+ ;; just uses the default.
+ (setq new-value old-value)
+ ;; Terminal frames can support colors that don't appear
+ ;; explicitly in VALID, using color approximation code
+ ;; in tty-colors.el.
+ (when (and (memq attribute '(:foreground :background))
+ (not (memq (window-system frame) '(x w32 ns)))
+ (not (member new-value
+ '("unspecified"
+ "unspecified-fg" "unspecified-bg"))))
+ (setq new-value (car (tty-color-desc new-value frame))))
+ (when (assoc new-value valid)
+ (setq new-value (cdr (assoc new-value valid)))))))
+ ((eq valid 'integerp)
+ (setq new-value (face-read-integer face old-value attribute-name)))
+ (t (error "Internal error")))
+ ;; Convert stipple and box value text we read back to a list or
+ ;; vector if it looks like one. This makes the assumption that a
+ ;; pixmap file name won't start with an open-paren.
+ (and (memq attribute '(:stipple :box :underline))
+ (stringp new-value)
+ (string-match-p "^[[(]" new-value)
+ (setq new-value (read new-value)))
+ new-value))
+
+ (declare-function fontset-list "fontset.c" ())
+ (declare-function x-list-fonts "xfaces.c"
+ (pattern &optional face frame maximum width))
+
+ (defun read-face-font (face &optional frame)
+ "Read the name of a font for FACE on FRAME.
+ If optional argument FRAME is nil or omitted, use the selected frame."
+ (let ((completion-ignore-case t))
+ (completing-read (format "Set font attributes of face `%s' from font: " face)
+ (append (fontset-list) (x-list-fonts "*" nil frame)))))
+
+
+ (defun read-all-face-attributes (face &optional frame)
+ "Interactively read all attributes for FACE.
+ If optional argument FRAME is nil or omitted, use the selected frame.
+ Value is a property list of attribute names and new values."
+ (let (result)
+ (dolist (attribute face-attribute-name-alist result)
+ (setq result (cons (car attribute)
+ (cons (read-face-attribute face (car attribute) frame)
+ result))))))
+
+ (defun modify-face (&optional face foreground background stipple
+ bold-p italic-p underline inverse-p frame)
+ "Modify attributes of faces interactively.
+ If optional argument FRAME is nil or omitted, modify the face used
+ for newly created frame, i.e. the global face.
+ For non-interactive use, `set-face-attribute' is preferred.
+ When called from Lisp, if FACE is nil, all arguments but FRAME are ignored
+ and the face and its settings are obtained by querying the user."
+ (interactive)
+ (if face
+ (set-face-attribute face frame
+ :foreground (or foreground 'unspecified)
+ :background (or background 'unspecified)
+ :stipple stipple
+ :weight (if bold-p 'bold 'normal)
+ :slant (if italic-p 'italic 'normal)
+ :underline underline
+ :inverse-video inverse-p)
+ (setq face (read-face-name "Modify face" (face-at-point t)))
+ (apply #'set-face-attribute face frame
+ (read-all-face-attributes face frame))))
+
+ (defun read-face-and-attribute (attribute &optional frame)
+ "Read face name and face attribute value.
+ ATTRIBUTE is the attribute whose new value is read.
+ FRAME nil or unspecified means read attribute value of global face.
+ Value is a list (FACE NEW-VALUE) where FACE is the face read
+ \(a symbol), and NEW-VALUE is value read."
+ (cond ((eq attribute :font)
+ (let* ((prompt "Set font-related attributes of face")
+ (face (read-face-name prompt (face-at-point t)))
+ (font (read-face-font face frame)))
+ (list face font)))
+ (t
+ (let* ((attribute-name (face-descriptive-attribute-name attribute))
+ (prompt (format "Set %s of face" attribute-name))
+ (face (read-face-name prompt (face-at-point t)))
+ (new-value (read-face-attribute face attribute frame)))
+ (list face new-value)))))
+
+
+ \f
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;; Listing faces.
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (defconst list-faces-sample-text
+ "abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ "Text string to display as the sample text for `list-faces-display'.")
+
+
+ ;; The name list-faces would be more consistent, but let's avoid a
+ ;; conflict with Lucid, which uses that name differently.
+
+ (defvar help-xref-stack)
+ (defun list-faces-display (&optional regexp)
+ "List all faces, using the same sample text in each.
+ The sample text is a string that comes from the variable
+ `list-faces-sample-text'.
+
+ If REGEXP is non-nil, list only those faces with names matching
+ this regular expression. When called interactively with a prefix
+ argument, prompt for a regular expression using `read-regexp'."
+ (interactive (list (and current-prefix-arg
+ (read-regexp "List faces matching regexp"))))
+ (let ((all-faces (zerop (length regexp)))
+ (frame (selected-frame))
+ (max-length 0)
+ faces line-format
+ disp-frame window face-name)
+ ;; We filter and take the max length in one pass
+ (setq faces
+ (delq nil
+ (mapcar (lambda (f)
+ (let ((s (symbol-name f)))
+ (when (or all-faces (string-match-p regexp s))
+ (setq max-length (max (length s) max-length))
+ f)))
+ (sort (face-list) #'string-lessp))))
+ (unless faces
+ (error "No faces matching \"%s\"" regexp))
+ (setq max-length (1+ max-length)
+ line-format (format "%%-%ds" max-length))
+ (with-help-window "*Faces*"
+ (with-current-buffer standard-output
+ (setq truncate-lines t)
+ (insert
+ (substitute-command-keys
+ (concat
+ "\\<help-mode-map>Use "
+ (if (display-mouse-p) "\\[help-follow-mouse] or ")
+ "\\[help-follow] on a face name to customize it\n"
+ "or on its sample text for a description of the face.\n\n")))
+ (setq help-xref-stack nil)
+ (dolist (face faces)
+ (setq face-name (symbol-name face))
+ (insert (format line-format face-name))
+ ;; Hyperlink to a customization buffer for the face. Using
+ ;; the help xref mechanism may not be the best way.
+ (save-excursion
+ (save-match-data
+ (search-backward face-name)
+ (setq help-xref-stack-item `(list-faces-display ,regexp))
+ (help-xref-button 0 'help-customize-face face)))
+ (let ((beg (point))
+ (line-beg (line-beginning-position)))
+ (insert list-faces-sample-text)
+ ;; Hyperlink to a help buffer for the face.
+ (save-excursion
+ (save-match-data
+ (search-backward list-faces-sample-text)
+ (help-xref-button 0 'help-face face)))
+ (insert "\n")
+ (put-text-property beg (1- (point)) 'face face)
+ ;; Make all face commands default to the proper face
+ ;; anywhere in the line.
+ (put-text-property line-beg (1- (point)) 'read-face-name face)
+ ;; If the sample text has multiple lines, line up all of them.
+ (goto-char beg)
+ (forward-line 1)
+ (while (not (eobp))
+ (insert-char ?\s max-length)
+ (forward-line 1))))
+ (goto-char (point-min))))
+ ;; If the *Faces* buffer appears in a different frame,
+ ;; copy all the face definitions from FRAME,
+ ;; so that the display will reflect the frame that was selected.
+ (setq window (get-buffer-window (get-buffer "*Faces*") t))
+ (setq disp-frame (if window (window-frame window)
+ (car (frame-list))))
+ (or (eq frame disp-frame)
+ (dolist (face (face-list))
+ (copy-face face face frame disp-frame)))))
+
+
+ (defun describe-face (face &optional frame)
+ "Display the properties of face FACE on FRAME.
+ Interactively, FACE defaults to the faces of the character after point
+ and FRAME defaults to the selected frame.
+
+ If the optional argument FRAME is given, report on face FACE in that frame.
+ If FRAME is t, report on the defaults for face FACE (for new frames).
+ If FRAME is omitted or nil, use the selected frame."
+ (interactive (list (read-face-name "Describe face"
+ (or (face-at-point t) 'default)
+ t)))
+ (let* ((attrs '((:family . "Family")
+ (:foundry . "Foundry")
+ (:width . "Width")
+ (:height . "Height")
+ (:weight . "Weight")
+ (:slant . "Slant")
+ (:foreground . "Foreground")
+ (:distant-foreground . "DistantForeground")
+ (:background . "Background")
+ (:underline . "Underline")
+ (:overline . "Overline")
+ (:strike-through . "Strike-through")
+ (:box . "Box")
+ (:inverse-video . "Inverse")
+ (:stipple . "Stipple")
+ (:font . "Font")
+ (:fontset . "Fontset")
+ (:inherit . "Inherit")))
+ (max-width (apply #'max (mapcar #'(lambda (x) (length (cdr x)))
+ attrs))))
+ (help-setup-xref (list #'describe-face face)
+ (called-interactively-p 'interactive))
+ (unless face
+ (setq face 'default))
+ (if (not (listp face))
+ (setq face (list face)))
+ (with-help-window (help-buffer)
+ (with-current-buffer standard-output
+ (dolist (f face)
+ (if (stringp f) (setq f (intern f)))
+ ;; We may get called for anonymous faces (i.e., faces
+ ;; expressed using prop-value plists). Those can't be
+ ;; usefully customized, so ignore them.
+ (when (symbolp f)
+ (insert "Face: " (symbol-name f))
+ (if (not (facep f))
+ (insert " undefined face.\n")
+ (let ((customize-label "customize this face")
+ file-name)
+ (insert (concat " (" (propertize "sample" 'font-lock-face f) ")"))
+ (princ (concat " (" customize-label ")\n"))
+ ;; FIXME not sure how much of this belongs here, and
+ ;; how much in `face-documentation'. The latter is
+ ;; not used much, but needs to return nil for
+ ;; undocumented faces.
+ (let ((alias (get f 'face-alias))
+ (face f)
+ obsolete)
+ (when alias
+ (setq face alias)
+ (insert
+ (format "\n %s is an alias for the face `%s'.\n%s"
+ f alias
+ (if (setq obsolete (get f 'obsolete-face))
+ (format " This face is obsolete%s; use `%s' instead.\n"
+ (if (stringp obsolete)
+ (format " since %s" obsolete)
+ "")
+ alias)
+ ""))))
+ (insert "\nDocumentation:\n"
+ (or (face-documentation face)
+ "Not documented as a face.")
+ "\n\n"))
+ (with-current-buffer standard-output
+ (save-excursion
+ (re-search-backward
+ (concat "\\(" customize-label "\\)") nil t)
+ (help-xref-button 1 'help-customize-face f)))
+ (setq file-name (find-lisp-object-file-name f 'defface))
+ (when file-name
+ (princ "Defined in `")
+ (princ (file-name-nondirectory file-name))
+ (princ "'")
+ ;; Make a hyperlink to the library.
+ (save-excursion
+ (re-search-backward "`\\([^`']+\\)'" nil t)
+ (help-xref-button 1 'help-face-def f file-name))
+ (princ ".")
+ (terpri)
+ (terpri))
+ (dolist (a attrs)
+ (let ((attr (face-attribute f (car a) frame)))
+ (insert (make-string (- max-width (length (cdr a))) ?\s)
+ (cdr a) ": " (format "%s" attr))
+ (if (and (eq (car a) :inherit)
+ (not (eq attr 'unspecified)))
+ ;; Make a hyperlink to the parent face.
+ (save-excursion
+ (re-search-backward ": \\([^:]+\\)" nil t)
+ (help-xref-button 1 'help-face attr)))
+ (insert "\n")))))
+ (terpri)))))))
+
+ \f
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;; Face specifications (defface).
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ ;; Parameter FRAME Is kept for call compatibility to with previous
+ ;; face implementation.
+
+ (defun face-attr-construct (face &optional _frame)
+ "Return a `defface'-style attribute list for FACE.
+ Value is a property list of pairs ATTRIBUTE VALUE for all specified
+ face attributes of FACE where ATTRIBUTE is the attribute name and
+ VALUE is the specified value of that attribute.
+ Argument FRAME is ignored and retained for compatibility."
+ (let (result)
+ (dolist (entry face-attribute-name-alist result)
+ (let* ((attribute (car entry))
+ (value (face-attribute face attribute)))
+ (unless (eq value 'unspecified)
+ (setq result (nconc (list attribute value) result)))))))
+
+
+ (defun face-spec-set-match-display (display frame)
+ "Non-nil if DISPLAY matches FRAME.
+ DISPLAY is part of a spec such as can be used in `defface'.
+ If FRAME is nil, the current FRAME is used."
+ (let* ((conjuncts display)
+ conjunct req options
+ ;; t means we have succeeded against all the conjuncts in
+ ;; DISPLAY that have been tested so far.
+ (match t))
+ (if (eq conjuncts t)
+ (setq conjuncts nil))
+ (while (and conjuncts match)
+ (setq conjunct (car conjuncts)
+ conjuncts (cdr conjuncts)
+ req (car conjunct)
+ options (cdr conjunct)
+ match (cond ((eq req 'type)
+ (or (memq (window-system frame) options)
+ (and (memq 'graphic options)
+ (memq (window-system frame) '(x w32 ns)))
+ ;; FIXME: This should be revisited to use
+ ;; display-graphic-p, provided that the
+ ;; color selection depends on the number
+ ;; of supported colors, and all defface's
+ ;; are changed to look at number of colors
+ ;; instead of (type graphic) etc.
+ (if (null (window-system frame))
+ (memq 'tty options)
+ (or (and (memq 'motif options)
+ (featurep 'motif))
+ (and (memq 'gtk options)
+ (featurep 'gtk))
+ (and (memq 'lucid options)
+ (featurep 'x-toolkit)
+ (not (featurep 'motif))
+ (not (featurep 'gtk)))
+ (and (memq 'x-toolkit options)
+ (featurep 'x-toolkit))))))
+ ((eq req 'min-colors)
+ (>= (display-color-cells frame) (car options)))
+ ((eq req 'class)
+ (memq (frame-parameter frame 'display-type) options))
+ ((eq req 'background)
+ (memq (frame-parameter frame 'background-mode)
+ options))
+ ((eq req 'supports)
+ (display-supports-face-attributes-p options frame))
+ (t (error "Unknown req `%S' with options `%S'"
+ req options)))))
+ match))
+
+
+ (defun face-spec-choose (spec &optional frame no-match-retval)
+ "Return the proper attributes for FRAME, out of SPEC.
+
+ If no match is found or SPEC is nil, return nil, unless NO-MATCH-RETVAL
+ is given, in which case return its value instead."
+ (unless frame
+ (setq frame (selected-frame)))
+ (let ((tail spec)
+ result defaults match-found)
+ (while tail
+ (let* ((entry (pop tail))
+ (display (car entry))
+ (attrs (cdr entry))
+ thisval)
+ ;; Get the attributes as actually specified by this alternative.
+ (setq thisval
+ (if (null (cdr attrs)) ;; was (listp (car attrs))
+ ;; Old-style entry, the attribute list is the
+ ;; first element.
+ (car attrs)
+ attrs))
+
+ ;; If the condition is `default', that sets the default
+ ;; for following conditions.
+ (if (eq display 'default)
+ (setq defaults thisval)
+ ;; Otherwise, if it matches, use it.
+ (when (face-spec-set-match-display display frame)
+ (setq result thisval
+ tail nil
+ match-found t)))))
+ ;; If defaults have been found, it's safe to just append those to the result
+ ;; list (which at this point will be either nil or contain actual specs) and
+ ;; return it to the caller. Since there will most definitely be something to
+ ;; return in this case, there's no need to know/check if a match was found.
+ (if defaults
+ (append result defaults)
+ (if match-found
+ result
+ no-match-retval))))
+
+
+ (defun face-spec-reset-face (face &optional frame)
+ "Reset all attributes of FACE on FRAME to unspecified."
+ (apply 'set-face-attribute face frame
+ (if (eq face 'default)
+ ;; For the default face, avoid making any attribute
+ ;; unspecified. Instead, set attributes to default values
+ ;; (see also realize_default_face in xfaces.c).
+ (append
+ '(:underline nil :overline nil :strike-through nil
+ :box nil :inverse-video nil :stipple nil :inherit nil)
+ ;; `display-graphic-p' is unavailable when running
+ ;; temacs, prior to loading frame.el.
+ (when (fboundp 'display-graphic-p)
+ (unless (display-graphic-p frame)
+ `(:family "default" :foundry "default" :width normal
+ :height 1 :weight normal :slant normal
+ :foreground ,(if (frame-parameter nil 'reverse)
+ "unspecified-bg"
+ "unspecified-fg")
+ :background ,(if (frame-parameter nil 'reverse)
+ "unspecified-fg"
+ "unspecified-bg")))))
+ ;; For all other faces, unspecify all attributes.
+ (apply 'append
+ (mapcar (lambda (x) (list (car x) 'unspecified))
+ face-attribute-name-alist)))))
+
+ (defun face-spec-set (face spec &optional spec-type)
+ "Set the face spec SPEC for FACE.
+ See `defface' for the format of SPEC.
+
+ The appearance of each face is controlled by its specs (set via
+ this function), and by the internal frame-specific face
+ attributes (set via `set-face-attribute').
+
+ This function also defines FACE as a valid face name if it is not
+ already one, and (re)calculates its attributes on existing
+ frames.
+
+ The argument SPEC-TYPE determines which spec to set:
+ nil or `face-override-spec' means the override spec (which is
+ usually what you want if calling this function outside of
+ Custom code);
+ `customized-face' or `saved-face' means the customized spec or
+ the saved custom spec;
+ `face-defface-spec' means the default spec
+ (usually set only via `defface');
+ `reset' means to ignore SPEC, but clear the `customized-face'
+ and `face-override-spec' specs;
+ Any other value means not to set any spec, but to run the
+ function for its other effects."
+ (if (get face 'face-alias)
+ (setq face (get face 'face-alias)))
+ ;; Save SPEC to the relevant symbol property.
+ (unless spec-type
+ (setq spec-type 'face-override-spec))
+ (if (memq spec-type '(face-defface-spec face-override-spec
+ customized-face saved-face))
+ (put face spec-type spec))
+ (if (memq spec-type '(reset saved-face))
+ (put face 'customized-face nil))
+ ;; Setting the face spec via Custom empties out any override spec,
+ ;; similar to how setting a variable via Custom changes its values.
+ (if (memq spec-type '(customized-face saved-face reset))
+ (put face 'face-override-spec nil))
+ ;; If we reset the face based on its custom spec, it is unmodified
+ ;; as far as Custom is concerned.
+ (unless (eq face 'face-override-spec)
+ (put face 'face-modified nil))
+ ;; Initialize the face if it does not exist, then recalculate.
+ (make-empty-face face)
+ (dolist (frame (frame-list))
+ (face-spec-recalc face frame)))
+
+ (defun face-spec-recalc (face frame)
+ "Reset the face attributes of FACE on FRAME according to its specs.
+ The following sources are applied in this order:
+
+ face reset to default values if it's the default face, otherwise set
+ to unspecified (through `face-spec-reset-face')
+ |
+ (theme and user customization)
+ or: if none of the above exist, and none match the current frame or
+ inherited from the defface spec instead of overwriting it
+ entirely, the following is applied instead:
+ (defface default spec)
+ (X resources (if applicable))
+ |
+ defface override spec"
+ (while (get face 'face-alias)
+ (setq face (get face 'face-alias)))
+ (face-spec-reset-face face frame)
+ ;; If FACE is customized or themed, set the custom spec from
+ ;; `theme-face' records.
+ (let ((theme-faces (get face 'theme-face))
+ (no-match-found 0)
+ spec theme-face-applied)
+ (if theme-faces
+ (dolist (elt (reverse theme-faces))
+ (setq spec (face-spec-choose (cadr elt) frame no-match-found))
+ (unless (eq spec no-match-found)
+ (face-spec-set-2 face frame spec)
+ (setq theme-face-applied t))))
+ ;; If there was a spec applicable to FRAME, that overrides the
+ ;; defface spec entirely (rather than inheriting from it). If
+ ;; there was no spec applicable to FRAME, apply the defface spec
+ ;; as well as any applicable X resources.
+ (unless theme-face-applied
+ (setq spec (face-spec-choose (face-default-spec face) frame))
+ (face-spec-set-2 face frame spec)
+ (make-face-x-resource-internal face frame))
+ (setq spec (face-spec-choose (get face 'face-override-spec) frame))
+ (face-spec-set-2 face frame spec)))
+
+ (defun face-spec-set-2 (face frame spec)
+ "Set the face attributes of FACE on FRAME according to SPEC."
+ (let (attrs)
+ (while spec
+ (when (assq (car spec) face-x-resources)
+ (push (car spec) attrs)
+ (push (cadr spec) attrs))
+ (setq spec (cddr spec)))
+ (apply 'set-face-attribute face frame (nreverse attrs))))
+
+ (defun face-attr-match-p (face attrs &optional frame)
+ "Return t if attributes of FACE match values in plist ATTRS.
+ Optional parameter FRAME is the frame whose definition of FACE
+ is used. If nil or omitted, use the selected frame."
+ (unless frame
+ (setq frame (selected-frame)))
+ (let* ((list face-attribute-name-alist)
+ (match t)
+ (bold (and (plist-member attrs :bold)
+ (not (plist-member attrs :weight))))
+ (italic (and (plist-member attrs :italic)
+ (not (plist-member attrs :slant))))
+ (plist (if (or bold italic)
+ (copy-sequence attrs)
+ attrs)))
+ ;; Handle the Emacs 20 :bold and :italic properties.
+ (if bold
+ (plist-put plist :weight (if bold 'bold 'normal)))
+ (if italic
+ (plist-put plist :slant (if italic 'italic 'normal)))
+ (while (and match list)
+ (let* ((attr (caar list))
+ (specified-value
+ (if (plist-member plist attr)
+ (plist-get plist attr)
+ 'unspecified))
+ (value-now (face-attribute face attr frame)))
+ (setq match (equal specified-value value-now))
+ (setq list (cdr list))))
+ match))
+
+ (defsubst face-spec-match-p (face spec &optional frame)
+ "Return t if FACE, on FRAME, matches what SPEC says it should look like."
+ (face-attr-match-p face (face-spec-choose spec frame) frame))
+
+ (defsubst face-default-spec (face)
+ "Return the default face-spec for FACE, ignoring any user customization.
+ If there is no default for FACE, return nil."
+ (get face 'face-defface-spec))
+
+ (defsubst face-user-default-spec (face)
+ "Return the user's customized face-spec for FACE, or the default if none.
+ If there is neither a user setting nor a default for FACE, return nil."
+ (or (get face 'customized-face)
+ (get face 'saved-face)
+ (face-default-spec face)))
+
+ \f
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;; Frame-type independent color support.
+ ;;; We keep the old x-* names as aliases for back-compatibility.
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (defun defined-colors (&optional frame)
+ "Return a list of colors supported for a particular frame.
+ The argument FRAME specifies which frame to try.
+ The value may be different for frames on different display types.
+ If FRAME doesn't support colors, the value is nil.
+ If FRAME is nil, that stands for the selected frame."
+ (if (memq (framep (or frame (selected-frame))) '(x w32 ns))
+ (xw-defined-colors frame)
+ (mapcar 'car (tty-color-alist frame))))
+ (defalias 'x-defined-colors 'defined-colors)
+
+ (declare-function xw-color-defined-p "xfns.c" (color &optional frame))
+
+ (defun color-defined-p (color &optional frame)
+ "Return non-nil if COLOR is supported on frame FRAME.
+ COLOR should be a string naming a color (e.g. \"white\"), or a
+ string specifying a color's RGB components (e.g. \"#ff12ec\"), or
+ the symbol `unspecified'.
+
+ This function returns nil if COLOR is the symbol `unspecified',
+ or one of the strings \"unspecified-fg\" or \"unspecified-bg\".
+
+ If FRAME is omitted or nil, use the selected frame."
+ (unless (member color '(unspecified "unspecified-bg" "unspecified-fg"))
+ (if (member (framep (or frame (selected-frame))) '(x w32 ns))
+ (xw-color-defined-p color frame)
+ (numberp (tty-color-translate color frame)))))
+ (defalias 'x-color-defined-p 'color-defined-p)
+
+ (declare-function xw-color-values "xfns.c" (color &optional frame))
+
+ (defun color-values (color &optional frame)
+ "Return a description of the color named COLOR on frame FRAME.
+ COLOR should be a string naming a color (e.g. \"white\"), or a
+ string specifying a color's RGB components (e.g. \"#ff12ec\").
+
+ Return a list of three integers, (RED GREEN BLUE), each between 0
+ and either 65280 or 65535 (the maximum depends on the system).
+ Use `color-name-to-rgb' if you want RGB floating-point values
+ normalized to 1.0.
+
+ If FRAME is omitted or nil, use the selected frame.
+ If FRAME cannot display COLOR, the value is nil.
+
+ COLOR can also be the symbol `unspecified' or one of the strings
+ \"unspecified-fg\" or \"unspecified-bg\", in which case the
+ return value is nil."
+ (cond
+ ((member color '(unspecified "unspecified-fg" "unspecified-bg"))
+ nil)
+ ((memq (framep (or frame (selected-frame))) '(x w32 ns))
+ (xw-color-values color frame))
+ (t
+ (tty-color-values color frame))))
+
+ (defalias 'x-color-values 'color-values)
+
+ (declare-function xw-display-color-p "xfns.c" (&optional terminal))
+
+ (defun display-color-p (&optional display)
+ "Return t if DISPLAY supports color.
+ The optional argument DISPLAY specifies which display to ask about.
+ DISPLAY should be either a frame or a display name (a string).
+ If omitted or nil, that stands for the selected frame's display."
+ (if (memq (framep-on-display display) '(x w32 ns))
+ (xw-display-color-p display)
+ (tty-display-color-p display)))
+ (defalias 'x-display-color-p 'display-color-p)
+
+ (declare-function x-display-grayscale-p "xfns.c" (&optional terminal))
+
+ (defun display-grayscale-p (&optional display)
+ "Return non-nil if frames on DISPLAY can display shades of gray.
+ DISPLAY should be either a frame or a display name (a string).
+ If omitted or nil, that stands for the selected frame's display."
+ (let ((frame-type (framep-on-display display)))
+ (cond
+ ((memq frame-type '(x w32 ns))
+ (x-display-grayscale-p display))
+ (t
+ (> (tty-color-gray-shades display) 2)))))
+
+ (defun read-color (&optional prompt convert-to-RGB allow-empty-name msg)
+ "Read a color name or RGB triplet.
+ Completion is available for color names, but not for RGB triplets.
+
+ RGB triplets have the form \"#RRGGBB\". Each of the R, G, and B
+ components can have one to four digits, but all three components
+ must have the same number of digits. Each digit is a hex value
+ between 0 and F; either upper case or lower case for A through F
+ are acceptable.
+
+ In addition to standard color names and RGB hex values, the
+ following are available as color candidates. In each case, the
+ corresponding color is used.
+
+ * `foreground at point' - foreground under the cursor
+ * `background at point' - background under the cursor
+
+ Optional arg PROMPT is the prompt; if nil, use a default prompt.
+
+ Interactively, or with optional arg CONVERT-TO-RGB-P non-nil,
+ convert an input color name to an RGB hex string. Return the RGB
+ hex string.
+
+ If optional arg ALLOW-EMPTY-NAME is non-nil, the user is allowed
+ to enter an empty color name (the empty string).
+
+ Interactively, or with optional arg MSG non-nil, print the
+ resulting color name in the echo area."
+ (interactive "i\np\ni\np") ; Always convert to RGB interactively.
+ (let* ((completion-ignore-case t)
+ (colors (or facemenu-color-alist
+ (append '("foreground at point" "background at point")
+ (if allow-empty-name '(""))
+ (defined-colors))))
+ (color (completing-read
+ (or prompt "Color (name or #RGB triplet): ")
+ ;; Completing function for reading colors, accepting
+ ;; both color names and RGB triplets.
+ (lambda (string pred flag)
+ (cond
+ ((null flag) ; Try completion.
+ (or (try-completion string colors pred)
+ (if (color-defined-p string)
+ string)))
+ ((eq flag t) ; List all completions.
+ (or (all-completions string colors pred)
+ (if (color-defined-p string)
+ (list string))))
+ ((eq flag 'lambda) ; Test completion.
+ (or (member string colors)
+ (color-defined-p string)))))
+ nil t)))
+
+ ;; Process named colors.
+ (when (member color colors)
+ (cond ((string-equal color "foreground at point")
+ (setq color (foreground-color-at-point)))
+ ((string-equal color "background at point")
+ (setq color (background-color-at-point))))
+ (when (and convert-to-RGB
+ (not (string-equal color "")))
+ (let ((components (x-color-values color)))
+ (unless (string-match-p "^#\\(?:[a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color)
+ (setq color (format "#%04X%04X%04X"
+ (logand 65535 (nth 0 components))
+ (logand 65535 (nth 1 components))
+ (logand 65535 (nth 2 components))))))))
+ (when msg (message "Color: `%s'" color))
+ color))
+
+ (defun face-at-point (&optional thing multiple)
+ "Return the face of the character after point.
+ If it has more than one face, return the first one.
+ If THING is non-nil try first to get a face name from the buffer.
+ IF MULTIPLE is non-nil, return a list of all faces.
+ Return nil if there is no face."
+ (let (faces)
+ (if thing
+ ;; Try to get a face name from the buffer.
+ (let ((face (intern-soft (thing-at-point 'symbol))))
+ (if (facep face)
+ (push face faces))))
+ ;; Add the named faces that the `read-face-name' or `face' property uses.
+ (let ((faceprop (or (get-char-property (point) 'read-face-name)
+ (get-char-property (point) 'face))))
+ (cond ((facep faceprop)
+ (push faceprop faces))
+ ((and (listp faceprop)
+ ;; Don't treat an attribute spec as a list of faces.
+ (not (keywordp (car faceprop)))
+ (not (memq (car faceprop)
+ '(foreground-color background-color))))
+ (dolist (face faceprop)
+ (if (facep face)
+ (push face faces))))))
+ (setq faces (delete-dups (nreverse faces)))
+ (if multiple faces (car faces))))
+
+ (defun foreground-color-at-point ()
+ "Return the foreground color of the character after point."
+ ;; `face-at-point' alone is not sufficient. It only gets named faces.
+ ;; Need also pick up any face properties that are not associated with named faces.
+ (let ((face (or (face-at-point)
+ (get-char-property (point) 'read-face-name)
+ (get-char-property (point) 'face))))
+ (cond ((and face (symbolp face))
+ (let ((value (face-foreground face nil 'default)))
+ (if (member value '("unspecified-fg" "unspecified-bg"))
+ nil
+ value)))
+ ((consp face)
+ (cond ((memq 'foreground-color face) (cdr (memq 'foreground-color face)))
+ ((memq ':foreground face) (cadr (memq ':foreground face)))))
+ (t nil)))) ; Invalid face value.
+
+ (defun background-color-at-point ()
+ "Return the background color of the character after point."
+ ;; `face-at-point' alone is not sufficient. It only gets named faces.
+ ;; Need also pick up any face properties that are not associated with named faces.
+ (let ((face (or (face-at-point)
+ (get-char-property (point) 'read-face-name)
+ (get-char-property (point) 'face))))
+ (cond ((and face (symbolp face))
+ (let ((value (face-background face nil 'default)))
+ (if (member value '("unspecified-fg" "unspecified-bg"))
+ nil
+ value)))
+ ((consp face)
+ (cond ((memq 'background-color face) (cdr (memq 'background-color face)))
+ ((memq ':background face) (cadr (memq ':background face)))))
+ (t nil)))) ; Invalid face value.
+
+ \f
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;; Frame creation.
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (declare-function x-display-list "xfns.c" ())
+ (declare-function x-open-connection "xfns.c"
+ (display &optional xrm-string must-succeed))
+ (declare-function x-get-resource "frame.c"
+ (attribute class &optional component subclass))
+ (declare-function x-parse-geometry "frame.c" (string))
+ (defvar x-display-name)
+
+ (defun x-handle-named-frame-geometry (parameters)
+ "Add geometry parameters for a named frame to parameter list PARAMETERS.
+ Value is the new parameter list."
+ ;; Note that `x-resource-name' has a global meaning.
+ (let ((x-resource-name (cdr (assq 'name parameters))))
+ (when x-resource-name
+ ;; Before checking X resources, we must have an X connection.
+ (or (window-system)
+ (x-display-list)
+ (x-open-connection (or (cdr (assq 'display parameters))
+ x-display-name)))
+ (let (res-geometry parsed)
+ (and (setq res-geometry (x-get-resource "geometry" "Geometry"))
+ (setq parsed (x-parse-geometry res-geometry))
+ (setq parameters
+ (append parameters parsed
+ ;; If the resource specifies a position,
+ ;; take note of that.
+ (if (or (assq 'top parsed) (assq 'left parsed))
+ '((user-position . t) (user-size . t)))))))))
+ parameters)
+
+
+ (defun x-handle-reverse-video (frame parameters)
+ "Handle the reverse-video frame parameter and X resource.
+ `x-create-frame' does not handle this one."
+ (when (cdr (or (assq 'reverse parameters)
+ (let ((resource (x-get-resource "reverseVideo"
+ "ReverseVideo")))
+ (if resource
+ (cons nil (member (downcase resource)
+ '("on" "true")))))))
+ (let* ((params (frame-parameters frame))
+ (bg (cdr (assq 'foreground-color params)))
+ (fg (cdr (assq 'background-color params))))
+ (modify-frame-parameters frame
+ (list (cons 'foreground-color fg)
+ (cons 'background-color bg)))
+ (if (equal bg (cdr (assq 'border-color params)))
+ (modify-frame-parameters frame
+ (list (cons 'border-color fg))))
+ (if (equal bg (cdr (assq 'mouse-color params)))
+ (modify-frame-parameters frame
+ (list (cons 'mouse-color fg))))
+ (if (equal bg (cdr (assq 'cursor-color params)))
+ (modify-frame-parameters frame
+ (list (cons 'cursor-color fg)))))))
+
+ (declare-function x-create-frame "xfns.c" (parms))
+ (declare-function x-setup-function-keys "term/common-win" (frame))
+
+ (defun x-create-frame-with-faces (&optional parameters)
+ "Create and return a frame with frame parameters PARAMETERS.
+ If PARAMETERS specify a frame name, handle X geometry resources
+ for that name. If PARAMETERS includes a `reverse' parameter, or
+ the X resource ``reverseVideo'' is present, handle that."
+ (setq parameters (x-handle-named-frame-geometry parameters))
+ (let* ((params (copy-tree parameters))
+ (visibility-spec (assq 'visibility parameters))
+ (delayed-params '(foreground-color background-color font
+ border-color cursor-color mouse-color
+ visibility scroll-bar-foreground
+ scroll-bar-background))
+ frame success)
+ (dolist (param delayed-params)
+ (setq params (assq-delete-all param params)))
+ (setq frame (x-create-frame `((visibility . nil) . ,params)))
+ (unwind-protect
+ (progn
+ (x-setup-function-keys frame)
+ (x-handle-reverse-video frame parameters)
+ (frame-set-background-mode frame t)
+ (face-set-after-frame-default frame parameters)
+ (if (null visibility-spec)
+ (make-frame-visible frame)
+ (modify-frame-parameters frame (list visibility-spec)))
+ (setq success t))
+ (unless success
+ (delete-frame frame)))
+ frame))
+
+ (defun face-set-after-frame-default (frame &optional parameters)
+ "Initialize the frame-local faces of FRAME.
+ Calculate the face definitions using the face specs, custom theme
+ settings, X resources, and `face-new-frame-defaults'.
+ Finally, apply any relevant face attributes found amongst the
+ frame parameters in PARAMETERS."
+ (let ((window-system-p (memq (window-system frame) '(x w32))))
+ ;; The `reverse' is so that `default' goes first.
+ (dolist (face (nreverse (face-list)))
+ (condition-case ()
+ (progn
+ ;; Initialize faces from face spec and custom theme.
+ (face-spec-recalc face frame)
+ ;; Apply attributes specified by face-new-frame-defaults
+ (internal-merge-in-global-face face frame))
+ ;; Don't let invalid specs prevent frame creation.
+ (error nil))))
+
+ ;; Apply attributes specified by frame parameters.
+ (let ((face-params '((foreground-color default :foreground)
+ (background-color default :background)
+ (font default :font)
+ (border-color border :background)
+ (cursor-color cursor :background)
+ (scroll-bar-foreground scroll-bar :foreground)
+ (scroll-bar-background scroll-bar :background)
+ (mouse-color mouse :background))))
+ (dolist (param face-params)
+ (let* ((param-name (nth 0 param))
+ (value (cdr (assq param-name parameters))))
+ (if value
+ (set-face-attribute (nth 1 param) frame
+ (nth 2 param) value))))))
+
+ (defun tty-handle-reverse-video (frame parameters)
+ "Handle the reverse-video frame parameter for terminal frames."
+ (when (cdr (assq 'reverse parameters))
+ (let* ((params (frame-parameters frame))
+ (bg (cdr (assq 'foreground-color params)))
+ (fg (cdr (assq 'background-color params))))
+ (modify-frame-parameters frame
+ (list (cons 'foreground-color fg)
+ (cons 'background-color bg)))
+ (if (equal bg (cdr (assq 'mouse-color params)))
+ (modify-frame-parameters frame
+ (list (cons 'mouse-color fg))))
+ (if (equal bg (cdr (assq 'cursor-color params)))
+ (modify-frame-parameters frame
+ (list (cons 'cursor-color fg)))))))
+
+
+ (defun tty-create-frame-with-faces (&optional parameters)
+ "Create and return a frame from optional frame parameters PARAMETERS.
+ If PARAMETERS contains a `reverse' parameter, handle that."
+ (let ((frame (make-terminal-frame parameters))
+ success)
+ (unwind-protect
+ (with-selected-frame frame
+ (tty-handle-reverse-video frame (frame-parameters frame))
+
+ (unless (terminal-parameter frame 'terminal-initted)
+ (set-terminal-parameter frame 'terminal-initted t)
+ (set-locale-environment nil frame)
+ (tty-run-terminal-initialization frame nil t))
+ (frame-set-background-mode frame t)
+ (face-set-after-frame-default frame parameters)
+ (setq success t))
+ (unless success
+ (delete-frame frame)))
+ frame))
+
+ (defun tty-find-type (pred type)
+ "Return the longest prefix of TYPE to which PRED returns non-nil.
+ TYPE should be a tty type name such as \"xterm-16color\".
+
+ The function tries only those prefixes that are followed by a
+ dash or underscore in the original type name, like \"xterm\" in
+ the above example."
+ (let (hyphend)
+ (while (and type
+ (not (funcall pred type)))
+ ;; Strip off last hyphen and what follows, then try again
+ (setq type
+ (if (setq hyphend (string-match-p "[-_][^-_]+$" type))
+ (substring type 0 hyphend)
+ nil))))
+ type)
+
+ (defvar tty-setup-hook nil
+ "Hook run after running the initialization function of a new text terminal.
+ Specifically, `tty-run-terminal-initialization' runs this.
+ This can be used to fine tune the `input-decode-map', for example.")
+
+ (defun tty-run-terminal-initialization (frame &optional type run-hook)
+ "Run the special initialization code for the terminal type of FRAME.
+ The optional TYPE parameter may be used to override the autodetected
+ terminal type to a different value.
+
+ If optional argument RUN-HOOK is non-nil, then as a final step,
+ this runs the hook `tty-setup-hook'.
+
+ If you set `term-file-prefix' to nil, this function does nothing."
+ (setq type (or type (tty-type frame)))
+ ;; Load library for our terminal type.
+ ;; User init file can set term-file-prefix to nil to prevent this.
+ (with-selected-frame frame
+ (unless (null term-file-prefix)
+ (let* (term-init-func)
+ ;; First, load the terminal initialization file, if it is
+ ;; available and it hasn't been loaded already.
+ (tty-find-type #'(lambda (type)
+ (let ((file (locate-library (concat term-file-prefix type))))
+ (and file
+ (or (assoc file load-history)
+ (load file t t)))))
+ type)
+ ;; Next, try to find a matching initialization function, and call it.
+ (tty-find-type #'(lambda (type)
+ (fboundp (setq term-init-func
+ (intern (concat "terminal-init-" type)))))
+ type)
+ (when (fboundp term-init-func)
+ (funcall term-init-func))
+ (set-terminal-parameter frame 'terminal-initted term-init-func)
+ (if run-hook (run-hooks 'tty-setup-hook))))))
+
+ ;; Called from C function init_display to initialize faces of the
+ ;; dumped terminal frame on startup.
+
+ (defun tty-set-up-initial-frame-faces ()
+ (let ((frame (selected-frame)))
+ (frame-set-background-mode frame t)
+ (face-set-after-frame-default frame)))
+
+ \f
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;; Standard faces.
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (defgroup basic-faces nil
+ "The standard faces of Emacs."
+ :group 'faces)
+
+ (defface default
+ '((t nil)) ; If this were nil, face-defface-spec would not be set.
+ "Basic default face."
+ :group 'basic-faces)
+
+ (defface bold
+ '((t :weight bold))
+ "Basic bold face."
+ :group 'basic-faces)
+
+ (defface italic
+ '((((supports :slant italic))
+ :slant italic)
+ (((supports :underline t))
+ :underline t)
+ (t
+ ;; Default to italic, even if it doesn't appear to be supported,
+ ;; because in some cases the display engine will do its own
+ ;; workaround (to `dim' on ttys).
+ :slant italic))
+ "Basic italic face."
+ :group 'basic-faces)
+
+ (defface bold-italic
+ '((t :weight bold :slant italic))
+ "Basic bold-italic face."
+ :group 'basic-faces)
+
+ (defface underline
+ '((((supports :underline t))
+ :underline t)
+ (((supports :weight bold))
+ :weight bold)
+ (t :underline t))
+ "Basic underlined face."
+ :group 'basic-faces)
+
+ (defface fixed-pitch
+ '((t :family "Monospace"))
+ "The basic fixed-pitch face."
+ :group 'basic-faces)
+
+ (defface variable-pitch
+ '((t :family "Sans Serif"))
+ "The basic variable-pitch face."
+ :group 'basic-faces)
+
+ (defface shadow
+ '((((class color grayscale) (min-colors 88) (background light))
+ :foreground "grey50")
+ (((class color grayscale) (min-colors 88) (background dark))
+ :foreground "grey70")
+ (((class color) (min-colors 8) (background light))
+ :foreground "green")
+ (((class color) (min-colors 8) (background dark))
+ :foreground "yellow"))
+ "Basic face for shadowed text."
+ :group 'basic-faces
+ :version "22.1")
+
+ (defface link
+ '((((class color) (min-colors 88) (background light))
+ :foreground "RoyalBlue3" :underline t)
+ (((class color) (background light))
+ :foreground "blue" :underline t)
+ (((class color) (min-colors 88) (background dark))
+ :foreground "cyan1" :underline t)
+ (((class color) (background dark))
+ :foreground "cyan" :underline t)
+ (t :inherit underline))
+ "Basic face for unvisited links."
+ :group 'basic-faces
+ :version "22.1")
+
+ (defface link-visited
+ '((default :inherit link)
+ (((class color) (background light)) :foreground "magenta4")
+ (((class color) (background dark)) :foreground "violet"))
+ "Basic face for visited links."
+ :group 'basic-faces
+ :version "22.1")
+
+ (defface highlight
+ '((((class color) (min-colors 88) (background light))
+ :background "darkseagreen2")
+ (((class color) (min-colors 88) (background dark))
+ :background "darkolivegreen")
+ (((class color) (min-colors 16) (background light))
+ :background "darkseagreen2")
+ (((class color) (min-colors 16) (background dark))
+ :background "darkolivegreen")
+ (((class color) (min-colors 8))
+ :background "green" :foreground "black")
+ (t :inverse-video t))
+ "Basic face for highlighting."
+ :group 'basic-faces)
+
+ ;; Region face: under NS, default to the system-defined selection
+ ;; color (optimized for the fixed white background of other apps),
+ ;; if background is light.
+ (defface region
+ '((((class color) (min-colors 88) (background dark))
+ :background "blue3")
+ (((class color) (min-colors 88) (background light) (type gtk))
+ :distant-foreground "gtk_selection_fg_color"
+ :background "gtk_selection_bg_color")
+ (((class color) (min-colors 88) (background light) (type ns))
+ :distant-foreground "ns_selection_fg_color"
+ :background "ns_selection_bg_color")
+ (((class color) (min-colors 88) (background light))
+ :background "lightgoldenrod2")
+ (((class color) (min-colors 16) (background dark))
+ :background "blue3")
+ (((class color) (min-colors 16) (background light))
+ :background "lightgoldenrod2")
+ (((class color) (min-colors 8))
+ :background "blue" :foreground "white")
+ (((type tty) (class mono))
+ :inverse-video t)
+ (t :background "gray"))
+ "Basic face for highlighting the region."
+ :version "21.1"
+ :group 'basic-faces)
+
+ (defface secondary-selection
+ '((((class color) (min-colors 88) (background light))
+ :background "yellow1")
+ (((class color) (min-colors 88) (background dark))
+ :background "SkyBlue4")
+ (((class color) (min-colors 16) (background light))
+ :background "yellow")
+ (((class color) (min-colors 16) (background dark))
+ :background "SkyBlue4")
+ (((class color) (min-colors 8))
+ :background "cyan" :foreground "black")
+ (t :inverse-video t))
+ "Basic face for displaying the secondary selection."
+ :group 'basic-faces)
+
+ (defface trailing-whitespace
+ '((((class color) (background light))
+ :background "red1")
+ (((class color) (background dark))
+ :background "red1")
+ (t :inverse-video t))
+ "Basic face for highlighting trailing whitespace."
+ :version "21.1"
+ :group 'basic-faces)
+
+ (defface escape-glyph
+ '((((background dark)) :foreground "cyan")
+ ;; See the comment in minibuffer-prompt for
+ ;; the reason not to use blue on MS-DOS.
+ (((type pc)) :foreground "magenta")
+ ;; red4 is too dark, but some say blue is too loud.
+ ;; brown seems to work ok. -- rms.
+ (t :foreground "brown"))
+ "Face for characters displayed as sequences using `^' or `\\'."
+ :group 'basic-faces
+ :version "22.1")
+
+ (defface nobreak-space
+ '((((class color) (min-colors 88)) :inherit escape-glyph :underline t)
+ (((class color) (min-colors 8)) :background "magenta")
+ (t :inverse-video t))
+ "Face for displaying nobreak space."
+ :group 'basic-faces
+ :version "22.1")
+
+ (defgroup mode-line-faces nil
+ "Faces used in the mode line."
+ :group 'mode-line
+ :group 'faces
+ :version "22.1")
+
+ (defface mode-line
+ '((((class color) (min-colors 88))
+ :box (:line-width -1 :style released-button)
+ :background "grey75" :foreground "black")
+ (t
+ :inverse-video t))
+ "Basic mode line face for selected window."
+ :version "21.1"
+ :group 'mode-line-faces
+ :group 'basic-faces)
+
+ (defface mode-line-inactive
+ '((default
+ :inherit mode-line)
+ (((class color) (min-colors 88) (background light))
+ :weight light
+ :box (:line-width -1 :color "grey75" :style nil)
+ :foreground "grey20" :background "grey90")
+ (((class color) (min-colors 88) (background dark) )
+ :weight light
+ :box (:line-width -1 :color "grey40" :style nil)
+ :foreground "grey80" :background "grey30"))
+ "Basic mode line face for non-selected windows."
+ :version "22.1"
+ :group 'mode-line-faces
+ :group 'basic-faces)
+ (define-obsolete-face-alias 'modeline-inactive 'mode-line-inactive "22.1")
+
+ (defface mode-line-highlight
+ '((((class color) (min-colors 88))
+ :box (:line-width 2 :color "grey40" :style released-button))
+ (t
+ :inherit highlight))
+ "Basic mode line face for highlighting."
+ :version "22.1"
+ :group 'mode-line-faces
+ :group 'basic-faces)
+ (define-obsolete-face-alias 'modeline-highlight 'mode-line-highlight "22.1")
+
+ (defface mode-line-emphasis
+ '((t (:weight bold)))
+ "Face used to emphasize certain mode line features.
+ Use the face `mode-line-highlight' for features that can be selected."
+ :version "23.1"
+ :group 'mode-line-faces
+ :group 'basic-faces)
+
+ (defface mode-line-buffer-id
+ '((t (:weight bold)))
+ "Face used for buffer identification parts of the mode line."
+ :version "22.1"
+ :group 'mode-line-faces
+ :group 'basic-faces)
+ (define-obsolete-face-alias 'modeline-buffer-id 'mode-line-buffer-id "22.1")
+
+ (defface header-line
+ '((default
+ :inherit mode-line)
+ (((type tty))
+ ;; This used to be `:inverse-video t', but that doesn't look very
+ ;; good when combined with inverse-video mode-lines and multiple
+ ;; windows. Underlining looks better, and is more consistent with
+ ;; the window-system face variants, which deemphasize the
+ ;; header-line in relation to the mode-line face. If a terminal
+ ;; can't underline, then the header-line will end up without any
+ ;; highlighting; this may be too confusing in general, although it
+ ;; happens to look good with the only current use of header-lines,
+ ;; the info browser. XXX
+ :inverse-video nil ;Override the value inherited from mode-line.
+ :underline t)
+ (((class color grayscale) (background light))
+ :background "grey90" :foreground "grey20"
+ :box nil)
+ (((class color grayscale) (background dark))
+ :background "grey20" :foreground "grey90"
+ :box nil)
+ (((class mono) (background light))
+ :background "white" :foreground "black"
+ :inverse-video nil
+ :box nil
+ :underline t)
+ (((class mono) (background dark))
+ :background "black" :foreground "white"
+ :inverse-video nil
+ :box nil
+ :underline t))
+ "Basic header-line face."
+ :version "21.1"
+ :group 'basic-faces)
+
+ (defface vertical-border
+ '((((type tty)) :inherit mode-line-inactive))
+ "Face used for vertical window dividers on ttys."
+ :version "22.1"
+ :group 'basic-faces)
+
+ (defface window-divider '((t :foreground "gray60"))
+ "Basic face for window dividers.
+ When a divider is less than 3 pixels wide, it is drawn solidly
+ with the foreground of this face. For larger dividers this face
+ is used for the inner part while the first pixel line/column is
+ drawn with the `window-divider-first-pixel' face and the last
+ pixel line/column with the `window-divider-last-pixel' face."
+ :version "24.4"
+ :group 'frames
+ :group 'basic-faces)
+
+ (defface window-divider-first-pixel
+ '((t :foreground "gray80"))
+ "Basic face for first pixel line/column of window dividers.
+ When a divider is at least 3 pixels wide, its first pixel
+ line/column is drawn with the foreground of this face. If you do
+ not want to accentuate the first pixel line/column, set this to
+ the same as `window-divider' face."
+ :version "24.4"
+ :group 'frames
+ :group 'basic-faces)
+
+ (defface window-divider-last-pixel
+ '((t :foreground "gray40"))
+ "Basic face for last pixel line/column of window dividers.
+ When a divider is at least 3 pixels wide, its last pixel
+ line/column is drawn with the foreground of this face. If you do
+ not want to accentuate the last pixel line/column, set this to
+ the same as `window-divider' face."
+ :version "24.4"
+ :group 'frames
+ :group 'basic-faces)
+
+ (defface minibuffer-prompt
+ '((((background dark)) :foreground "cyan")
+ ;; Don't use blue because many users of the MS-DOS port customize
+ ;; their foreground color to be blue.
+ (((type pc)) :foreground "magenta")
+ (t :foreground "medium blue"))
+ "Face for minibuffer prompts.
+ By default, Emacs automatically adds this face to the value of
+ `minibuffer-prompt-properties', which is a list of text properties
+ used to display the prompt text."
+ :version "22.1"
+ :group 'basic-faces)
+
+ (setq minibuffer-prompt-properties
+ (append minibuffer-prompt-properties (list 'face 'minibuffer-prompt)))
+
+ (defface fringe
+ '((((class color) (background light))
+ :background "grey95")
+ (((class color) (background dark))
+ :background "grey10")
+ (t
+ :background "gray"))
+ "Basic face for the fringes to the left and right of windows under X."
+ :version "21.1"
+ :group 'frames
+ :group 'basic-faces)
+
+ (defface scroll-bar '((t nil))
+ "Basic face for the scroll bar colors under X."
+ :version "21.1"
+ :group 'frames
+ :group 'basic-faces)
+
+ (defface border '((t nil))
+ "Basic face for the frame border under X."
+ :version "21.1"
+ :group 'frames
+ :group 'basic-faces)
+
+ (defface cursor
+ '((((background light)) :background "black")
+ (((background dark)) :background "white"))
+ "Basic face for the cursor color under X.
+ Currently, only the `:background' attribute is meaningful; all
+ other attributes are ignored. The cursor foreground color is
+ taken from the background color of the underlying text.
+
+ Note: Other faces cannot inherit from the cursor face."
+ :version "21.1"
+ :group 'cursor
+ :group 'basic-faces)
+
+ (put 'cursor 'face-no-inherit t)
+
+ (defface mouse '((t nil))
+ "Basic face for the mouse color under X."
+ :version "21.1"
+ :group 'mouse
+ :group 'basic-faces)
+
+ (defface tool-bar
+ '((default
+ :box (:line-width 1 :style released-button)
+ :foreground "black")
+ (((type x w32 ns) (class color))
+ :background "grey75")
+ (((type x) (class mono))
+ :background "grey"))
+ "Basic tool-bar face."
+ :version "21.1"
+ :group 'basic-faces)
+
+ (defface menu
+ '((((type tty))
+ :inverse-video t)
+ (((type x-toolkit))
+ )
+ (t
+ :inverse-video t))
+ "Basic face for the font and colors of the menu bar and popup menus."
+ :version "21.1"
+ :group 'menu
+ :group 'basic-faces)
+
+ (defface help-argument-name '((t :inherit italic))
+ "Face to highlight argument names in *Help* buffers."
+ :group 'help)
+
+ (defface glyphless-char
+ '((((type tty)) :inherit underline)
+ (((type pc)) :inherit escape-glyph)
+ (t :height 0.6))
+ "Face for displaying non-graphic characters (e.g. U+202A (LRE)).
+ It is used for characters of no fonts too."
+ :version "24.1"
+ :group 'basic-faces)
+
+ (defface error
+ '((default :weight bold)
+ (((class color) (min-colors 88) (background light)) :foreground "Red1")
+ (((class color) (min-colors 88) (background dark)) :foreground "Pink")
+ (((class color) (min-colors 16) (background light)) :foreground "Red1")
+ (((class color) (min-colors 16) (background dark)) :foreground "Pink")
+ (((class color) (min-colors 8)) :foreground "red")
+ (t :inverse-video t))
+ "Basic face used to highlight errors and to denote failure."
+ :version "24.1"
+ :group 'basic-faces)
+
+ (defface warning
+ '((default :weight bold)
+ (((class color) (min-colors 16)) :foreground "DarkOrange")
+ (((class color)) :foreground "yellow"))
+ "Basic face used to highlight warnings."
+ :version "24.1"
+ :group 'basic-faces)
+
+ (defface success
+ '((default :weight bold)
+ (((class color) (min-colors 16) (background light)) :foreground "ForestGreen")
+ (((class color) (min-colors 88) (background dark)) :foreground "Green1")
+ (((class color) (min-colors 16) (background dark)) :foreground "Green")
+ (((class color)) :foreground "green"))
+ "Basic face used to indicate successful operation."
+ :version "24.1"
+ :group 'basic-faces)
+
+ ;; Faces for TTY menus.
+ (defface tty-menu-enabled-face
+ '((t
+ :foreground "yellow" :background "blue" :weight bold))
+ "Face for displaying enabled items in TTY menus."
+ :group 'basic-faces)
+
+ (defface tty-menu-disabled-face
+ '((((class color) (min-colors 16))
+ :foreground "lightgray" :background "blue")
+ (t
+ :foreground "white" :background "blue"))
+ "Face for displaying disabled items in TTY menus."
+ :group 'basic-faces)
+
+ (defface tty-menu-selected-face
+ '((t :background "red"))
+ "Face for displaying the currently selected item in TTY menus."
+ :group 'basic-faces)
+
+ (defgroup paren-showing-faces nil
+ "Faces used to highlight paren matches."
+ :group 'paren-showing
+ :group 'faces
+ :version "22.1")
+
+ (defface show-paren-match
+ '((((class color) (background light))
+ :background "turquoise") ; looks OK on tty (becomes cyan)
+ (((class color) (background dark))
+ :background "steelblue3") ; looks OK on tty (becomes blue)
+ (((background dark))
+ :background "grey50")
+ (t
+ :background "gray"))
+ "Face used for a matching paren."
+ :group 'paren-showing-faces)
+
+ (defface show-paren-mismatch
+ '((((class color)) (:foreground "white" :background "purple"))
+ (t (:inverse-video t)))
+ "Face used for a mismatching paren."
+ :group 'paren-showing-faces)
+
+ \f
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;; Manipulating font names.
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ ;; This is here for compatibility with Emacs 20.2. For example,
+ ;; international/fontset.el uses x-resolve-font-name. The following
+ ;; functions are not used in the face implementation itself.
+
+ (defvar x-font-regexp nil)
+ (defvar x-font-regexp-head nil)
+ (defvar x-font-regexp-weight nil)
+ (defvar x-font-regexp-slant nil)
+
+ (defconst x-font-regexp-weight-subnum 1)
+ (defconst x-font-regexp-slant-subnum 2)
+ (defconst x-font-regexp-swidth-subnum 3)
+ (defconst x-font-regexp-adstyle-subnum 4)
+
+ ;;; Regexps matching font names in "Host Portable Character Representation."
+ ;;;
+ (let ((- "[-?]")
+ (foundry "[^-]+")
+ (family "[^-]+")
+ (weight "\\(bold\\|demibold\\|medium\\)") ; 1
+ ; (weight\? "\\(\\*\\|bold\\|demibold\\|medium\\|\\)") ; 1
+ (weight\? "\\([^-]*\\)") ; 1
+ (slant "\\([ior]\\)") ; 2
+ ; (slant\? "\\([ior?*]?\\)") ; 2
+ (slant\? "\\([^-]?\\)") ; 2
+ ; (swidth "\\(\\*\\|normal\\|semicondensed\\|\\)") ; 3
+ (swidth "\\([^-]*\\)") ; 3
+ ; (adstyle "\\(\\*\\|sans\\|\\)") ; 4
+ (adstyle "\\([^-]*\\)") ; 4
+ (pixelsize "[0-9]+")
+ (pointsize "[0-9][0-9]+")
+ (resx "[0-9][0-9]+")
+ (resy "[0-9][0-9]+")
+ (spacing "[cmp?*]")
+ (avgwidth "[0-9]+")
+ (registry "[^-]+")
+ (encoding "[^-]+")
+ )
+ (setq x-font-regexp
+ (purecopy (concat "\\`\\*?[-?*]"
+ foundry - family - weight\? - slant\? - swidth - adstyle -
+ pixelsize - pointsize - resx - resy - spacing - avgwidth -
+ registry - encoding "\\*?\\'"
+ )))
+ (setq x-font-regexp-head
+ (purecopy (concat "\\`[-?*]" foundry - family - weight\? - slant\?
+ "\\([-*?]\\|\\'\\)")))
+ (setq x-font-regexp-slant (purecopy (concat - slant -)))
+ (setq x-font-regexp-weight (purecopy (concat - weight -)))
+ nil)
+
+
+ (defun x-resolve-font-name (pattern &optional face frame)
+ "Return a font name matching PATTERN.
+ All wildcards in PATTERN are instantiated.
+ If PATTERN is nil, return the name of the frame's base font, which never
+ contains wildcards.
+ Given optional arguments FACE and FRAME, return a font which is
+ also the same size as FACE on FRAME, or fail."
+ (and (eq frame t)
+ (setq frame nil))
+ (if pattern
+ ;; Note that x-list-fonts has code to handle a face with nil as its font.
+ (let ((fonts (x-list-fonts pattern face frame 1)))
+ (or fonts
+ (if face
+ (if (string-match-p "\\*" pattern)
+ (if (null (face-font face))
+ (error "No matching fonts are the same height as the frame default font")
+ (error "No matching fonts are the same height as face `%s'" face))
+ (if (null (face-font face))
+ (error "Height of font `%s' doesn't match the frame default font"
+ pattern)
+ (error "Height of font `%s' doesn't match face `%s'"
+ pattern face)))
+ (error "No fonts match `%s'" pattern)))
+ (car fonts))
+ (cdr (assq 'font (frame-parameters (selected-frame))))))
+
+ (defcustom font-list-limit 100
+ "This variable is obsolete and has no effect."
+ :type 'integer
+ :group 'display)
+ (make-obsolete-variable 'font-list-limit nil "24.3")
+
+ (provide 'faces)
+
+ ;;; faces.el ends here
--- /dev/null
+ ;;; lisp.el --- Lisp editing commands for Emacs -*- lexical-binding:t -*-
+
+ ;; Copyright (C) 1985-1986, 1994, 2000-2015 Free Software Foundation,
+ ;; Inc.
+
+ ;; Maintainer: emacs-devel@gnu.org
+ ;; Keywords: lisp, languages
+ ;; Package: emacs
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+
+ ;; Lisp editing commands to go with Lisp major mode. More-or-less
+ ;; applicable in other modes too.
+
+ ;;; Code:
+
+ ;; Note that this variable is used by non-lisp modes too.
+ (defcustom defun-prompt-regexp nil
+ "If non-nil, a regexp to ignore before a defun.
+ This is only necessary if the opening paren or brace is not in column 0.
+ See function `beginning-of-defun'."
+ :type '(choice (const nil)
+ regexp)
+ :group 'lisp)
+ (make-variable-buffer-local 'defun-prompt-regexp)
+
+ (defcustom parens-require-spaces t
+ "If non-nil, add whitespace as needed when inserting parentheses.
+ This affects `insert-parentheses' and `insert-pair'."
+ :type 'boolean
+ :group 'lisp)
+
+ (defvar forward-sexp-function nil
+ ;; FIXME:
+ ;; - for some uses, we may want a "sexp-only" version, which only
+ ;; jumps over a well-formed sexp, rather than some dwimish thing
+ ;; like jumping from an "else" back up to its "if".
+ ;; - for up-list, we could use the "sexp-only" behavior as well
+ ;; to treat the dwimish halfsexp as a form of "up-list" step.
+ "If non-nil, `forward-sexp' delegates to this function.
+ Should take the same arguments and behave similarly to `forward-sexp'.")
+
+ (defun forward-sexp (&optional arg)
+ "Move forward across one balanced expression (sexp).
+ With ARG, do it that many times. Negative arg -N means
+ move backward across N balanced expressions.
+ This command assumes point is not in a string or comment.
+ Calls `forward-sexp-function' to do the work, if that is non-nil."
+ (interactive "^p")
+ (or arg (setq arg 1))
+ (if forward-sexp-function
+ (funcall forward-sexp-function arg)
+ (goto-char (or (scan-sexps (point) arg) (buffer-end arg)))
+ (if (< arg 0) (backward-prefix-chars))))
+
+ (defun backward-sexp (&optional arg)
+ "Move backward across one balanced expression (sexp).
+ With ARG, do it that many times. Negative arg -N means
+ move forward across N balanced expressions.
+ This command assumes point is not in a string or comment.
+ Uses `forward-sexp' to do the work."
+ (interactive "^p")
+ (or arg (setq arg 1))
+ (forward-sexp (- arg)))
+
+ (defun mark-sexp (&optional arg allow-extend)
+ "Set mark ARG sexps from point.
+ The place mark goes is the same place \\[forward-sexp] would
+ move to with the same argument.
+ Interactively, if this command is repeated
+ or (in Transient Mark mode) if the mark is active,
+ it marks the next ARG sexps after the ones already marked.
+ This command assumes point is not in a string or comment."
+ (interactive "P\np")
+ (cond ((and allow-extend
+ (or (and (eq last-command this-command) (mark t))
+ (and transient-mark-mode mark-active)))
+ (setq arg (if arg (prefix-numeric-value arg)
+ (if (< (mark) (point)) -1 1)))
+ (set-mark
+ (save-excursion
+ (goto-char (mark))
+ (forward-sexp arg)
+ (point))))
+ (t
+ (push-mark
+ (save-excursion
+ (forward-sexp (prefix-numeric-value arg))
+ (point))
+ nil t))))
+
+ (defun forward-list (&optional arg)
+ "Move forward across one balanced group of parentheses.
+ This command will also work on other parentheses-like expressions
+ defined by the current language mode.
+ With ARG, do it that many times.
+ Negative arg -N means move backward across N groups of parentheses.
+ This command assumes point is not in a string or comment."
+ (interactive "^p")
+ (or arg (setq arg 1))
+ (goto-char (or (scan-lists (point) arg 0) (buffer-end arg))))
+
+ (defun backward-list (&optional arg)
+ "Move backward across one balanced group of parentheses.
+ This command will also work on other parentheses-like expressions
+ defined by the current language mode.
+ With ARG, do it that many times.
+ Negative arg -N means move forward across N groups of parentheses.
+ This command assumes point is not in a string or comment."
+ (interactive "^p")
+ (or arg (setq arg 1))
+ (forward-list (- arg)))
+
+ (defun down-list (&optional arg)
+ "Move forward down one level of parentheses.
+ This command will also work on other parentheses-like expressions
+ defined by the current language mode.
+ With ARG, do this that many times.
+ A negative argument means move backward but still go down a level.
+ This command assumes point is not in a string or comment."
+ (interactive "^p")
+ (or arg (setq arg 1))
+ (let ((inc (if (> arg 0) 1 -1)))
+ (while (/= arg 0)
+ (goto-char (or (scan-lists (point) inc -1) (buffer-end arg)))
+ (setq arg (- arg inc)))))
+
+ (defun backward-up-list (&optional arg)
+ "Move backward out of one level of parentheses.
+ This command will also work on other parentheses-like expressions
+ defined by the current language mode.
+ With ARG, do this that many times.
+ A negative argument means move forward but still to a less deep spot.
+ This command assumes point is not in a string or comment."
+ (interactive "^p")
+ (up-list (- (or arg 1))))
+
+ (defun up-list (&optional arg)
+ "Move forward out of one level of parentheses.
+ This command will also work on other parentheses-like expressions
+ defined by the current language mode.
+ With ARG, do this that many times.
+ A negative argument means move backward but still to a less deep spot.
+ This command assumes point is not in a string or comment."
+ (interactive "^p")
+ (or arg (setq arg 1))
+ (let ((inc (if (> arg 0) 1 -1))
+ pos)
+ (while (/= arg 0)
+ (if (null forward-sexp-function)
+ (goto-char (or (scan-lists (point) inc 1) (buffer-end arg)))
+ (condition-case err
+ (while (progn (setq pos (point))
+ (forward-sexp inc)
+ (/= (point) pos)))
+ (scan-error (goto-char (nth (if (> arg 0) 3 2) err))))
+ (if (= (point) pos)
+ (signal 'scan-error
+ (list "Unbalanced parentheses" (point) (point)))))
+ (setq arg (- arg inc)))))
+
+ (defun kill-sexp (&optional arg)
+ "Kill the sexp (balanced expression) following point.
+ With ARG, kill that many sexps after point.
+ Negative arg -N means kill N sexps before point.
+ This command assumes point is not in a string or comment."
+ (interactive "p")
+ (let ((opoint (point)))
+ (forward-sexp (or arg 1))
+ (kill-region opoint (point))))
+
+ (defun backward-kill-sexp (&optional arg)
+ "Kill the sexp (balanced expression) preceding point.
+ With ARG, kill that many sexps before point.
+ Negative arg -N means kill N sexps after point.
+ This command assumes point is not in a string or comment."
+ (interactive "p")
+ (kill-sexp (- (or arg 1))))
+
+ ;; After Zmacs:
+ (defun kill-backward-up-list (&optional arg)
+ "Kill the form containing the current sexp, leaving the sexp itself.
+ A prefix argument ARG causes the relevant number of surrounding
+ forms to be removed.
+ This command assumes point is not in a string or comment."
+ (interactive "*p")
+ (let ((current-sexp (thing-at-point 'sexp)))
+ (if current-sexp
+ (save-excursion
+ (backward-up-list arg)
+ (kill-sexp)
+ (insert current-sexp))
+ (error "Not at a sexp"))))
+ \f
+ (defvar beginning-of-defun-function nil
+ "If non-nil, function for `beginning-of-defun-raw' to call.
+ This is used to find the beginning of the defun instead of using the
+ normal recipe (see `beginning-of-defun'). Major modes can define this
+ if defining `defun-prompt-regexp' is not sufficient to handle the mode's
+ needs.
+
+ The function takes the same argument as `beginning-of-defun' and should
+ behave similarly, returning non-nil if it found the beginning of a defun.
+ Ideally it should move to a point right before an open-paren which encloses
+ the body of the defun.")
+
+ (defun beginning-of-defun (&optional arg)
+ "Move backward to the beginning of a defun.
+ With ARG, do it that many times. Negative ARG means move forward
+ to the ARGth following beginning of defun.
+
+ If search is successful, return t; point ends up at the beginning
+ of the line where the search succeeded. Otherwise, return nil.
+
+ When `open-paren-in-column-0-is-defun-start' is non-nil, a defun
+ is assumed to start where there is a char with open-parenthesis
+ syntax at the beginning of a line. If `defun-prompt-regexp' is
+ non-nil, then a string which matches that regexp may also precede
+ the open-parenthesis. If `defun-prompt-regexp' and
+ `open-paren-in-column-0-is-defun-start' are both nil, this
+ function instead finds an open-paren at the outermost level.
+
+ If the variable `beginning-of-defun-function' is non-nil, its
+ value is called as a function, with argument ARG, to find the
+ defun's beginning.
+
+ Regardless of the values of `defun-prompt-regexp' and
+ `beginning-of-defun-function', point always moves to the
+ beginning of the line whenever the search is successful."
+ (interactive "^p")
+ (or (not (eq this-command 'beginning-of-defun))
+ (eq last-command 'beginning-of-defun)
+ (and transient-mark-mode mark-active)
+ (push-mark))
+ (and (beginning-of-defun-raw arg)
+ (progn (beginning-of-line) t)))
+
+ (defun beginning-of-defun-raw (&optional arg)
+ "Move point to the character that starts a defun.
+ This is identical to function `beginning-of-defun', except that point
+ does not move to the beginning of the line when `defun-prompt-regexp'
+ is non-nil.
+
+ If variable `beginning-of-defun-function' is non-nil, its value
+ is called as a function to find the defun's beginning."
+ (interactive "^p") ; change this to "P", maybe, if we ever come to pass ARG
+ ; to beginning-of-defun-function.
+ (unless arg (setq arg 1))
+ (cond
+ (beginning-of-defun-function
+ (condition-case nil
+ (funcall beginning-of-defun-function arg)
+ ;; We used to define beginning-of-defun-function as taking no argument
+ ;; but that makes it impossible to implement correct forward motion:
+ ;; we used to use end-of-defun for that, but it's not supposed to do
+ ;; the same thing (it moves to the end of a defun not to the beginning
+ ;; of the next).
+ ;; In case the beginning-of-defun-function uses the old calling
+ ;; convention, fallback on the old implementation.
+ (wrong-number-of-arguments
+ (if (> arg 0)
+ (dotimes (_ arg)
+ (funcall beginning-of-defun-function))
+ (dotimes (_ (- arg))
+ (funcall end-of-defun-function))))))
+
+ ((or defun-prompt-regexp open-paren-in-column-0-is-defun-start)
+ (and (< arg 0) (not (eobp)) (forward-char 1))
+ (and (re-search-backward (if defun-prompt-regexp
+ (concat (if open-paren-in-column-0-is-defun-start
+ "^\\s(\\|" "")
+ "\\(?:" defun-prompt-regexp "\\)\\s(")
+ "^\\s(")
+ nil 'move arg)
+ (progn (goto-char (1- (match-end 0)))
+ t)))
+
+ ;; If open-paren-in-column-0-is-defun-start and defun-prompt-regexp
+ ;; are both nil, column 0 has no significance - so scan forward
+ ;; from BOB to see how nested point is, then carry on from there.
+ ;;
+ ;; It is generally not a good idea to land up here, because the
+ ;; call to scan-lists below can be extremely slow. This is because
+ ;; back_comment in syntax.c may have to scan from bob to find the
+ ;; beginning of each comment. Fixing this is not trivial -- cyd.
+
+ ((eq arg 0))
+ (t
+ (let ((floor (point-min))
+ (ceiling (point-max))
+ (arg-+ve (> arg 0)))
+ (save-restriction
+ (widen)
+ (let ((ppss (let (syntax-begin-function
+ font-lock-beginning-of-syntax-function)
+ (syntax-ppss)))
+ ;; position of least enclosing paren, or nil.
+ encl-pos)
+ ;; Back out of any comment/string, so that encl-pos will always
+ ;; become nil if we're at top-level.
+ (when (nth 8 ppss)
+ (goto-char (nth 8 ppss))
+ (setq ppss (syntax-ppss))) ; should be fast, due to cache.
+ (setq encl-pos (syntax-ppss-toplevel-pos ppss))
+ (if encl-pos (goto-char encl-pos))
+
+ (and encl-pos arg-+ve (setq arg (1- arg)))
+ (and (not encl-pos) (not arg-+ve) (not (looking-at "\\s("))
+ (setq arg (1+ arg)))
+
+ (condition-case nil ; to catch crazy parens.
+ (progn
+ (goto-char (scan-lists (point) (- arg) 0))
+ (if arg-+ve
+ (if (>= (point) floor)
+ t
+ (goto-char floor)
+ nil)
+ ;; forward to next (, or trigger the c-c
+ (goto-char (1- (scan-lists (point) 1 -1)))
+ (if (<= (point) ceiling)
+ t
+ (goto-char ceiling)
+ nil)))
+ (error
+ (goto-char (if arg-+ve floor ceiling))
+ nil))))))))
+
+ (defvar end-of-defun-function
+ (lambda () (forward-sexp 1))
+ "Function for `end-of-defun' to call.
+ This is used to find the end of the defun at point.
+ It is called with no argument, right after calling `beginning-of-defun-raw'.
+ So the function can assume that point is at the beginning of the defun body.
+ It should move point to the first position after the defun.")
+
+ (defun buffer-end (arg)
+ "Return the \"far end\" position of the buffer, in direction ARG.
+ If ARG is positive, that's the end of the buffer.
+ Otherwise, that's the beginning of the buffer."
+ (if (> arg 0) (point-max) (point-min)))
+
+ (defun end-of-defun (&optional arg)
+ "Move forward to next end of defun.
+ With argument, do it that many times.
+ Negative argument -N means move back to Nth preceding end of defun.
+
+ An end of a defun occurs right after the close-parenthesis that
+ matches the open-parenthesis that starts a defun; see function
+ `beginning-of-defun'.
+
+ If variable `end-of-defun-function' is non-nil, its value
+ is called as a function to find the defun's end."
+ (interactive "^p")
+ (or (not (eq this-command 'end-of-defun))
+ (eq last-command 'end-of-defun)
+ (and transient-mark-mode mark-active)
+ (push-mark))
+ (if (or (null arg) (= arg 0)) (setq arg 1))
+ (let ((pos (point))
+ (beg (progn (end-of-line 1) (beginning-of-defun-raw 1) (point)))
+ (skip (lambda ()
+ ;; When comparing point against pos, we want to consider that if
+ ;; point was right after the end of the function, it's still
+ ;; considered as "in that function".
+ ;; E.g. `eval-defun' from right after the last close-paren.
+ (unless (bolp)
+ (skip-chars-forward " \t")
+ (if (looking-at "\\s<\\|\n")
+ (forward-line 1))))))
+ (funcall end-of-defun-function)
+ (funcall skip)
+ (cond
+ ((> arg 0)
+ ;; Moving forward.
+ (if (> (point) pos)
+ ;; We already moved forward by one because we started from
+ ;; within a function.
+ (setq arg (1- arg))
+ ;; We started from after the end of the previous function.
+ (goto-char pos))
+ (unless (zerop arg)
+ (beginning-of-defun-raw (- arg))
+ (funcall end-of-defun-function)))
+ ((< arg 0)
+ ;; Moving backward.
+ (if (< (point) pos)
+ ;; We already moved backward because we started from between
+ ;; two functions.
+ (setq arg (1+ arg))
+ ;; We started from inside a function.
+ (goto-char beg))
+ (unless (zerop arg)
+ (beginning-of-defun-raw (- arg))
+ (setq beg (point))
+ (funcall end-of-defun-function))))
+ (funcall skip)
+ (while (and (< arg 0) (>= (point) pos))
+ ;; We intended to move backward, but this ended up not doing so:
+ ;; Try harder!
+ (goto-char beg)
+ (beginning-of-defun-raw (- arg))
+ (if (>= (point) beg)
+ (setq arg 0)
+ (setq beg (point))
+ (funcall end-of-defun-function)
+ (funcall skip)))))
+
+ (defun mark-defun (&optional allow-extend)
+ "Put mark at end of this defun, point at beginning.
+ The defun marked is the one that contains point or follows point.
+
+ Interactively, if this command is repeated
+ or (in Transient Mark mode) if the mark is active,
+ it marks the next defun after the ones already marked."
+ (interactive "p")
+ (cond ((and allow-extend
+ (or (and (eq last-command this-command) (mark t))
+ (and transient-mark-mode mark-active)))
+ (set-mark
+ (save-excursion
+ (goto-char (mark))
+ (end-of-defun)
+ (point))))
+ (t
+ (let ((opoint (point))
+ beg end)
+ (push-mark opoint)
+ ;; Try first in this order for the sake of languages with nested
+ ;; functions where several can end at the same place as with
+ ;; the offside rule, e.g. Python.
+ (beginning-of-defun)
+ (setq beg (point))
+ (end-of-defun)
+ (setq end (point))
+ (while (looking-at "^\n")
+ (forward-line 1))
+ (if (> (point) opoint)
+ (progn
+ ;; We got the right defun.
+ (push-mark beg nil t)
+ (goto-char end)
+ (exchange-point-and-mark))
+ ;; beginning-of-defun moved back one defun
+ ;; so we got the wrong one.
+ (goto-char opoint)
+ (end-of-defun)
+ (push-mark (point) nil t)
+ (beginning-of-defun))
+ (re-search-backward "^\n" (- (point) 1) t)))))
+
+ (defun narrow-to-defun (&optional _arg)
+ "Make text outside current defun invisible.
+ The defun visible is the one that contains point or follows point.
+ Optional ARG is ignored."
+ (interactive)
+ (save-excursion
+ (widen)
+ (let ((opoint (point))
+ beg end)
+ ;; Try first in this order for the sake of languages with nested
+ ;; functions where several can end at the same place as with
+ ;; the offside rule, e.g. Python.
+
+ ;; Finding the start of the function is a bit problematic since
+ ;; `beginning-of-defun' when we are on the first character of
+ ;; the function might go to the previous function.
+ ;;
+ ;; Therefore we first move one character forward and then call
+ ;; `beginning-of-defun'. However now we must check that we did
+ ;; not move into the next function.
+ (let ((here (point)))
+ (unless (eolp)
+ (forward-char))
+ (beginning-of-defun)
+ (when (< (point) here)
+ (goto-char here)
+ (beginning-of-defun)))
+ (setq beg (point))
+ (end-of-defun)
+ (setq end (point))
+ (while (looking-at "^\n")
+ (forward-line 1))
+ (unless (> (point) opoint)
+ ;; beginning-of-defun moved back one defun
+ ;; so we got the wrong one.
+ (goto-char opoint)
+ (end-of-defun)
+ (setq end (point))
+ (beginning-of-defun)
+ (setq beg (point)))
+ (goto-char end)
+ (re-search-backward "^\n" (- (point) 1) t)
+ (narrow-to-region beg end))))
+
+ (defvar insert-pair-alist
+ '((?\( ?\)) (?\[ ?\]) (?\{ ?\}) (?\< ?\>) (?\" ?\") (?\' ?\') (?\` ?\'))
+ "Alist of paired characters inserted by `insert-pair'.
+ Each element looks like (OPEN-CHAR CLOSE-CHAR) or (COMMAND-CHAR
+ OPEN-CHAR CLOSE-CHAR). The characters OPEN-CHAR and CLOSE-CHAR
+ of the pair whose key is equal to the last input character with
+ or without modifiers, are inserted by `insert-pair'.")
+
+ (defun insert-pair (&optional arg open close)
+ "Enclose following ARG sexps in a pair of OPEN and CLOSE characters.
+ Leave point after the first character.
+ A negative ARG encloses the preceding ARG sexps instead.
+ No argument is equivalent to zero: just insert characters
+ and leave point between.
+ If `parens-require-spaces' is non-nil, this command also inserts a space
+ before and after, depending on the surrounding characters.
+ If region is active, insert enclosing characters at region boundaries.
+
+ If arguments OPEN and CLOSE are nil, the character pair is found
+ from the variable `insert-pair-alist' according to the last input
+ character with or without modifiers. If no character pair is
+ found in the variable `insert-pair-alist', then the last input
+ character is inserted ARG times.
+
+ This command assumes point is not in a string or comment."
+ (interactive "P")
+ (if (not (and open close))
+ (let ((pair (or (assq last-command-event insert-pair-alist)
+ (assq (event-basic-type last-command-event)
+ insert-pair-alist))))
+ (if pair
+ (if (nth 2 pair)
+ (setq open (nth 1 pair) close (nth 2 pair))
+ (setq open (nth 0 pair) close (nth 1 pair))))))
+ (if (and open close)
+ (if (and transient-mark-mode mark-active)
+ (progn
+ (save-excursion (goto-char (region-end)) (insert close))
+ (save-excursion (goto-char (region-beginning)) (insert open)))
+ (if arg (setq arg (prefix-numeric-value arg))
+ (setq arg 0))
+ (cond ((> arg 0) (skip-chars-forward " \t"))
+ ((< arg 0) (forward-sexp arg) (setq arg (- arg))))
+ (and parens-require-spaces
+ (not (bobp))
+ (memq (char-syntax (preceding-char)) (list ?w ?_ (char-syntax close)))
+ (insert " "))
+ (insert open)
+ (save-excursion
+ (or (eq arg 0) (forward-sexp arg))
+ (insert close)
+ (and parens-require-spaces
+ (not (eobp))
+ (memq (char-syntax (following-char)) (list ?w ?_ (char-syntax open)))
+ (insert " "))))
+ (insert-char (event-basic-type last-command-event)
+ (prefix-numeric-value arg))))
+
+ (defun insert-parentheses (&optional arg)
+ "Enclose following ARG sexps in parentheses.
+ Leave point after open-paren.
+ A negative ARG encloses the preceding ARG sexps instead.
+ No argument is equivalent to zero: just insert `()' and leave point between.
+ If `parens-require-spaces' is non-nil, this command also inserts a space
+ before and after, depending on the surrounding characters.
+ If region is active, insert enclosing characters at region boundaries.
+
+ This command assumes point is not in a string or comment."
+ (interactive "P")
+ (insert-pair arg ?\( ?\)))
+
+ (defun delete-pair ()
+ "Delete a pair of characters enclosing the sexp that follows point."
+ (interactive)
+ (save-excursion (forward-sexp 1) (delete-char -1))
+ (delete-char 1))
+
+ (defun raise-sexp (&optional arg)
+ "Raise ARG sexps higher up the tree."
+ (interactive "p")
+ (let ((s (if (and transient-mark-mode mark-active)
+ (buffer-substring (region-beginning) (region-end))
+ (buffer-substring
+ (point)
+ (save-excursion (forward-sexp arg) (point))))))
+ (backward-up-list 1)
+ (delete-region (point) (save-excursion (forward-sexp 1) (point)))
+ (save-excursion (insert s))))
+
+ (defun move-past-close-and-reindent ()
+ "Move past next `)', delete indentation before it, then indent after it."
+ (interactive)
+ (up-list 1)
+ (forward-char -1)
+ (while (save-excursion ; this is my contribution
+ (let ((before-paren (point)))
+ (back-to-indentation)
+ (and (= (point) before-paren)
+ (progn
+ ;; Move to end of previous line.
+ (beginning-of-line)
+ (forward-char -1)
+ ;; Verify it doesn't end within a string or comment.
+ (let ((end (point))
+ state)
+ (beginning-of-line)
+ ;; Get state at start of line.
+ (setq state (list 0 nil nil
+ (null (calculate-lisp-indent))
+ nil nil nil nil
+ nil))
+ ;; Parse state across the line to get state at end.
+ (setq state (parse-partial-sexp (point) end nil nil
+ state))
+ ;; Check not in string or comment.
+ (and (not (elt state 3)) (not (elt state 4))))))))
+ (delete-indentation))
+ (forward-char 1)
+ (newline-and-indent))
+
+ (defun check-parens () ; lame name?
+ "Check for unbalanced parentheses in the current buffer.
+ More accurately, check the narrowed part of the buffer for unbalanced
+ expressions (\"sexps\") in general. This is done according to the
+ current syntax table and will find unbalanced brackets or quotes as
+ appropriate. (See Info node `(emacs)Parentheses'.) If imbalance is
+ found, an error is signaled and point is left at the first unbalanced
+ character."
+ (interactive)
+ (condition-case data
+ ;; Buffer can't have more than (point-max) sexps.
+ (scan-sexps (point-min) (point-max))
+ (scan-error (goto-char (nth 2 data))
+ ;; Could print (nth 1 data), which is either
+ ;; "Containing expression ends prematurely" or
+ ;; "Unbalanced parentheses", but those may not be so
+ ;; accurate/helpful, e.g. quotes may actually be
+ ;; mismatched.
+ (user-error "Unmatched bracket or quote"))))
+ \f
+ (defun field-complete (table &optional predicate)
+ (declare (obsolete completion-in-region "24.4"))
+ (let ((minibuffer-completion-table table)
+ (minibuffer-completion-predicate predicate)
+ ;; This made sense for lisp-complete-symbol, but for
+ ;; field-complete, this is out of place. --Stef
+ ;; (completion-annotate-function
+ ;; (unless (eq predicate 'fboundp)
+ ;; (lambda (str)
+ ;; (if (fboundp (intern-soft str)) " <f>"))))
+ )
+ (call-interactively 'minibuffer-complete)))
+
+ (defun lisp-complete-symbol (&optional predicate)
+ "Perform completion on Lisp symbol preceding point.
+ Compare that symbol against the known Lisp symbols.
+ If no characters can be completed, display a list of possible completions.
+ Repeating the command at that point scrolls the list.
+
+ When called from a program, optional arg PREDICATE is a predicate
+ determining which symbols are considered, e.g. `commandp'.
+ If PREDICATE is nil, the context determines which symbols are
+ considered. If the symbol starts just after an open-parenthesis, only
+ symbols with function definitions are considered. Otherwise, all
+ symbols with function definitions, values or properties are
+ considered."
+ (declare (obsolete completion-at-point "24.4"))
+ (interactive)
+ (let* ((data (lisp-completion-at-point predicate))
+ (plist (nthcdr 3 data)))
+ (if (null data)
+ (minibuffer-message "Nothing to complete")
+ (let ((completion-extra-properties plist))
+ (completion-in-region (nth 0 data) (nth 1 data) (nth 2 data)
+ (plist-get plist :predicate))))))
+
+ (defun lisp--local-variables-1 (vars sexp)
+ "Return the vars locally bound around the witness, or nil if not found."
+ (let (res)
+ (while
+ (unless
+ (setq res
+ (pcase sexp
+ (`(,(or `let `let*) ,bindings)
+ (let ((vars vars))
+ (when (eq 'let* (car sexp))
+ (dolist (binding (cdr (reverse bindings)))
+ (push (or (car-safe binding) binding) vars)))
+ (lisp--local-variables-1
+ vars (car (cdr-safe (car (last bindings)))))))
+ (`(,(or `let `let*) ,bindings . ,body)
+ (let ((vars vars))
+ (dolist (binding bindings)
+ (push (or (car-safe binding) binding) vars))
+ (lisp--local-variables-1 vars (car (last body)))))
+ (`(lambda ,_) (setq sexp nil))
+ (`(lambda ,args . ,body)
+ (lisp--local-variables-1
+ (append args vars) (car (last body))))
+ (`(condition-case ,_ ,e) (lisp--local-variables-1 vars e))
+ (`(condition-case ,v ,_ . ,catches)
+ (lisp--local-variables-1
+ (cons v vars) (cdr (car (last catches)))))
+ (`(quote . ,_) (setq sexp nil))
+ (`(,_ . ,_)
+ (lisp--local-variables-1 vars (car (last sexp))))
+ (`lisp--witness--lisp (or vars '(nil)))
+ (_ nil)))
+ (setq sexp (ignore-errors (butlast sexp)))))
+ res))
+
+ (defun lisp--local-variables ()
+ "Return a list of locally let-bound variables at point."
+ (save-excursion
+ (skip-syntax-backward "w_")
+ (let* ((ppss (syntax-ppss))
+ (txt (buffer-substring-no-properties (or (car (nth 9 ppss)) (point))
+ (or (nth 8 ppss) (point))))
+ (closer ()))
+ (dolist (p (nth 9 ppss))
+ (push (cdr (syntax-after p)) closer))
+ (setq closer (apply #'string closer))
+ (let* ((sexp (condition-case nil
+ (car (read-from-string
+ (concat txt "lisp--witness--lisp" closer)))
+ (end-of-file nil)))
+ (macroexpand-advice (lambda (expander form &rest args)
+ (condition-case nil
+ (apply expander form args)
+ (error form))))
+ (sexp
+ (unwind-protect
+ (progn
+ (advice-add 'macroexpand :around macroexpand-advice)
+ (macroexpand-all sexp))
+ (advice-remove 'macroexpand macroexpand-advice)))
+ (vars (lisp--local-variables-1 nil sexp)))
+ (delq nil
+ (mapcar (lambda (var)
+ (and (symbolp var)
+ (not (string-match (symbol-name var) "\\`[&_]"))
+ ;; Eliminate uninterned vars.
+ (intern-soft var)
+ var))
+ vars))))))
+
+ (defvar lisp--local-variables-completion-table
+ ;; Use `defvar' rather than `defconst' since defconst would purecopy this
+ ;; value, which would doubly fail: it would fail because purecopy can't
+ ;; handle the recursive bytecode object, and it would fail because it would
+ ;; move `lastpos' and `lastvars' to pure space where they'd be immutable!
+ (let ((lastpos nil) (lastvars nil))
+ (letrec ((hookfun (lambda ()
+ (setq lastpos nil)
+ (remove-hook 'post-command-hook hookfun))))
+ (completion-table-dynamic
+ (lambda (_string)
+ (save-excursion
+ (skip-syntax-backward "_w")
+ (let ((newpos (cons (point) (current-buffer))))
+ (unless (equal lastpos newpos)
+ (add-hook 'post-command-hook hookfun)
+ (setq lastpos newpos)
+ (setq lastvars
+ (mapcar #'symbol-name (lisp--local-variables))))))
+ lastvars)))))
+
+ ;; FIXME: Support for Company brings in features which straddle eldoc.
+ ;; We should consolidate this, so that major modes can provide all that
+ ;; data all at once:
+ ;; - a function to extract "the reference at point" (may be more complex
+ ;; than a mere string, to distinguish various namespaces).
+ ;; - a function to jump to such a reference.
+ ;; - a function to show the signature/interface of such a reference.
+ ;; - a function to build a help-buffer about that reference.
+ ;; FIXME: Those functions should also be used by the normal completion code in
+ ;; the *Completions* buffer.
+
+ (defun lisp--company-doc-buffer (str)
+ (let ((symbol (intern-soft str)))
+ ;; FIXME: we really don't want to "display-buffer and then undo it".
+ (save-window-excursion
+ ;; Make sure we don't display it in another frame, otherwise
+ ;; save-window-excursion won't be able to undo it.
+ (let ((display-buffer-overriding-action
+ '(nil . ((inhibit-switch-frame . t)))))
+ (ignore-errors
+ (cond
+ ((fboundp symbol) (describe-function symbol))
+ ((boundp symbol) (describe-variable symbol))
+ ((featurep symbol) (describe-package symbol))
+ ((facep symbol) (describe-face symbol))
+ (t (signal 'user-error nil)))
+ (help-buffer))))))
+
+ (defun lisp--company-doc-string (str)
+ (let* ((symbol (intern-soft str))
+ (doc (if (fboundp symbol)
+ (documentation symbol t)
+ (documentation-property symbol 'variable-documentation t))))
+ (and (stringp doc)
+ (string-match ".*$" doc)
+ (match-string 0 doc))))
+
+ (declare-function find-library-name "find-func" (library))
+
+ (defun lisp--company-location (str)
+ (let ((sym (intern-soft str)))
+ (cond
+ ((fboundp sym) (find-definition-noselect sym nil))
+ ((boundp sym) (find-definition-noselect sym 'defvar))
+ ((featurep sym)
+ (require 'find-func)
+ (cons (find-file-noselect (find-library-name
+ (symbol-name sym)))
+ 0))
+ ((facep sym) (find-definition-noselect sym 'defface)))))
+
+ (defun lisp-completion-at-point (&optional _predicate)
+ "Function used for `completion-at-point-functions' in `emacs-lisp-mode'."
+ (with-syntax-table emacs-lisp-mode-syntax-table
+ (let* ((pos (point))
+ (beg (condition-case nil
+ (save-excursion
+ (backward-sexp 1)
+ (skip-syntax-forward "'")
+ (point))
+ (scan-error pos)))
+ (end
+ (unless (or (eq beg (point-max))
+ (member (char-syntax (char-after beg))
+ '(?\s ?\" ?\( ?\))))
+ (condition-case nil
+ (save-excursion
+ (goto-char beg)
+ (forward-sexp 1)
+ (when (>= (point) pos)
+ (point)))
+ (scan-error pos))))
+ (funpos (eq (char-before beg) ?\()) ;t if in function position.
+ (table-etc
+ (if (not funpos)
+ ;; FIXME: We could look at the first element of the list and
+ ;; use it to provide a more specific completion table in some
+ ;; cases. E.g. filter out keywords that are not understood by
+ ;; the macro/function being called.
+ (list nil (completion-table-merge
+ lisp--local-variables-completion-table
+ (apply-partially #'completion-table-with-predicate
+ obarray
+ ;; Don't include all symbols
+ ;; (bug#16646).
+ (lambda (sym)
+ (or (boundp sym)
+ (fboundp sym)
+ (symbol-plist sym)))
+ 'strict))
+ :annotation-function
+ (lambda (str) (if (fboundp (intern-soft str)) " <f>"))
+ :company-doc-buffer #'lisp--company-doc-buffer
+ :company-docsig #'lisp--company-doc-string
+ :company-location #'lisp--company-location)
+ ;; Looks like a funcall position. Let's double check.
+ (save-excursion
+ (goto-char (1- beg))
+ (let ((parent
+ (condition-case nil
+ (progn (up-list -1) (forward-char 1)
+ (let ((c (char-after)))
+ (if (eq c ?\() ?\(
+ (if (memq (char-syntax c) '(?w ?_))
+ (read (current-buffer))))))
+ (error nil))))
+ (pcase parent
+ ;; FIXME: Rather than hardcode special cases here,
+ ;; we should use something like a symbol-property.
+ (`declare
+ (list t (mapcar (lambda (x) (symbol-name (car x)))
+ (delete-dups
+ ;; FIXME: We should include some
+ ;; docstring with each entry.
+ (append
+ macro-declarations-alist
+ defun-declarations-alist)))))
+ ((and (or `condition-case `condition-case-unless-debug)
+ (guard (save-excursion
+ (ignore-errors
+ (forward-sexp 2)
+ (< (point) beg)))))
+ (list t obarray
+ :predicate (lambda (sym) (get sym 'error-conditions))))
+ ((and ?\(
+ (guard (save-excursion
+ (goto-char (1- beg))
+ (up-list -1)
+ (forward-symbol -1)
+ (looking-at "\\_<let\\*?\\_>"))))
+ (list t obarray
+ :predicate #'boundp
+ :company-doc-buffer #'lisp--company-doc-buffer
+ :company-docsig #'lisp--company-doc-string
+ :company-location #'lisp--company-location))
+ (_ (list nil obarray
+ :predicate #'fboundp
+ :company-doc-buffer #'lisp--company-doc-buffer
+ :company-docsig #'lisp--company-doc-string
+ :company-location #'lisp--company-location
+ ))))))))
+ (when end
+ (let ((tail (if (null (car table-etc))
+ (cdr table-etc)
+ (cons
+ (if (memq (char-syntax (or (char-after end) ?\s))
+ '(?\s ?>))
+ (cadr table-etc)
+ (apply-partially 'completion-table-with-terminator
+ " " (cadr table-etc)))
+ (cddr table-etc)))))
+ `(,beg ,end ,@tail))))))
+
+ ;;; lisp.el ends here
--- /dev/null
+ ;;; simple.el --- basic editing commands for Emacs -*- lexical-binding: t -*-
+
+ ;; Copyright (C) 1985-1987, 1993-2015 Free Software Foundation, Inc.
+
+ ;; Maintainer: emacs-devel@gnu.org
+ ;; Keywords: internal
+ ;; Package: emacs
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+
+ ;; A grab-bag of basic Emacs commands not specifically related to some
+ ;; major mode or to file-handling.
+
+ ;;; Code:
+
+ (eval-when-compile (require 'cl-lib))
+
+ (declare-function widget-convert "wid-edit" (type &rest args))
+ (declare-function shell-mode "shell" ())
+
+ ;;; From compile.el
+ (defvar compilation-current-error)
+ (defvar compilation-context-lines)
+
+ (defcustom idle-update-delay 0.5
+ "Idle time delay before updating various things on the screen.
+ Various Emacs features that update auxiliary information when point moves
+ wait this many seconds after Emacs becomes idle before doing an update."
+ :type 'number
+ :group 'display
+ :version "22.1")
+
+ (defgroup killing nil
+ "Killing and yanking commands."
+ :group 'editing)
+
+ (defgroup paren-matching nil
+ "Highlight (un)matching of parens and expressions."
+ :group 'matching)
+ \f
+ ;;; next-error support framework
+
+ (defgroup next-error nil
+ "`next-error' support framework."
+ :group 'compilation
+ :version "22.1")
+
+ (defface next-error
+ '((t (:inherit region)))
+ "Face used to highlight next error locus."
+ :group 'next-error
+ :version "22.1")
+
+ (defcustom next-error-highlight 0.5
+ "Highlighting of locations in selected source buffers.
+ If a number, highlight the locus in `next-error' face for the given time
+ in seconds, or until the next command is executed.
+ If t, highlight the locus until the next command is executed, or until
+ some other locus replaces it.
+ If nil, don't highlight the locus in the source buffer.
+ If `fringe-arrow', indicate the locus by the fringe arrow
+ indefinitely until some other locus replaces it."
+ :type '(choice (number :tag "Highlight for specified time")
+ (const :tag "Semipermanent highlighting" t)
+ (const :tag "No highlighting" nil)
+ (const :tag "Fringe arrow" fringe-arrow))
+ :group 'next-error
+ :version "22.1")
+
+ (defcustom next-error-highlight-no-select 0.5
+ "Highlighting of locations in `next-error-no-select'.
+ If number, highlight the locus in `next-error' face for given time in seconds.
+ If t, highlight the locus indefinitely until some other locus replaces it.
+ If nil, don't highlight the locus in the source buffer.
+ If `fringe-arrow', indicate the locus by the fringe arrow
+ indefinitely until some other locus replaces it."
+ :type '(choice (number :tag "Highlight for specified time")
+ (const :tag "Semipermanent highlighting" t)
+ (const :tag "No highlighting" nil)
+ (const :tag "Fringe arrow" fringe-arrow))
+ :group 'next-error
+ :version "22.1")
+
+ (defcustom next-error-recenter nil
+ "Display the line in the visited source file recentered as specified.
+ If non-nil, the value is passed directly to `recenter'."
+ :type '(choice (integer :tag "Line to recenter to")
+ (const :tag "Center of window" (4))
+ (const :tag "No recentering" nil))
+ :group 'next-error
+ :version "23.1")
+
+ (defcustom next-error-hook nil
+ "List of hook functions run by `next-error' after visiting source file."
+ :type 'hook
+ :group 'next-error)
+
+ (defvar next-error-highlight-timer nil)
+
+ (defvar next-error-overlay-arrow-position nil)
+ (put 'next-error-overlay-arrow-position 'overlay-arrow-string (purecopy "=>"))
+ (add-to-list 'overlay-arrow-variable-list 'next-error-overlay-arrow-position)
+
+ (defvar next-error-last-buffer nil
+ "The most recent `next-error' buffer.
+ A buffer becomes most recent when its compilation, grep, or
+ similar mode is started, or when it is used with \\[next-error]
+ or \\[compile-goto-error].")
+
+ (defvar next-error-function nil
+ "Function to use to find the next error in the current buffer.
+ The function is called with 2 parameters:
+ ARG is an integer specifying by how many errors to move.
+ RESET is a boolean which, if non-nil, says to go back to the beginning
+ of the errors before moving.
+ Major modes providing compile-like functionality should set this variable
+ to indicate to `next-error' that this is a candidate buffer and how
+ to navigate in it.")
+ (make-variable-buffer-local 'next-error-function)
+
+ (defvar next-error-move-function nil
+ "Function to use to move to an error locus.
+ It takes two arguments, a buffer position in the error buffer
+ and a buffer position in the error locus buffer.
+ The buffer for the error locus should already be current.
+ nil means use goto-char using the second argument position.")
+ (make-variable-buffer-local 'next-error-move-function)
+
+ (defsubst next-error-buffer-p (buffer
+ &optional avoid-current
+ extra-test-inclusive
+ extra-test-exclusive)
+ "Test if BUFFER is a `next-error' capable buffer.
+
+ If AVOID-CURRENT is non-nil, treat the current buffer
+ as an absolute last resort only.
+
+ The function EXTRA-TEST-INCLUSIVE, if non-nil, is called in each buffer
+ that normally would not qualify. If it returns t, the buffer
+ in question is treated as usable.
+
+ The function EXTRA-TEST-EXCLUSIVE, if non-nil, is called in each buffer
+ that would normally be considered usable. If it returns nil,
+ that buffer is rejected."
+ (and (buffer-name buffer) ;First make sure it's live.
+ (not (and avoid-current (eq buffer (current-buffer))))
+ (with-current-buffer buffer
+ (if next-error-function ; This is the normal test.
+ ;; Optionally reject some buffers.
+ (if extra-test-exclusive
+ (funcall extra-test-exclusive)
+ t)
+ ;; Optionally accept some other buffers.
+ (and extra-test-inclusive
+ (funcall extra-test-inclusive))))))
+
+ (defun next-error-find-buffer (&optional avoid-current
+ extra-test-inclusive
+ extra-test-exclusive)
+ "Return a `next-error' capable buffer.
+
+ If AVOID-CURRENT is non-nil, treat the current buffer
+ as an absolute last resort only.
+
+ The function EXTRA-TEST-INCLUSIVE, if non-nil, is called in each buffer
+ that normally would not qualify. If it returns t, the buffer
+ in question is treated as usable.
+
+ The function EXTRA-TEST-EXCLUSIVE, if non-nil, is called in each buffer
+ that would normally be considered usable. If it returns nil,
+ that buffer is rejected."
+ (or
+ ;; 1. If one window on the selected frame displays such buffer, return it.
+ (let ((window-buffers
+ (delete-dups
+ (delq nil (mapcar (lambda (w)
+ (if (next-error-buffer-p
+ (window-buffer w)
+ avoid-current
+ extra-test-inclusive extra-test-exclusive)
+ (window-buffer w)))
+ (window-list))))))
+ (if (eq (length window-buffers) 1)
+ (car window-buffers)))
+ ;; 2. If next-error-last-buffer is an acceptable buffer, use that.
+ (if (and next-error-last-buffer
+ (next-error-buffer-p next-error-last-buffer avoid-current
+ extra-test-inclusive extra-test-exclusive))
+ next-error-last-buffer)
+ ;; 3. If the current buffer is acceptable, choose it.
+ (if (next-error-buffer-p (current-buffer) avoid-current
+ extra-test-inclusive extra-test-exclusive)
+ (current-buffer))
+ ;; 4. Look for any acceptable buffer.
+ (let ((buffers (buffer-list)))
+ (while (and buffers
+ (not (next-error-buffer-p
+ (car buffers) avoid-current
+ extra-test-inclusive extra-test-exclusive)))
+ (setq buffers (cdr buffers)))
+ (car buffers))
+ ;; 5. Use the current buffer as a last resort if it qualifies,
+ ;; even despite AVOID-CURRENT.
+ (and avoid-current
+ (next-error-buffer-p (current-buffer) nil
+ extra-test-inclusive extra-test-exclusive)
+ (progn
+ (message "This is the only buffer with error message locations")
+ (current-buffer)))
+ ;; 6. Give up.
+ (error "No buffers contain error message locations")))
+
+ (defun next-error (&optional arg reset)
+ "Visit next `next-error' message and corresponding source code.
+
+ If all the error messages parsed so far have been processed already,
+ the message buffer is checked for new ones.
+
+ A prefix ARG specifies how many error messages to move;
+ negative means move back to previous error messages.
+ Just \\[universal-argument] as a prefix means reparse the error message buffer
+ and start at the first error.
+
+ The RESET argument specifies that we should restart from the beginning.
+
+ \\[next-error] normally uses the most recently started
+ compilation, grep, or occur buffer. It can also operate on any
+ buffer with output from the \\[compile], \\[grep] commands, or,
+ more generally, on any buffer in Compilation mode or with
+ Compilation Minor mode enabled, or any buffer in which
+ `next-error-function' is bound to an appropriate function.
+ To specify use of a particular buffer for error messages, type
+ \\[next-error] in that buffer when it is the only one displayed
+ in the current frame.
+
+ Once \\[next-error] has chosen the buffer for error messages, it
+ runs `next-error-hook' with `run-hooks', and stays with that buffer
+ until you use it in some other buffer which uses Compilation mode
+ or Compilation Minor mode.
+
+ To control which errors are matched, customize the variable
+ `compilation-error-regexp-alist'."
+ (interactive "P")
+ (if (consp arg) (setq reset t arg nil))
+ (when (setq next-error-last-buffer (next-error-find-buffer))
+ ;; we know here that next-error-function is a valid symbol we can funcall
+ (with-current-buffer next-error-last-buffer
+ (funcall next-error-function (prefix-numeric-value arg) reset)
+ (when next-error-recenter
+ (recenter next-error-recenter))
+ (run-hooks 'next-error-hook))))
+
+ (defun next-error-internal ()
+ "Visit the source code corresponding to the `next-error' message at point."
+ (setq next-error-last-buffer (current-buffer))
+ ;; we know here that next-error-function is a valid symbol we can funcall
+ (with-current-buffer next-error-last-buffer
+ (funcall next-error-function 0 nil)
+ (when next-error-recenter
+ (recenter next-error-recenter))
+ (run-hooks 'next-error-hook)))
+
+ (defalias 'goto-next-locus 'next-error)
+ (defalias 'next-match 'next-error)
+
+ (defun previous-error (&optional n)
+ "Visit previous `next-error' message and corresponding source code.
+
+ Prefix arg N says how many error messages to move backwards (or
+ forwards, if negative).
+
+ This operates on the output from the \\[compile] and \\[grep] commands."
+ (interactive "p")
+ (next-error (- (or n 1))))
+
+ (defun first-error (&optional n)
+ "Restart at the first error.
+ Visit corresponding source code.
+ With prefix arg N, visit the source code of the Nth error.
+ This operates on the output from the \\[compile] command, for instance."
+ (interactive "p")
+ (next-error n t))
+
+ (defun next-error-no-select (&optional n)
+ "Move point to the next error in the `next-error' buffer and highlight match.
+ Prefix arg N says how many error messages to move forwards (or
+ backwards, if negative).
+ Finds and highlights the source line like \\[next-error], but does not
+ select the source buffer."
+ (interactive "p")
+ (let ((next-error-highlight next-error-highlight-no-select))
+ (next-error n))
+ (pop-to-buffer next-error-last-buffer))
+
+ (defun previous-error-no-select (&optional n)
+ "Move point to the previous error in the `next-error' buffer and highlight match.
+ Prefix arg N says how many error messages to move backwards (or
+ forwards, if negative).
+ Finds and highlights the source line like \\[previous-error], but does not
+ select the source buffer."
+ (interactive "p")
+ (next-error-no-select (- (or n 1))))
+
+ ;; Internal variable for `next-error-follow-mode-post-command-hook'.
+ (defvar next-error-follow-last-line nil)
+
+ (define-minor-mode next-error-follow-minor-mode
+ "Minor mode for compilation, occur and diff modes.
+ With a prefix argument ARG, enable mode if ARG is positive, and
+ disable it otherwise. If called from Lisp, enable mode if ARG is
+ omitted or nil.
+ When turned on, cursor motion in the compilation, grep, occur or diff
+ buffer causes automatic display of the corresponding source code location."
+ :group 'next-error :init-value nil :lighter " Fol"
+ (if (not next-error-follow-minor-mode)
+ (remove-hook 'post-command-hook 'next-error-follow-mode-post-command-hook t)
+ (add-hook 'post-command-hook 'next-error-follow-mode-post-command-hook nil t)
+ (make-local-variable 'next-error-follow-last-line)))
+
+ ;; Used as a `post-command-hook' by `next-error-follow-mode'
+ ;; for the *Compilation* *grep* and *Occur* buffers.
+ (defun next-error-follow-mode-post-command-hook ()
+ (unless (equal next-error-follow-last-line (line-number-at-pos))
+ (setq next-error-follow-last-line (line-number-at-pos))
+ (condition-case nil
+ (let ((compilation-context-lines nil))
+ (setq compilation-current-error (point))
+ (next-error-no-select 0))
+ (error t))))
+
+ \f
+ ;;;
+
+ (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)
+ (run-mode-hooks))
+
+ ;; Special major modes to view specially formatted data rather than files.
+
+ (defvar special-mode-map
+ (let ((map (make-sparse-keymap)))
+ (suppress-keymap map)
+ (define-key map "q" 'quit-window)
+ (define-key map " " 'scroll-up-command)
+ (define-key map [?\S-\ ] 'scroll-down-command)
+ (define-key map "\C-?" 'scroll-down-command)
+ (define-key map "?" 'describe-mode)
+ (define-key map "h" 'describe-mode)
+ (define-key map ">" 'end-of-buffer)
+ (define-key map "<" 'beginning-of-buffer)
+ (define-key map "g" 'revert-buffer)
+ map))
+
+ (put 'special-mode 'mode-class 'special)
+ (define-derived-mode special-mode nil "Special"
+ "Parent major mode from which special major modes should inherit."
+ (setq buffer-read-only t))
+
+ ;; Making and deleting lines.
+
+ (defvar self-insert-uses-region-functions nil
+ "Special hook to tell if `self-insert-command' will use the region.
+ It must be called via `run-hook-with-args-until-success' with no arguments.
+ Any `post-self-insert-command' which consumes the region should
+ register a function on this hook so that things like `delete-selection-mode'
+ can refrain from consuming the region.")
+
+ (defvar hard-newline (propertize "\n" 'hard t 'rear-nonsticky '(hard))
+ "Propertized string representing a hard newline character.")
+
+ (defun newline (&optional arg interactive)
+ "Insert a newline, and move to left margin of the new line if it's blank.
+ If option `use-hard-newlines' is non-nil, the newline is marked with the
+ text-property `hard'.
+ With ARG, insert that many newlines.
+
+ If `electric-indent-mode' is enabled, this indents the final new line
+ that it adds, and reindents the preceding line. To just insert
+ a newline, use \\[electric-indent-just-newline].
+
+ Calls `auto-fill-function' if the current column number is greater
+ than the value of `fill-column' and ARG is nil.
+ A non-nil INTERACTIVE argument means to run the `post-self-insert-hook'."
+ (interactive "*P\np")
+ (barf-if-buffer-read-only)
+ ;; Call self-insert so that auto-fill, abbrev expansion etc. happens.
+ ;; Set last-command-event to tell self-insert what to insert.
+ (let* ((was-page-start (and (bolp) (looking-at page-delimiter)))
+ (beforepos (point))
+ (last-command-event ?\n)
+ ;; Don't auto-fill if we have a numeric argument.
+ (auto-fill-function (if arg nil auto-fill-function))
+ (postproc
+ ;; Do the rest in post-self-insert-hook, because we want to do it
+ ;; *before* other functions on that hook.
+ (lambda ()
+ (cl-assert (eq ?\n (char-before)))
+ ;; Mark the newline(s) `hard'.
+ (if use-hard-newlines
+ (set-hard-newline-properties
+ (- (point) (prefix-numeric-value arg)) (point)))
+ ;; If the newline leaves the previous line blank, and we
+ ;; have a left margin, delete that from the blank line.
+ (save-excursion
+ (goto-char beforepos)
+ (beginning-of-line)
+ (and (looking-at "[ \t]$")
+ (> (current-left-margin) 0)
+ (delete-region (point)
+ (line-end-position))))
+ ;; Indent the line after the newline, except in one case:
+ ;; when we added the newline at the beginning of a line which
+ ;; starts a page.
+ (or was-page-start
+ (move-to-left-margin nil t)))))
+ (unwind-protect
+ (if (not interactive)
+ ;; FIXME: For non-interactive uses, many calls actually just want
+ ;; (insert "\n"), so maybe we should do just that, so as to avoid
+ ;; the risk of filling or running abbrevs unexpectedly.
+ (let ((post-self-insert-hook (list postproc)))
+ (self-insert-command (prefix-numeric-value arg)))
+ (unwind-protect
+ (progn
+ (add-hook 'post-self-insert-hook postproc nil t)
+ (self-insert-command (prefix-numeric-value arg)))
+ ;; We first used let-binding to protect the hook, but that was naive
+ ;; since add-hook affects the symbol-default value of the variable,
+ ;; whereas the let-binding might only protect the buffer-local value.
+ (remove-hook 'post-self-insert-hook postproc t)))
+ (cl-assert (not (member postproc post-self-insert-hook)))
+ (cl-assert (not (member postproc (default-value 'post-self-insert-hook))))))
+ nil)
+
+ (defun set-hard-newline-properties (from to)
+ (let ((sticky (get-text-property from 'rear-nonsticky)))
+ (put-text-property from to 'hard 't)
+ ;; If rear-nonsticky is not "t", add 'hard to rear-nonsticky list
+ (if (and (listp sticky) (not (memq 'hard sticky)))
+ (put-text-property from (point) 'rear-nonsticky
+ (cons 'hard sticky)))))
+
+ (defun open-line (n)
+ "Insert a newline and leave point before it.
+ If there is a fill prefix and/or a `left-margin', insert them
+ on the new line if the line would have been blank.
+ With arg N, insert N newlines."
+ (interactive "*p")
+ (let* ((do-fill-prefix (and fill-prefix (bolp)))
+ (do-left-margin (and (bolp) (> (current-left-margin) 0)))
+ (loc (point-marker))
+ ;; Don't expand an abbrev before point.
+ (abbrev-mode nil))
+ (newline n)
+ (goto-char loc)
+ (while (> n 0)
+ (cond ((bolp)
+ (if do-left-margin (indent-to (current-left-margin)))
+ (if do-fill-prefix (insert-and-inherit fill-prefix))))
+ (forward-line 1)
+ (setq n (1- n)))
+ (goto-char loc)
+ (end-of-line)))
+
+ (defun split-line (&optional arg)
+ "Split current line, moving portion beyond point vertically down.
+ If the current line starts with `fill-prefix', insert it on the new
+ line as well. With prefix ARG, don't insert `fill-prefix' on new line.
+
+ When called from Lisp code, ARG may be a prefix string to copy."
+ (interactive "*P")
+ (skip-chars-forward " \t")
+ (let* ((col (current-column))
+ (pos (point))
+ ;; What prefix should we check for (nil means don't).
+ (prefix (cond ((stringp arg) arg)
+ (arg nil)
+ (t fill-prefix)))
+ ;; Does this line start with it?
+ (have-prfx (and prefix
+ (save-excursion
+ (beginning-of-line)
+ (looking-at (regexp-quote prefix))))))
+ (newline 1)
+ (if have-prfx (insert-and-inherit prefix))
+ (indent-to col 0)
+ (goto-char pos)))
+
+ (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.
+ With argument, join this line to following line."
+ (interactive "*P")
+ (beginning-of-line)
+ (if arg (forward-line 1))
+ (if (eq (preceding-char) ?\n)
+ (progn
+ (delete-region (point) (1- (point)))
+ ;; If the second line started with the fill prefix,
+ ;; delete the prefix.
+ (if (and fill-prefix
+ (<= (+ (point) (length fill-prefix)) (point-max))
+ (string= fill-prefix
+ (buffer-substring (point)
+ (+ (point) (length fill-prefix)))))
+ (delete-region (point) (+ (point) (length fill-prefix))))
+ (fixup-whitespace))))
+
+ (defalias 'join-line #'delete-indentation) ; easier to find
+
+ (defun delete-blank-lines ()
+ "On blank line, delete all surrounding blank lines, leaving just one.
+ On isolated blank line, delete that one.
+ On nonblank line, delete any immediately following blank lines."
+ (interactive "*")
+ (let (thisblank singleblank)
+ (save-excursion
+ (beginning-of-line)
+ (setq thisblank (looking-at "[ \t]*$"))
+ ;; Set singleblank if there is just one blank line here.
+ (setq singleblank
+ (and thisblank
+ (not (looking-at "[ \t]*\n[ \t]*$"))
+ (or (bobp)
+ (progn (forward-line -1)
+ (not (looking-at "[ \t]*$")))))))
+ ;; Delete preceding blank lines, and this one too if it's the only one.
+ (if thisblank
+ (progn
+ (beginning-of-line)
+ (if singleblank (forward-line 1))
+ (delete-region (point)
+ (if (re-search-backward "[^ \t\n]" nil t)
+ (progn (forward-line 1) (point))
+ (point-min)))))
+ ;; Delete following blank lines, unless the current line is blank
+ ;; and there are no following blank lines.
+ (if (not (and thisblank singleblank))
+ (save-excursion
+ (end-of-line)
+ (forward-line 1)
+ (delete-region (point)
+ (if (re-search-forward "[^ \t\n]" nil t)
+ (progn (beginning-of-line) (point))
+ (point-max)))))
+ ;; Handle the special case where point is followed by newline and eob.
+ ;; Delete the line, leaving point at eob.
+ (if (looking-at "^[ \t]*\n\\'")
+ (delete-region (point) (point-max)))))
+
+ (defcustom delete-trailing-lines t
+ "If non-nil, \\[delete-trailing-whitespace] deletes trailing lines.
+ Trailing lines are deleted only if `delete-trailing-whitespace'
+ is called on the entire buffer (rather than an active region)."
+ :type 'boolean
+ :group 'editing
+ :version "24.3")
+
+ (defun delete-trailing-whitespace (&optional start end)
+ "Delete trailing whitespace between START and END.
+ If called interactively, START and END are the start/end of the
+ region if the mark is active, or of the buffer's accessible
+ portion if the mark is inactive.
+
+ This command deletes whitespace characters after the last
+ non-whitespace character in each line between START and END. It
+ does not consider formfeed characters to be whitespace.
+
+ If this command acts on the entire buffer (i.e. if called
+ interactively with the mark inactive, or called from Lisp with
+ END nil), it also deletes all trailing lines at the end of the
+ buffer if the variable `delete-trailing-lines' is non-nil."
+ (interactive (progn
+ (barf-if-buffer-read-only)
+ (if (use-region-p)
+ (list (region-beginning) (region-end))
+ (list nil nil))))
+ (save-match-data
+ (save-excursion
+ (let ((end-marker (copy-marker (or end (point-max))))
+ (start (or start (point-min))))
+ (goto-char start)
+ (while (re-search-forward "\\s-$" end-marker t)
+ (skip-syntax-backward "-" (line-beginning-position))
+ ;; Don't delete formfeeds, even if they are considered whitespace.
+ (if (looking-at-p ".*\f")
+ (goto-char (match-end 0)))
+ (delete-region (point) (match-end 0)))
+ ;; Delete trailing empty lines.
+ (goto-char end-marker)
+ (when (and (not end)
+ delete-trailing-lines
+ ;; Really the end of buffer.
+ (= (point-max) (1+ (buffer-size)))
+ (<= (skip-chars-backward "\n") -2))
+ (delete-region (1+ (point)) end-marker))
+ (set-marker end-marker nil))))
+ ;; Return nil for the benefit of `write-file-functions'.
+ nil)
+
+ (defun newline-and-indent ()
+ "Insert a newline, then indent according to major mode.
+ Indentation is done using the value of `indent-line-function'.
+ In programming language modes, this is the same as TAB.
+ In some text modes, where TAB inserts a tab, this command indents to the
+ column specified by the function `current-left-margin'."
+ (interactive "*")
+ (delete-horizontal-space t)
+ (newline nil t)
+ (indent-according-to-mode))
+
+ (defun reindent-then-newline-and-indent ()
+ "Reindent current line, insert newline, then indent the new line.
+ Indentation of both lines is done according to the current major mode,
+ which means calling the current value of `indent-line-function'.
+ In programming language modes, this is the same as TAB.
+ In some text modes, where TAB inserts a tab, this indents to the
+ column specified by the function `current-left-margin'."
+ (interactive "*")
+ (let ((pos (point)))
+ ;; Be careful to insert the newline before indenting the line.
+ ;; Otherwise, the indentation might be wrong.
+ (newline)
+ (save-excursion
+ (goto-char pos)
+ ;; We are at EOL before the call to indent-according-to-mode, and
+ ;; after it we usually are as well, but not always. We tried to
+ ;; address it with `save-excursion' but that uses a normal marker
+ ;; whereas we need `move after insertion', so we do the save/restore
+ ;; by hand.
+ (setq pos (copy-marker pos t))
+ (indent-according-to-mode)
+ (goto-char pos)
+ ;; Remove the trailing white-space after indentation because
+ ;; indentation may introduce the whitespace.
+ (delete-horizontal-space t))
+ (indent-according-to-mode)))
+
+ (defcustom read-quoted-char-radix 8
+ "Radix for \\[quoted-insert] and other uses of `read-quoted-char'.
+ Legitimate radix values are 8, 10 and 16."
+ :type '(choice (const 8) (const 10) (const 16))
+ :group 'editing-basics)
+
+ (defun read-quoted-char (&optional prompt)
+ "Like `read-char', but do not allow quitting.
+ Also, if the first character read is an octal digit,
+ we read any number of octal digits and return the
+ specified character code. Any nondigit terminates the sequence.
+ If the terminator is RET, it is discarded;
+ any other terminator is used itself as input.
+
+ The optional argument PROMPT specifies a string to use to prompt the user.
+ The variable `read-quoted-char-radix' controls which radix to use
+ for numeric input."
+ (let ((message-log-max nil)
+ (help-events (delq nil (mapcar (lambda (c) (unless (characterp c) c))
+ help-event-list)))
+ done (first t) (code 0) translated)
+ (while (not done)
+ (let ((inhibit-quit first)
+ ;; Don't let C-h or other help chars get the help
+ ;; message--only help function keys. See bug#16617.
+ (help-char nil)
+ (help-event-list help-events)
+ (help-form
+ "Type the special character you want to use,
+ or the octal character code.
+ RET terminates the character code and is discarded;
+ any other non-digit terminates the character code and is then used as input."))
+ (setq translated (read-key (and prompt (format "%s-" prompt))))
+ (if inhibit-quit (setq quit-flag nil)))
+ (if (integerp translated)
+ (setq translated (char-resolve-modifiers translated)))
+ (cond ((null translated))
+ ((not (integerp translated))
+ (setq unread-command-events
+ (listify-key-sequence (this-single-command-raw-keys))
+ done t))
+ ((/= (logand translated ?\M-\^@) 0)
+ ;; Turn a meta-character into a character with the 0200 bit set.
+ (setq code (logior (logand translated (lognot ?\M-\^@)) 128)
+ done t))
+ ((and (<= ?0 translated)
+ (< translated (+ ?0 (min 10 read-quoted-char-radix))))
+ (setq code (+ (* code read-quoted-char-radix) (- translated ?0)))
+ (and prompt (setq prompt (message "%s %c" prompt translated))))
+ ((and (<= ?a (downcase translated))
+ (< (downcase translated)
+ (+ ?a -10 (min 36 read-quoted-char-radix))))
+ (setq code (+ (* code read-quoted-char-radix)
+ (+ 10 (- (downcase translated) ?a))))
+ (and prompt (setq prompt (message "%s %c" prompt translated))))
+ ((and (not first) (eq translated ?\C-m))
+ (setq done t))
+ ((not first)
+ (setq unread-command-events
+ (listify-key-sequence (this-single-command-raw-keys))
+ done t))
+ (t (setq code translated
+ done t)))
+ (setq first nil))
+ code))
+
+ (defun quoted-insert (arg)
+ "Read next input character and insert it.
+ This is useful for inserting control characters.
+ With argument, insert ARG copies of the character.
+
+ 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
+ ;; Avoid "obsolete" warnings for translation-table-for-input.
+ (with-no-warnings
+ (let (translation-table-for-input input-method-function)
+ (if (or (not overwrite-mode)
+ (eq overwrite-mode 'overwrite-mode-binary))
+ (read-quoted-char)
+ (read-char))))))
+ ;; This used to assume character codes 0240 - 0377 stand for
+ ;; characters in some single-byte character set, and converted them
+ ;; to Emacs characters. But in 23.1 this feature is deprecated
+ ;; in favor of inserting the corresponding Unicode characters.
+ ;; (if (and enable-multibyte-characters
+ ;; (>= char ?\240)
+ ;; (<= char ?\377))
+ ;; (setq char (unibyte-char-to-multibyte char)))
+ (unless (characterp char)
+ (user-error "%s is not a valid character"
+ (key-description (vector 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 forward-to-indentation (&optional arg)
+ "Move forward ARG lines and position at first nonblank character."
+ (interactive "^p")
+ (forward-line (or arg 1))
+ (skip-chars-forward " \t"))
+
+ (defun backward-to-indentation (&optional arg)
+ "Move backward ARG lines and position at first nonblank character."
+ (interactive "^p")
+ (forward-line (- (or arg 1)))
+ (skip-chars-forward " \t"))
+
+ (defun back-to-indentation ()
+ "Move point to the first non-whitespace character on this line."
+ (interactive "^")
+ (beginning-of-line 1)
+ (skip-syntax-forward " " (line-end-position))
+ ;; Move back over chars that have whitespace syntax but have the p flag.
+ (backward-prefix-chars))
+
+ (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 ?\s))))
+
+ (defun delete-horizontal-space (&optional backward-only)
+ "Delete all spaces and tabs around point.
+ If BACKWARD-ONLY is non-nil, only delete them before point."
+ (interactive "*P")
+ (let ((orig-pos (point)))
+ (delete-region
+ (if backward-only
+ orig-pos
+ (progn
+ (skip-chars-forward " \t")
+ (constrain-to-field nil orig-pos t)))
+ (progn
+ (skip-chars-backward " \t")
+ (constrain-to-field nil orig-pos)))))
+
+ (defun just-one-space (&optional n)
+ "Delete all spaces and tabs around point, leaving one space (or N spaces).
+ If N is negative, delete newlines as well, leaving -N spaces.
+ See also `cycle-spacing'."
+ (interactive "*p")
+ (cycle-spacing n nil t))
+
+ (defvar cycle-spacing--context nil
+ "Store context used in consecutive calls to `cycle-spacing' command.
+ The first time this function is run, it saves the original point
+ position and original spacing around the point in this
+ variable.")
+
+ (defun cycle-spacing (&optional n preserve-nl-back single-shot)
+ "Manipulate whitespace around point in a smart way.
+ In interactive use, this function behaves differently in successive
+ consecutive calls.
+
+ The first call in a sequence acts like `just-one-space'.
+ It deletes all spaces and tabs around point, leaving one space
+ \(or N spaces). N is the prefix argument. If N is negative,
+ it deletes newlines as well, leaving -N spaces.
+ \(If PRESERVE-NL-BACK is non-nil, it does not delete newlines before point.)
+
+ The second call in a sequence (or the first call if the above does
+ not result in any changes) deletes all spaces.
+
+ The third call in a sequence restores the original whitespace (and point).
+
+ If SINGLE-SHOT is non-nil, it only performs the first step in the sequence."
+ (interactive "*p")
+ (let ((orig-pos (point))
+ (skip-characters (if (and n (< n 0)) " \t\n\r" " \t"))
+ (n (abs (or n 1))))
+ (skip-chars-backward (if preserve-nl-back " \t" skip-characters))
+ (constrain-to-field nil orig-pos)
+ (cond
+ ;; Command run for the first time or single-shot is non-nil.
+ ((or single-shot
+ (not (equal last-command this-command))
+ (not cycle-spacing--context))
+ (let* ((start (point))
+ (n (- n (skip-chars-forward " " (+ n (point)))))
+ (mid (point))
+ (end (progn
+ (skip-chars-forward skip-characters)
+ (constrain-to-field nil orig-pos t))))
+ (setq cycle-spacing--context ;; Save for later.
+ ;; Special handling for case where there was no space at all.
+ (unless (= start end)
+ (cons orig-pos (buffer-substring start (point)))))
+ ;; If this run causes no change in buffer content, delete all spaces,
+ ;; otherwise delete all excess spaces.
+ (delete-region (if (and (not single-shot) (zerop n) (= mid end))
+ start mid) end)
+ (insert (make-string n ?\s))))
+
+ ;; Command run for the second time.
+ ((not (equal orig-pos (point)))
+ (delete-region (point) orig-pos))
+
+ ;; Command run for the third time.
+ (t
+ (insert (cdr cycle-spacing--context))
+ (goto-char (car cycle-spacing--context))
+ (setq cycle-spacing--context nil)))))
+ \f
+ (defun beginning-of-buffer (&optional arg)
+ "Move point to the beginning of the buffer.
+ With numeric arg N, put point N/10 of the way from the beginning.
+ If the buffer is narrowed, this command uses the beginning of the
+ accessible part of the buffer.
+
+ If Transient Mark mode is disabled, leave mark at previous
+ position, unless a \\[universal-argument] prefix is supplied.
+
+ Don't use this command in Lisp programs!
+ \(goto-char (point-min)) is faster."
+ (interactive "^P")
+ (or (consp arg)
+ (region-active-p)
+ (push-mark))
+ (let ((size (- (point-max) (point-min))))
+ (goto-char (if (and arg (not (consp arg)))
+ (+ (point-min)
+ (if (> size 10000)
+ ;; Avoid overflow for large buffer sizes!
+ (* (prefix-numeric-value arg)
+ (/ size 10))
+ (/ (+ 10 (* size (prefix-numeric-value arg))) 10)))
+ (point-min))))
+ (if (and arg (not (consp arg))) (forward-line 1)))
+ (put 'beginning-of-buffer 'interactive-only
+ "use `(goto-char (point-min))' instead.")
+
+ (defun end-of-buffer (&optional arg)
+ "Move point to the end of the buffer.
+ With numeric arg N, put point N/10 of the way from the end.
+ If the buffer is narrowed, this command uses the end of the
+ accessible part of the buffer.
+
+ If Transient Mark mode is disabled, leave mark at previous
+ position, unless a \\[universal-argument] prefix is supplied.
+
+ Don't use this command in Lisp programs!
+ \(goto-char (point-max)) is faster."
+ (interactive "^P")
+ (or (consp arg) (region-active-p) (push-mark))
+ (let ((size (- (point-max) (point-min))))
+ (goto-char (if (and arg (not (consp arg)))
+ (- (point-max)
+ (if (> size 10000)
+ ;; Avoid overflow for large buffer sizes!
+ (* (prefix-numeric-value arg)
+ (/ size 10))
+ (/ (* size (prefix-numeric-value arg)) 10)))
+ (point-max))))
+ ;; If we went to a place in the middle of the buffer,
+ ;; adjust it to the beginning of a line.
+ (cond ((and arg (not (consp arg))) (forward-line 1))
+ ((and (eq (current-buffer) (window-buffer))
+ (> (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))))
+ (put 'end-of-buffer 'interactive-only "use `(goto-char (point-max))' instead.")
+
+ (defcustom delete-active-region t
+ "Whether single-char deletion commands delete an active region.
+ This has an effect only if Transient Mark mode is enabled, and
+ affects `delete-forward-char' and `delete-backward-char', though
+ not `delete-char'.
+
+ If the value is the symbol `kill', the active region is killed
+ instead of deleted."
+ :type '(choice (const :tag "Delete active region" t)
+ (const :tag "Kill active region" kill)
+ (const :tag "Do ordinary deletion" nil))
+ :group 'killing
+ :version "24.1")
+
+ (defvar region-extract-function
+ (lambda (delete)
+ (when (region-beginning)
+ (if (eq delete 'delete-only)
+ (delete-region (region-beginning) (region-end))
+ (filter-buffer-substring (region-beginning) (region-end) delete))))
+ "Function to get the region's content.
+ Called with one argument DELETE.
+ If DELETE is `delete-only', then only delete the region and the return value
+ is undefined. If DELETE is nil, just return the content as a string.
+ If anything else, delete the region and return its content as a string.")
+
+ (defun delete-backward-char (n &optional killflag)
+ "Delete the previous N characters (following if N is negative).
+ If Transient Mark mode is enabled, the mark is active, and N is 1,
+ delete the text in the region and deactivate the mark instead.
+ To disable this, set option `delete-active-region' to nil.
+
+ Optional second arg KILLFLAG, if non-nil, means to kill (save in
+ kill ring) instead of delete. Interactively, N is the prefix
+ arg, and KILLFLAG is set if N is explicitly specified.
+
+ In Overwrite mode, single character backward deletion may replace
+ tabs with spaces so as to back over columns, unless point is at
+ the end of the line."
+ (interactive "p\nP")
+ (unless (integerp n)
+ (signal 'wrong-type-argument (list 'integerp n)))
+ (cond ((and (use-region-p)
+ delete-active-region
+ (= n 1))
+ ;; If a region is active, kill or delete it.
+ (if (eq delete-active-region 'kill)
+ (kill-region (region-beginning) (region-end) 'region)
+ (funcall region-extract-function 'delete-only)))
+ ;; In Overwrite mode, maybe untabify while deleting
+ ((null (or (null overwrite-mode)
+ (<= n 0)
+ (memq (char-before) '(?\t ?\n))
+ (eobp)
+ (eq (char-after) ?\n)))
+ (let ((ocol (current-column)))
+ (delete-char (- n) killflag)
+ (save-excursion
+ (insert-char ?\s (- ocol (current-column)) nil))))
+ ;; Otherwise, do simple deletion.
+ (t (delete-char (- n) killflag))))
+ (put 'delete-backward-char 'interactive-only 'delete-char)
+
+ (defun delete-forward-char (n &optional killflag)
+ "Delete the following N characters (previous if N is negative).
+ If Transient Mark mode is enabled, the mark is active, and N is 1,
+ delete the text in the region and deactivate the mark instead.
+ To disable this, set variable `delete-active-region' to nil.
+
+ Optional second arg KILLFLAG non-nil means to kill (save in kill
+ ring) instead of delete. Interactively, N is the prefix arg, and
+ KILLFLAG is set if N was explicitly specified."
+ (interactive "p\nP")
+ (unless (integerp n)
+ (signal 'wrong-type-argument (list 'integerp n)))
+ (cond ((and (use-region-p)
+ delete-active-region
+ (= n 1))
+ ;; If a region is active, kill or delete it.
+ (if (eq delete-active-region 'kill)
+ (kill-region (region-beginning) (region-end) 'region)
+ (funcall region-extract-function 'delete-only)))
+
+ ;; Otherwise, do simple deletion.
+ (t (delete-char n killflag))))
+ (put 'delete-forward-char 'interactive-only 'delete-char)
+
+ (defun mark-whole-buffer ()
+ "Put point at beginning and mark at end of buffer.
+ If narrowing is in effect, only uses the accessible part of the buffer.
+ You probably should not use this function in Lisp programs;
+ it is usually a mistake for a Lisp function to use any subroutine
+ that uses or sets the mark."
+ (interactive)
+ (push-mark (point))
+ (push-mark (point-max) nil t)
+ (goto-char (point-min)))
+ \f
+
+ ;; Counting lines, one way or another.
+
+ (defun goto-line (line &optional buffer)
+ "Go to LINE, counting from line 1 at beginning of buffer.
+ If called interactively, a numeric prefix argument specifies
+ LINE; without a numeric prefix argument, read LINE from the
+ minibuffer.
+
+ If optional argument BUFFER is non-nil, switch to that buffer and
+ move to line LINE there. If called interactively with \\[universal-argument]
+ as argument, BUFFER is the most recently selected other buffer.
+
+ Prior to moving point, this function sets the mark (without
+ activating it), unless Transient Mark mode is enabled and the
+ mark is already active.
+
+ This function is usually the wrong thing to use in a Lisp program.
+ What you probably want instead is something like:
+ (goto-char (point-min))
+ (forward-line (1- N))
+ If at all possible, an even better solution is to use char counts
+ rather than line counts."
+ (interactive
+ (if (and current-prefix-arg (not (consp current-prefix-arg)))
+ (list (prefix-numeric-value current-prefix-arg))
+ ;; Look for a default, a number in the buffer at point.
+ (let* ((default
+ (save-excursion
+ (skip-chars-backward "0-9")
+ (if (looking-at "[0-9]")
+ (string-to-number
+ (buffer-substring-no-properties
+ (point)
+ (progn (skip-chars-forward "0-9")
+ (point)))))))
+ ;; Decide if we're switching buffers.
+ (buffer
+ (if (consp current-prefix-arg)
+ (other-buffer (current-buffer) t)))
+ (buffer-prompt
+ (if buffer
+ (concat " in " (buffer-name buffer))
+ "")))
+ ;; Read the argument, offering that number (if any) as default.
+ (list (read-number (format "Goto line%s: " buffer-prompt)
+ (list default (line-number-at-pos)))
+ buffer))))
+ ;; Switch to the desired buffer, one way or another.
+ (if buffer
+ (let ((window (get-buffer-window buffer)))
+ (if window (select-window window)
+ (switch-to-buffer-other-window buffer))))
+ ;; Leave mark at previous position
+ (or (region-active-p) (push-mark))
+ ;; Move to the specified line number in that buffer.
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (if (eq selective-display t)
+ (re-search-forward "[\n\C-m]" nil 'end (1- line))
+ (forward-line (1- line)))))
+ (put 'goto-line 'interactive-only 'forward-line)
+
+ (defun count-words-region (start end &optional arg)
+ "Count the number of words in the region.
+ If called interactively, print a message reporting the number of
+ lines, words, and characters in the region (whether or not the
+ region is active); with prefix ARG, report for the entire buffer
+ rather than the region.
+
+ If called from Lisp, return the number of words between positions
+ START and END."
+ (interactive (if current-prefix-arg
+ (list nil nil current-prefix-arg)
+ (list (region-beginning) (region-end) nil)))
+ (cond ((not (called-interactively-p 'any))
+ (count-words start end))
+ (arg
+ (count-words--buffer-message))
+ (t
+ (count-words--message "Region" start end))))
+
+ (defun count-words (start end)
+ "Count words between START and END.
+ If called interactively, START and END are normally the start and
+ end of the buffer; but if the region is active, START and END are
+ the start and end of the region. Print a message reporting the
+ number of lines, words, and chars.
+
+ If called from Lisp, return the number of words between START and
+ END, without printing any message."
+ (interactive (list nil nil))
+ (cond ((not (called-interactively-p 'any))
+ (let ((words 0))
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start end)
+ (goto-char (point-min))
+ (while (forward-word 1)
+ (setq words (1+ words)))))
+ words))
+ ((use-region-p)
+ (call-interactively 'count-words-region))
+ (t
+ (count-words--buffer-message))))
+
+ (defun count-words--buffer-message ()
+ (count-words--message
+ (if (buffer-narrowed-p) "Narrowed part of buffer" "Buffer")
+ (point-min) (point-max)))
+
+ (defun count-words--message (str start end)
+ (let ((lines (count-lines start end))
+ (words (count-words start end))
+ (chars (- end start)))
+ (message "%s has %d line%s, %d word%s, and %d character%s."
+ str
+ lines (if (= lines 1) "" "s")
+ words (if (= words 1) "" "s")
+ chars (if (= chars 1) "" "s"))))
+
+ (define-obsolete-function-alias 'count-lines-region 'count-words-region "24.1")
+
+ (defun what-line ()
+ "Print the current buffer line number and narrowed line number of point."
+ (interactive)
+ (let ((start (point-min))
+ (n (line-number-at-pos)))
+ (if (= start 1)
+ (message "Line %d" n)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (message "line %d (narrowed line %d)"
+ (+ n (line-number-at-pos start) -1) n))))))
+
+ (defun count-lines (start end)
+ "Return number of lines between START and END.
+ This is usually the number of newlines between them,
+ but can be one more if START is not equal to END
+ and the greater of them is not at the start of a line."
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start end)
+ (goto-char (point-min))
+ (if (eq selective-display t)
+ (save-match-data
+ (let ((done 0))
+ (while (re-search-forward "[\n\C-m]" nil t 40)
+ (setq done (+ 40 done)))
+ (while (re-search-forward "[\n\C-m]" nil t 1)
+ (setq done (+ 1 done)))
+ (goto-char (point-max))
+ (if (and (/= start end)
+ (not (bolp)))
+ (1+ done)
+ done)))
+ (- (buffer-size) (forward-line (buffer-size)))))))
+
+ (defun line-number-at-pos (&optional pos)
+ "Return (narrowed) buffer line number at position POS.
+ If POS is nil, use current buffer location.
+ Counting starts at (point-min), so the value refers
+ to the contents of the accessible portion of the buffer."
+ (let ((opoint (or pos (point))) start)
+ (save-excursion
+ (goto-char (point-min))
+ (setq start (point))
+ (goto-char opoint)
+ (forward-line 0)
+ (1+ (count-lines start (point))))))
+
+ (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
+ in octal, decimal and hex.
+
+ For a non-ASCII multibyte character, also give its encoding in the
+ buffer's selected coding system if the coding system encodes the
+ character safely. If the character is encoded into one byte, that
+ code is shown in hex. If the character is encoded into more than one
+ byte, just \"...\" is shown.
+
+ In addition, with prefix argument, show details about that character
+ in *Help* buffer. See also the command `describe-char'."
+ (interactive "P")
+ (let* ((char (following-char))
+ (bidi-fixer
+ (cond ((memq char '(?\x202a ?\x202b ?\x202d ?\x202e))
+ ;; If the character is one of LRE, LRO, RLE, RLO, it
+ ;; will start a directional embedding, which could
+ ;; completely disrupt the rest of the line (e.g., RLO
+ ;; will display the rest of the line right-to-left).
+ ;; So we put an invisible PDF character after these
+ ;; characters, to end the embedding, which eliminates
+ ;; any effects on the rest of the line.
+ (propertize (string ?\x202c) 'invisible t))
+ ;; Strong right-to-left characters cause reordering of
+ ;; the following numerical characters which show the
+ ;; codepoint, so append LRM to countermand that.
+ ((memq (get-char-code-property char 'bidi-class) '(R AL))
+ (propertize (string ?\x200e) 'invisible t))
+ (t
+ "")))
+ (beg (point-min))
+ (end (point-max))
+ (pos (point))
+ (total (buffer-size))
+ (percent (if (> total 50000)
+ ;; Avoid overflow from multiplying by 100!
+ (/ (+ (/ total 200) (1- pos)) (max (/ total 100) 1))
+ (/ (+ (/ total 2) (* 100 (1- pos))) (max total 1))))
+ (hscroll (if (= (window-hscroll) 0)
+ ""
+ (format " Hscroll=%d" (window-hscroll))))
+ (col (current-column)))
+ (if (= pos end)
+ (if (or (/= beg 1) (/= end (1+ total)))
+ (message "point=%d of %d (%d%%) <%d-%d> column=%d%s"
+ pos total percent beg end col hscroll)
+ (message "point=%d of %d (EOB) column=%d%s"
+ pos total col hscroll))
+ (let ((coding buffer-file-coding-system)
+ encoded encoding-msg display-prop under-display)
+ (if (or (not coding)
+ (eq (coding-system-type coding) t))
+ (setq coding (default-value 'buffer-file-coding-system)))
+ (if (eq (char-charset char) 'eight-bit)
+ (setq encoding-msg
+ (format "(%d, #o%o, #x%x, raw-byte)" char char char))
+ ;; Check if the character is displayed with some `display'
+ ;; text property. In that case, set under-display to the
+ ;; buffer substring covered by that property.
+ (setq display-prop (get-char-property pos 'display))
+ (if display-prop
+ (let ((to (or (next-single-char-property-change pos 'display)
+ (point-max))))
+ (if (< to (+ pos 4))
+ (setq under-display "")
+ (setq under-display "..."
+ to (+ pos 4)))
+ (setq under-display
+ (concat (buffer-substring-no-properties pos to)
+ under-display)))
+ (setq encoded (and (>= char 128) (encode-coding-char char coding))))
+ (setq encoding-msg
+ (if display-prop
+ (if (not (stringp display-prop))
+ (format "(%d, #o%o, #x%x, part of display \"%s\")"
+ char char char under-display)
+ (format "(%d, #o%o, #x%x, part of display \"%s\"->\"%s\")"
+ char char char under-display display-prop))
+ (if encoded
+ (format "(%d, #o%o, #x%x, file %s)"
+ char char char
+ (if (> (length encoded) 1)
+ "..."
+ (encoded-string-description encoded coding)))
+ (format "(%d, #o%o, #x%x)" char char char)))))
+ (if detail
+ ;; We show the detailed information about CHAR.
+ (describe-char (point)))
+ (if (or (/= beg 1) (/= end (1+ total)))
+ (message "Char: %s%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))))
+ bidi-fixer
+ encoding-msg pos total percent beg end col hscroll)
+ (message "Char: %s%s %s point=%d of %d (%d%%) column=%d%s"
+ (if enable-multibyte-characters
+ (if (< char 128)
+ (single-key-description char)
+ (buffer-substring-no-properties (point) (1+ (point))))
+ (single-key-description char))
+ bidi-fixer encoding-msg pos total percent col hscroll))))))
+ \f
+ ;; Initialize read-expression-map. It is defined at C level.
+ (defvar read-expression-map
+ (let ((m (make-sparse-keymap)))
+ (define-key m "\M-\t" 'completion-at-point)
+ ;; Might as well bind TAB to completion, since inserting a TAB char is
+ ;; much too rarely useful.
+ (define-key m "\t" 'completion-at-point)
+ (set-keymap-parent m minibuffer-local-map)
+ m))
+
+ (defun read-minibuffer (prompt &optional initial-contents)
+ "Return a Lisp object read using the minibuffer, unevaluated.
+ Prompt with PROMPT. If non-nil, optional second arg INITIAL-CONTENTS
+ is a string to insert in the minibuffer before reading.
+ \(INITIAL-CONTENTS can also be a cons of a string and an integer.
+ Such arguments are used as in `read-from-minibuffer'.)"
+ ;; Used for interactive spec `x'.
+ (read-from-minibuffer prompt initial-contents minibuffer-local-map
+ t 'minibuffer-history))
+
+ (defun eval-minibuffer (prompt &optional initial-contents)
+ "Return value of Lisp expression read using the minibuffer.
+ Prompt with PROMPT. If non-nil, optional second arg INITIAL-CONTENTS
+ is a string to insert in the minibuffer before reading.
+ \(INITIAL-CONTENTS can also be a cons of a string and an integer.
+ Such arguments are used as in `read-from-minibuffer'.)"
+ ;; Used for interactive spec `X'.
+ (eval (read--expression prompt initial-contents)))
+
+ (defvar minibuffer-completing-symbol nil
+ "Non-nil means completing a Lisp symbol in the minibuffer.")
+ (make-obsolete-variable 'minibuffer-completing-symbol nil "24.1" 'get)
+
+ (defvar minibuffer-default nil
+ "The current default value or list of default values in the minibuffer.
+ The functions `read-from-minibuffer' and `completing-read' bind
+ this variable locally.")
+
+ (defcustom eval-expression-print-level 4
+ "Value for `print-level' while printing value in `eval-expression'.
+ A value of nil means no limit."
+ :group 'lisp
+ :type '(choice (const :tag "No Limit" nil) integer)
+ :version "21.1")
+
+ (defcustom eval-expression-print-length 12
+ "Value for `print-length' while printing value in `eval-expression'.
+ A value of nil means no limit."
+ :group 'lisp
+ :type '(choice (const :tag "No Limit" nil) integer)
+ :version "21.1")
+
+ (defcustom eval-expression-debug-on-error t
+ "If non-nil set `debug-on-error' to t in `eval-expression'.
+ If nil, don't change the value of `debug-on-error'."
+ :group 'lisp
+ :type 'boolean
+ :version "21.1")
+
+ (defun eval-expression-print-format (value)
+ "Format VALUE as a result of evaluated expression.
+ Return a formatted string which is displayed in the echo area
+ in addition to the value printed by prin1 in functions which
+ display the result of expression evaluation."
+ (if (and (integerp value)
+ (or (eq standard-output t)
+ (zerop (prefix-numeric-value current-prefix-arg))))
+ (let ((char-string
+ (if (and (characterp value)
+ (char-displayable-p value))
+ (prin1-char value))))
+ (if char-string
+ (format " (#o%o, #x%x, %s)" value value char-string)
+ (format " (#o%o, #x%x)" value value)))))
+
+ (defvar eval-expression-minibuffer-setup-hook nil
+ "Hook run by `eval-expression' when entering the minibuffer.")
+
+ (defun read--expression (prompt &optional initial-contents)
+ (let ((minibuffer-completing-symbol t))
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (add-hook 'completion-at-point-functions
+ #'lisp-completion-at-point nil t)
+ (run-hooks 'eval-expression-minibuffer-setup-hook))
+ (read-from-minibuffer prompt initial-contents
+ read-expression-map t
+ 'read-expression-history))))
+
+ ;; We define this, rather than making `eval' interactive,
+ ;; for the sake of completion of names like eval-region, eval-buffer.
+ (defun eval-expression (exp &optional insert-value)
+ "Evaluate EXP and print value in the echo area.
+ When called interactively, read an Emacs Lisp expression and evaluate it.
+ Value is also consed on to front of the variable `values'.
+ Optional argument INSERT-VALUE non-nil (interactively, with prefix
+ argument) means insert the result into the current buffer instead of
+ printing it in the echo area.
+
+ Normally, this function truncates long output according to the value
+ of the variables `eval-expression-print-length' and
+ `eval-expression-print-level'. With a prefix argument of zero,
+ however, there is no such truncation. Such a prefix argument
+ also causes integers to be printed in several additional formats
+ \(octal, hexadecimal, and character).
+
+ Runs the hook `eval-expression-minibuffer-setup-hook' on entering the
+ minibuffer.
+
+ If `eval-expression-debug-on-error' is non-nil, which is the default,
+ this command arranges for all errors to enter the debugger."
+ (interactive
+ (list (read--expression "Eval: ")
+ current-prefix-arg))
+
+ (if (null eval-expression-debug-on-error)
+ (push (eval exp lexical-binding) values)
+ (let ((old-value (make-symbol "t")) new-value)
+ ;; Bind debug-on-error to something unique so that we can
+ ;; detect when evalled code changes it.
+ (let ((debug-on-error old-value))
+ (push (eval exp lexical-binding) values)
+ (setq new-value debug-on-error))
+ ;; If evalled 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 (and (not (zerop (prefix-numeric-value insert-value)))
+ eval-expression-print-length))
+ (print-level (and (not (zerop (prefix-numeric-value insert-value)))
+ eval-expression-print-level))
+ (deactivate-mark))
+ (if insert-value
+ (with-no-warnings
+ (let ((standard-output (current-buffer)))
+ (prog1
+ (prin1 (car values))
+ (when (zerop (prefix-numeric-value insert-value))
+ (let ((str (eval-expression-print-format (car values))))
+ (if str (princ str)))))))
+ (prog1
+ (prin1 (car values) t)
+ (let ((str (eval-expression-print-format (car values))))
+ (if str (princ str t)))))))
+
+ (defun edit-and-eval-command (prompt command)
+ "Prompting with PROMPT, let user edit COMMAND and eval result.
+ COMMAND is a Lisp expression. Let user edit that expression in
+ the minibuffer, then read and evaluate the result."
+ (let ((command
+ (let ((print-level nil)
+ (minibuffer-history-sexp-flag (1+ (minibuffer-depth))))
+ (unwind-protect
+ (read-from-minibuffer prompt
+ (prin1-to-string command)
+ read-expression-map t
+ 'command-history)
+ ;; If command was added to command-history as a string,
+ ;; get rid of that. We want only evaluable expressions there.
+ (if (stringp (car command-history))
+ (setq command-history (cdr command-history)))))))
+
+ ;; If command to be redone does not match front of history,
+ ;; add it to the history.
+ (or (equal command (car command-history))
+ (setq command-history (cons command command-history)))
+ (eval command)))
+
+ (defun repeat-complex-command (arg)
+ "Edit and re-evaluate last complex command, or ARGth from last.
+ A complex command is one which used the minibuffer.
+ The command is placed in the minibuffer as a Lisp form for editing.
+ The result is executed, repeating the command as changed.
+ If the command has been changed or is not the most recent previous
+ command it is added to the front of the command history.
+ You can use the minibuffer history commands \
+ \\<minibuffer-local-map>\\[next-history-element] and \\[previous-history-element]
+ to get different commands to edit and resubmit."
+ (interactive "p")
+ (let ((elt (nth (1- arg) command-history))
+ newcmd)
+ (if elt
+ (progn
+ (setq newcmd
+ (let ((print-level nil)
+ (minibuffer-history-position arg)
+ (minibuffer-history-sexp-flag (1+ (minibuffer-depth))))
+ (unwind-protect
+ (read-from-minibuffer
+ "Redo: " (prin1-to-string elt) read-expression-map t
+ (cons 'command-history arg))
+
+ ;; If command was added to command-history as a
+ ;; string, get rid of that. We want only
+ ;; evaluable expressions there.
+ (if (stringp (car command-history))
+ (setq command-history (cdr command-history))))))
+
+ ;; If command to be redone does not match front of history,
+ ;; add it to the history.
+ (or (equal newcmd (car command-history))
+ (setq command-history (cons newcmd command-history)))
+ (unwind-protect
+ (progn
+ ;; Trick called-interactively-p into thinking that `newcmd' is
+ ;; an interactive call (bug#14136).
+ (add-hook 'called-interactively-p-functions
+ #'repeat-complex-command--called-interactively-skip)
+ (eval newcmd))
+ (remove-hook 'called-interactively-p-functions
+ #'repeat-complex-command--called-interactively-skip)))
+ (if command-history
+ (error "Argument %d is beyond length of command history" arg)
+ (error "There are no previous complex commands to repeat")))))
+
+ (defun repeat-complex-command--called-interactively-skip (i _frame1 frame2)
+ (and (eq 'eval (cadr frame2))
+ (eq 'repeat-complex-command
+ (cadr (backtrace-frame i #'called-interactively-p)))
+ 1))
+
+ (defvar extended-command-history nil)
+
+ (defun read-extended-command ()
+ "Read command name to invoke in `execute-extended-command'."
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (set (make-local-variable 'minibuffer-default-add-function)
+ (lambda ()
+ ;; Get a command name at point in the original buffer
+ ;; to propose it after M-n.
+ (with-current-buffer (window-buffer (minibuffer-selected-window))
+ (and (commandp (function-called-at-point))
+ (format "%S" (function-called-at-point)))))))
+ ;; Read a string, completing from and restricting to the set of
+ ;; all defined commands. Don't provide any initial input.
+ ;; Save the command read on the extended-command history list.
+ (completing-read
+ (concat (cond
+ ((eq current-prefix-arg '-) "- ")
+ ((and (consp current-prefix-arg)
+ (eq (car current-prefix-arg) 4)) "C-u ")
+ ((and (consp current-prefix-arg)
+ (integerp (car current-prefix-arg)))
+ (format "%d " (car current-prefix-arg)))
+ ((integerp current-prefix-arg)
+ (format "%d " current-prefix-arg)))
+ ;; This isn't strictly correct if `execute-extended-command'
+ ;; is bound to anything else (e.g. [menu]).
+ ;; It could use (key-description (this-single-command-keys)),
+ ;; but actually a prompt other than "M-x" would be confusing,
+ ;; because "M-x" is a well-known prompt to read a command
+ ;; and it serves as a shorthand for "Extended command: ".
+ "M-x ")
+ obarray 'commandp t nil 'extended-command-history)))
+
+ (defcustom suggest-key-bindings t
+ "Non-nil means show the equivalent key-binding when M-x command has one.
+ The value can be a length of time to show the message for.
+ If the value is non-nil and not a number, we wait 2 seconds."
+ :group 'keyboard
+ :type '(choice (const :tag "off" nil)
+ (integer :tag "time" 2)
+ (other :tag "on")))
+
+ (defun execute-extended-command (prefixarg &optional command-name)
+ ;; Based on Fexecute_extended_command in keyboard.c of Emacs.
+ ;; Aaron S. Hawley <aaron.s.hawley(at)gmail.com> 2009-08-24
+ "Read a command name, then read the arguments and call the command.
+ Interactively, to pass a prefix argument to the command you are
+ invoking, give a prefix argument to `execute-extended-command'.
+ Noninteractively, the argument PREFIXARG is the prefix argument to
+ give to the command you invoke."
+ (interactive (list current-prefix-arg (read-extended-command)))
+ ;; Emacs<24 calling-convention was with a single `prefixarg' argument.
+ (if (null command-name)
+ (setq command-name (let ((current-prefix-arg prefixarg)) ; for prompt
+ (read-extended-command))))
+ (let* ((function (and (stringp command-name) (intern-soft command-name)))
+ (binding (and suggest-key-bindings
+ (not executing-kbd-macro)
+ (where-is-internal function overriding-local-map t))))
+ (unless (commandp function)
+ (error "`%s' is not a valid command name" command-name))
+ (setq this-command function)
+ ;; Normally `real-this-command' should never be changed, but here we really
+ ;; want to pretend that M-x <cmd> RET is nothing more than a "key
+ ;; binding" for <cmd>, so the command the user really wanted to run is
+ ;; `function' and not `execute-extended-command'. The difference is
+ ;; visible in cases such as M-x <cmd> RET and then C-x z (bug#11506).
+ (setq real-this-command function)
+ (let ((prefix-arg prefixarg))
+ (command-execute function 'record))
+ ;; If enabled, show which key runs this command.
+ (when binding
+ ;; But first wait, and skip the message if there is input.
+ (let* ((waited
+ ;; If this command displayed something in the echo area;
+ ;; wait a few seconds, then display our suggestion message.
+ (sit-for (cond
+ ((zerop (length (current-message))) 0)
+ ((numberp suggest-key-bindings) suggest-key-bindings)
+ (t 2)))))
+ (when (and waited (not (consp unread-command-events)))
+ (with-temp-message
+ (format "You can run the command `%s' with %s"
+ function (key-description binding))
+ (sit-for (if (numberp suggest-key-bindings)
+ suggest-key-bindings
+ 2))))))))
+
+ (defun command-execute (cmd &optional record-flag keys special)
+ ;; BEWARE: Called directly from the C code.
+ "Execute CMD as an editor command.
+ CMD must be a symbol that satisfies the `commandp' predicate.
+ Optional second arg RECORD-FLAG non-nil
+ means unconditionally put this command in the variable `command-history'.
+ Otherwise, that is done only if an arg is read using the minibuffer.
+ The argument KEYS specifies the value to use instead of (this-command-keys)
+ when reading the arguments; if it is nil, (this-command-keys) is used.
+ The argument SPECIAL, if non-nil, means that this command is executing
+ a special event, so ignore the prefix argument and don't clear it."
+ (setq debug-on-next-call nil)
+ (let ((prefixarg (unless special
+ (prog1 prefix-arg
+ (setq current-prefix-arg prefix-arg)
+ (setq prefix-arg nil)))))
+ (if (and (symbolp cmd)
+ (get cmd 'disabled)
+ disabled-command-function)
+ ;; FIXME: Weird calling convention!
+ (run-hooks 'disabled-command-function)
+ (let ((final cmd))
+ (while
+ (progn
+ (setq final (indirect-function final))
+ (if (autoloadp final)
+ (setq final (autoload-do-load final cmd)))))
+ (cond
+ ((arrayp final)
+ ;; If requested, place the macro in the command history. For
+ ;; other sorts of commands, call-interactively takes care of this.
+ (when record-flag
+ (push `(execute-kbd-macro ,final ,prefixarg) command-history)
+ ;; Don't keep command history around forever.
+ (when (and (numberp history-length) (> history-length 0))
+ (let ((cell (nthcdr history-length command-history)))
+ (if (consp cell) (setcdr cell nil)))))
+ (execute-kbd-macro final prefixarg))
+ (t
+ ;; Pass `cmd' rather than `final', for the backtrace's sake.
+ (prog1 (call-interactively cmd record-flag keys)
+ (when (and (symbolp cmd)
+ (get cmd 'byte-obsolete-info)
+ (not (get cmd 'command-execute-obsolete-warned)))
+ (put cmd 'command-execute-obsolete-warned t)
+ (message "%s" (macroexp--obsolete-warning
+ cmd (get cmd 'byte-obsolete-info) "command"))))))))))
+ \f
+ (defvar minibuffer-history nil
+ "Default minibuffer history list.
+ This is used for all minibuffer input
+ except when an alternate history list is specified.
+
+ Maximum length of the history list is determined by the value
+ of `history-length', which see.")
+ (defvar minibuffer-history-sexp-flag nil
+ "Control whether history list elements are expressions or strings.
+ If the value of this variable equals current minibuffer depth,
+ they are expressions; otherwise they are strings.
+ \(That convention is designed to do the right thing for
+ recursive uses of the minibuffer.)")
+ (setq minibuffer-history-variable 'minibuffer-history)
+ (setq minibuffer-history-position nil) ;; Defvar is in C code.
+ (defvar minibuffer-history-search-history nil)
+
+ (defvar minibuffer-text-before-history nil
+ "Text that was in this minibuffer before any history commands.
+ This is nil if there have not yet been any history commands
+ in this use of the minibuffer.")
+
+ (add-hook 'minibuffer-setup-hook 'minibuffer-history-initialize)
+
+ (defun minibuffer-history-initialize ()
+ (setq minibuffer-text-before-history nil))
+
+ (defun minibuffer-avoid-prompt (_new _old)
+ "A point-motion hook for the minibuffer, that moves point out of the prompt."
+ (constrain-to-field nil (point-max)))
+
+ (defcustom minibuffer-history-case-insensitive-variables nil
+ "Minibuffer history variables for which matching should ignore case.
+ If a history variable is a member of this list, then the
+ \\[previous-matching-history-element] and \\[next-matching-history-element]\
+ commands ignore case when searching it, regardless of `case-fold-search'."
+ :type '(repeat variable)
+ :group 'minibuffer)
+
+ (defun previous-matching-history-element (regexp n)
+ "Find the previous history element that matches REGEXP.
+ \(Previous history elements refer to earlier actions.)
+ With prefix argument N, search for Nth previous match.
+ If N is negative, find the next or Nth next match.
+ Normally, history elements are matched case-insensitively if
+ `case-fold-search' is non-nil, but an uppercase letter in REGEXP
+ makes the search case-sensitive.
+ See also `minibuffer-history-case-insensitive-variables'."
+ (interactive
+ (let* ((enable-recursive-minibuffers t)
+ (regexp (read-from-minibuffer "Previous element matching (regexp): "
+ nil
+ minibuffer-local-map
+ nil
+ 'minibuffer-history-search-history
+ (car minibuffer-history-search-history))))
+ ;; Use the last regexp specified, by default, if input is empty.
+ (list (if (string= regexp "")
+ (if minibuffer-history-search-history
+ (car minibuffer-history-search-history)
+ (user-error "No previous history search regexp"))
+ regexp)
+ (prefix-numeric-value current-prefix-arg))))
+ (unless (zerop n)
+ (if (and (zerop minibuffer-history-position)
+ (null minibuffer-text-before-history))
+ (setq minibuffer-text-before-history
+ (minibuffer-contents-no-properties)))
+ (let ((history (symbol-value minibuffer-history-variable))
+ (case-fold-search
+ (if (isearch-no-upper-case-p regexp t) ; assume isearch.el is dumped
+ ;; On some systems, ignore case for file names.
+ (if (memq minibuffer-history-variable
+ minibuffer-history-case-insensitive-variables)
+ t
+ ;; Respect the user's setting for case-fold-search:
+ case-fold-search)
+ nil))
+ prevpos
+ match-string
+ match-offset
+ (pos minibuffer-history-position))
+ (while (/= n 0)
+ (setq prevpos pos)
+ (setq pos (min (max 1 (+ pos (if (< n 0) -1 1))) (length history)))
+ (when (= pos prevpos)
+ (user-error (if (= pos 1)
+ "No later matching history item"
+ "No earlier matching history item")))
+ (setq match-string
+ (if (eq minibuffer-history-sexp-flag (minibuffer-depth))
+ (let ((print-level nil))
+ (prin1-to-string (nth (1- pos) history)))
+ (nth (1- pos) history)))
+ (setq match-offset
+ (if (< n 0)
+ (and (string-match regexp match-string)
+ (match-end 0))
+ (and (string-match (concat ".*\\(" regexp "\\)") match-string)
+ (match-beginning 1))))
+ (when match-offset
+ (setq n (+ n (if (< n 0) 1 -1)))))
+ (setq minibuffer-history-position pos)
+ (goto-char (point-max))
+ (delete-minibuffer-contents)
+ (insert match-string)
+ (goto-char (+ (minibuffer-prompt-end) match-offset))))
+ (if (memq (car (car command-history)) '(previous-matching-history-element
+ next-matching-history-element))
+ (setq command-history (cdr command-history))))
+
+ (defun next-matching-history-element (regexp n)
+ "Find the next history element that matches REGEXP.
+ \(The next history element refers to a more recent action.)
+ With prefix argument N, search for Nth next match.
+ If N is negative, find the previous or Nth previous match.
+ Normally, history elements are matched case-insensitively if
+ `case-fold-search' is non-nil, but an uppercase letter in REGEXP
+ makes the search case-sensitive."
+ (interactive
+ (let* ((enable-recursive-minibuffers t)
+ (regexp (read-from-minibuffer "Next element matching (regexp): "
+ nil
+ minibuffer-local-map
+ nil
+ 'minibuffer-history-search-history
+ (car minibuffer-history-search-history))))
+ ;; Use the last regexp specified, by default, if input is empty.
+ (list (if (string= regexp "")
+ (if minibuffer-history-search-history
+ (car minibuffer-history-search-history)
+ (user-error "No previous history search regexp"))
+ regexp)
+ (prefix-numeric-value current-prefix-arg))))
+ (previous-matching-history-element regexp (- n)))
+
+ (defvar minibuffer-temporary-goal-position nil)
+
+ (defvar minibuffer-default-add-function 'minibuffer-default-add-completions
+ "Function run by `goto-history-element' before consuming default values.
+ This is useful to dynamically add more elements to the list of default values
+ when `goto-history-element' reaches the end of this list.
+ Before calling this function `goto-history-element' sets the variable
+ `minibuffer-default-add-done' to t, so it will call this function only
+ once. In special cases, when this function needs to be called more
+ than once, it can set `minibuffer-default-add-done' to nil explicitly,
+ overriding the setting of this variable to t in `goto-history-element'.")
+
+ (defvar minibuffer-default-add-done nil
+ "When nil, add more elements to the end of the list of default values.
+ The value nil causes `goto-history-element' to add more elements to
+ the list of defaults when it reaches the end of this list. It does
+ this by calling a function defined by `minibuffer-default-add-function'.")
+
+ (make-variable-buffer-local 'minibuffer-default-add-done)
+
+ (defun minibuffer-default-add-completions ()
+ "Return a list of all completions without the default value.
+ This function is used to add all elements of the completion table to
+ the end of the list of defaults just after the default value."
+ (let ((def minibuffer-default)
+ (all (all-completions ""
+ minibuffer-completion-table
+ minibuffer-completion-predicate)))
+ (if (listp def)
+ (append def all)
+ (cons def (delete def all)))))
+
+ (defun goto-history-element (nabs)
+ "Puts element of the minibuffer history in the minibuffer.
+ The argument NABS specifies the absolute history position."
+ (interactive "p")
+ (when (and (not minibuffer-default-add-done)
+ (functionp minibuffer-default-add-function)
+ (< nabs (- (if (listp minibuffer-default)
+ (length minibuffer-default)
+ 1))))
+ (setq minibuffer-default-add-done t
+ minibuffer-default (funcall minibuffer-default-add-function)))
+ (let ((minimum (if minibuffer-default
+ (- (if (listp minibuffer-default)
+ (length minibuffer-default)
+ 1))
+ 0))
+ elt minibuffer-returned-to-present)
+ (if (and (zerop minibuffer-history-position)
+ (null minibuffer-text-before-history))
+ (setq minibuffer-text-before-history
+ (minibuffer-contents-no-properties)))
+ (if (< nabs minimum)
+ (user-error (if minibuffer-default
+ "End of defaults; no next item"
+ "End of history; no default available")))
+ (if (> nabs (length (symbol-value minibuffer-history-variable)))
+ (user-error "Beginning of history; no preceding item"))
+ (unless (memq last-command '(next-history-element
+ previous-history-element))
+ (let ((prompt-end (minibuffer-prompt-end)))
+ (set (make-local-variable 'minibuffer-temporary-goal-position)
+ (cond ((<= (point) prompt-end) prompt-end)
+ ((eobp) nil)
+ (t (point))))))
+ (goto-char (point-max))
+ (delete-minibuffer-contents)
+ (setq minibuffer-history-position nabs)
+ (cond ((< nabs 0)
+ (setq elt (if (listp minibuffer-default)
+ (nth (1- (abs nabs)) minibuffer-default)
+ minibuffer-default)))
+ ((= nabs 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 (and (eq minibuffer-history-sexp-flag (minibuffer-depth))
+ (not minibuffer-returned-to-present))
+ (let ((print-level nil))
+ (prin1-to-string elt))
+ elt))
+ (goto-char (or minibuffer-temporary-goal-position (point-max)))))
+
+ (defun next-history-element (n)
+ "Puts next element of the minibuffer history in the minibuffer.
+ With argument N, it uses the Nth following element."
+ (interactive "p")
+ (or (zerop n)
+ (goto-history-element (- minibuffer-history-position n))))
+
+ (defun previous-history-element (n)
+ "Puts previous element of the minibuffer history in the minibuffer.
+ With argument N, it uses the Nth previous element."
+ (interactive "p")
+ (or (zerop n)
+ (goto-history-element (+ minibuffer-history-position n))))
+
+ (defun next-complete-history-element (n)
+ "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 (minibuffer-prompt-end) (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 sensible, because the text before point has not changed.
+ (goto-char point-at-start)))
+
+ (defun previous-complete-history-element (n)
+ "\
+ 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)))
+
+ ;; For compatibility with the old subr of the same name.
+ (defun minibuffer-prompt-width ()
+ "Return the display width of the minibuffer prompt.
+ Return 0 if current buffer is not a minibuffer."
+ ;; Return the width of everything before the field at the end of
+ ;; the buffer; this should be 0 for normal buffers.
+ (1- (minibuffer-prompt-end)))
+ \f
+ ;; isearch minibuffer history
+ (add-hook 'minibuffer-setup-hook 'minibuffer-history-isearch-setup)
+
+ (defvar minibuffer-history-isearch-message-overlay)
+ (make-variable-buffer-local 'minibuffer-history-isearch-message-overlay)
+
+ (defun minibuffer-history-isearch-setup ()
+ "Set up a minibuffer for using isearch to search the minibuffer history.
+ Intended to be added to `minibuffer-setup-hook'."
+ (set (make-local-variable 'isearch-search-fun-function)
+ 'minibuffer-history-isearch-search)
+ (set (make-local-variable 'isearch-message-function)
+ 'minibuffer-history-isearch-message)
+ (set (make-local-variable 'isearch-wrap-function)
+ 'minibuffer-history-isearch-wrap)
+ (set (make-local-variable 'isearch-push-state-function)
+ 'minibuffer-history-isearch-push-state)
+ (add-hook 'isearch-mode-end-hook 'minibuffer-history-isearch-end nil t))
+
+ (defun minibuffer-history-isearch-end ()
+ "Clean up the minibuffer after terminating isearch in the minibuffer."
+ (if minibuffer-history-isearch-message-overlay
+ (delete-overlay minibuffer-history-isearch-message-overlay)))
+
+ (defun minibuffer-history-isearch-search ()
+ "Return the proper search function, for isearch in minibuffer history."
+ (lambda (string bound noerror)
+ (let ((search-fun
+ ;; Use standard functions to search within minibuffer text
+ (isearch-search-fun-default))
+ found)
+ ;; Avoid lazy-highlighting matches in the minibuffer prompt when
+ ;; searching forward. Lazy-highlight calls this lambda with the
+ ;; bound arg, so skip the minibuffer prompt.
+ (if (and bound isearch-forward (< (point) (minibuffer-prompt-end)))
+ (goto-char (minibuffer-prompt-end)))
+ (or
+ ;; 1. First try searching in the initial minibuffer text
+ (funcall search-fun string
+ (if isearch-forward bound (minibuffer-prompt-end))
+ noerror)
+ ;; 2. If the above search fails, start putting next/prev history
+ ;; elements in the minibuffer successively, and search the string
+ ;; in them. Do this only when bound is nil (i.e. not while
+ ;; lazy-highlighting search strings in the current minibuffer text).
+ (unless bound
+ (condition-case nil
+ (progn
+ (while (not found)
+ (cond (isearch-forward
+ (next-history-element 1)
+ (goto-char (minibuffer-prompt-end)))
+ (t
+ (previous-history-element 1)
+ (goto-char (point-max))))
+ (setq isearch-barrier (point) isearch-opoint (point))
+ ;; After putting the next/prev history element, search
+ ;; the string in them again, until next-history-element
+ ;; or previous-history-element raises an error at the
+ ;; beginning/end of history.
+ (setq found (funcall search-fun string
+ (unless isearch-forward
+ ;; For backward search, don't search
+ ;; in the minibuffer prompt
+ (minibuffer-prompt-end))
+ noerror)))
+ ;; Return point of the new search result
+ (point))
+ ;; Return nil when next(prev)-history-element fails
+ (error nil)))))))
+
+ (defun minibuffer-history-isearch-message (&optional c-q-hack ellipsis)
+ "Display the minibuffer history search prompt.
+ If there are no search errors, this function displays an overlay with
+ the isearch prompt which replaces the original minibuffer prompt.
+ Otherwise, it displays the standard isearch message returned from
+ the function `isearch-message'."
+ (if (not (and (minibufferp) isearch-success (not isearch-error)))
+ ;; Use standard function `isearch-message' when not in the minibuffer,
+ ;; or search fails, or has an error (like incomplete regexp).
+ ;; This function overwrites minibuffer text with isearch message,
+ ;; so it's possible to see what is wrong in the search string.
+ (isearch-message c-q-hack ellipsis)
+ ;; Otherwise, put the overlay with the standard isearch prompt over
+ ;; the initial minibuffer prompt.
+ (if (overlayp minibuffer-history-isearch-message-overlay)
+ (move-overlay minibuffer-history-isearch-message-overlay
+ (point-min) (minibuffer-prompt-end))
+ (setq minibuffer-history-isearch-message-overlay
+ (make-overlay (point-min) (minibuffer-prompt-end)))
+ (overlay-put minibuffer-history-isearch-message-overlay 'evaporate t))
+ (overlay-put minibuffer-history-isearch-message-overlay
+ 'display (isearch-message-prefix c-q-hack ellipsis))
+ ;; And clear any previous isearch message.
+ (message "")))
+
+ (defun minibuffer-history-isearch-wrap ()
+ "Wrap the minibuffer history search when search fails.
+ Move point to the first history element for a forward search,
+ or to the last history element for a backward search."
+ ;; When `minibuffer-history-isearch-search' fails on reaching the
+ ;; beginning/end of the history, wrap the search to the first/last
+ ;; minibuffer history element.
+ (if isearch-forward
+ (goto-history-element (length (symbol-value minibuffer-history-variable)))
+ (goto-history-element 0))
+ (setq isearch-success t)
+ (goto-char (if isearch-forward (minibuffer-prompt-end) (point-max))))
+
+ (defun minibuffer-history-isearch-push-state ()
+ "Save a function restoring the state of minibuffer history search.
+ Save `minibuffer-history-position' to the additional state parameter
+ in the search status stack."
+ (let ((pos minibuffer-history-position))
+ (lambda (cmd)
+ (minibuffer-history-isearch-pop-state cmd pos))))
+
+ (defun minibuffer-history-isearch-pop-state (_cmd hist-pos)
+ "Restore the minibuffer history search state.
+ Go to the history element by the absolute history position HIST-POS."
+ (goto-history-element hist-pos))
+
+ \f
+ ;Put this on C-x u, so we can force that rather than C-_ into startup msg
+ (define-obsolete-function-alias 'advertised-undo 'undo "23.2")
+
+ (defconst undo-equiv-table (make-hash-table :test 'eq :weakness t)
+ "Table mapping redo records to the corresponding undo one.
+ A redo record for undo-in-region maps to t.
+ A redo record for ordinary undo maps to the following (earlier) undo.")
+
+ (defvar undo-in-region nil
+ "Non-nil if `pending-undo-list' is not just a tail of `buffer-undo-list'.")
+
+ (defvar undo-no-redo nil
+ "If t, `undo' doesn't go through redo entries.")
+
+ (defvar pending-undo-list nil
+ "Within a run of consecutive undo commands, list remaining to be undone.
+ If t, we undid all the way to the end of it.")
+
+ (defun undo (&optional arg)
+ "Undo some previous changes.
+ Repeat this command to undo more changes.
+ A numeric ARG serves as a repeat count.
+
+ In Transient Mark mode when the mark is active, only undo changes within
+ the current region. Similarly, when not in Transient Mark mode, just \\[universal-argument]
+ as an argument limits undo to changes within the current region."
+ (interactive "*P")
+ ;; Make last-command indicate for the next command that this was an undo.
+ ;; That way, another undo will undo more.
+ ;; If we get to the end of the undo history and get an error,
+ ;; another undo command will find the undo history empty
+ ;; and will get another error. To begin undoing the undos,
+ ;; you must type some other command.
+ (let* ((modified (buffer-modified-p))
+ ;; For an indirect buffer, look in the base buffer for the
+ ;; auto-save data.
+ (base-buffer (or (buffer-base-buffer) (current-buffer)))
+ (recent-save (with-current-buffer base-buffer
+ (recent-auto-save-p)))
+ message)
+ ;; If we get an error in undo-start,
+ ;; the next command should not be a "consecutive undo".
+ ;; So set `this-command' to something other than `undo'.
+ (setq this-command 'undo-start)
+
+ (unless (and (eq last-command 'undo)
+ (or (eq pending-undo-list t)
+ ;; If something (a timer or filter?) changed the buffer
+ ;; since the previous command, don't continue the undo seq.
+ (let ((list buffer-undo-list))
+ (while (eq (car list) nil)
+ (setq list (cdr list)))
+ ;; If the last undo record made was made by undo
+ ;; it shows nothing else happened in between.
+ (gethash list undo-equiv-table))))
+ (setq undo-in-region
+ (or (region-active-p) (and arg (not (numberp arg)))))
+ (if undo-in-region
+ (undo-start (region-beginning) (region-end))
+ (undo-start))
+ ;; get rid of initial undo boundary
+ (undo-more 1))
+ ;; If we got this far, the next command should be a consecutive undo.
+ (setq this-command 'undo)
+ ;; Check to see whether we're hitting a redo record, and if
+ ;; so, ask the user whether she wants to skip the redo/undo pair.
+ (let ((equiv (gethash pending-undo-list undo-equiv-table)))
+ (or (eq (selected-window) (minibuffer-window))
+ (setq message (format "%s%s!"
+ (if (or undo-no-redo (not equiv))
+ "Undo" "Redo")
+ (if undo-in-region " in region" ""))))
+ (when (and (consp equiv) undo-no-redo)
+ ;; The equiv entry might point to another redo record if we have done
+ ;; undo-redo-undo-redo-... so skip to the very last equiv.
+ (while (let ((next (gethash equiv undo-equiv-table)))
+ (if next (setq equiv next))))
+ (setq pending-undo-list equiv)))
+ (undo-more
+ (if (numberp arg)
+ (prefix-numeric-value arg)
+ 1))
+ ;; Record the fact that the just-generated undo records come from an
+ ;; undo operation--that is, they are redo records.
+ ;; In the ordinary case (not within a region), map the redo
+ ;; record to the following undos.
+ ;; I don't know how to do that in the undo-in-region case.
+ (let ((list buffer-undo-list))
+ ;; Strip any leading undo boundaries there might be, like we do
+ ;; above when checking.
+ (while (eq (car list) nil)
+ (setq list (cdr list)))
+ (puthash list
+ ;; Prevent identity mapping. This can happen if
+ ;; consecutive nils are erroneously in undo list.
+ (if (or undo-in-region (eq list pending-undo-list))
+ t
+ pending-undo-list)
+ undo-equiv-table))
+ ;; Don't specify a position in the undo record for the undo command.
+ ;; Instead, undoing this should move point to where the change is.
+ (let ((tail buffer-undo-list)
+ (prev nil))
+ (while (car tail)
+ (when (integerp (car tail))
+ (let ((pos (car tail)))
+ (if prev
+ (setcdr prev (cdr tail))
+ (setq buffer-undo-list (cdr tail)))
+ (setq tail (cdr tail))
+ (while (car tail)
+ (if (eq pos (car tail))
+ (if prev
+ (setcdr prev (cdr tail))
+ (setq buffer-undo-list (cdr tail)))
+ (setq prev tail))
+ (setq tail (cdr tail)))
+ (setq tail nil)))
+ (setq prev tail tail (cdr tail))))
+ ;; Record what the current undo list says,
+ ;; so the next command can tell if the buffer was modified in between.
+ (and modified (not (buffer-modified-p))
+ (with-current-buffer base-buffer
+ (delete-auto-save-file-if-necessary recent-save)))
+ ;; Display a message announcing success.
+ (if message
+ (message "%s" message))))
+
+ (defun buffer-disable-undo (&optional buffer)
+ "Make BUFFER stop keeping undo information.
+ No argument or nil as argument means do this for the current buffer."
+ (interactive)
+ (with-current-buffer (if buffer (get-buffer buffer) (current-buffer))
+ (setq buffer-undo-list t)))
+
+ (defun undo-only (&optional arg)
+ "Undo some previous changes.
+ Repeat this command to undo more changes.
+ A numeric ARG serves as a repeat count.
+ Contrary to `undo', this will not redo a previous undo."
+ (interactive "*p")
+ (let ((undo-no-redo t)) (undo arg)))
+
+ (defvar undo-in-progress nil
+ "Non-nil while performing an undo.
+ Some change-hooks test this variable to do something different.")
+
+ (defun undo-more (n)
+ "Undo back N undo-boundaries beyond what was already undone recently.
+ Call `undo-start' to get ready to undo recent changes,
+ then call `undo-more' one or more times to undo them."
+ (or (listp pending-undo-list)
+ (user-error (concat "No further undo information"
+ (and undo-in-region " for region"))))
+ (let ((undo-in-progress t))
+ ;; Note: The following, while pulling elements off
+ ;; `pending-undo-list' will call primitive change functions which
+ ;; will push more elements onto `buffer-undo-list'.
+ (setq pending-undo-list (primitive-undo n pending-undo-list))
+ (if (null pending-undo-list)
+ (setq pending-undo-list t))))
+
+ (defun primitive-undo (n list)
+ "Undo N records from the front of the list LIST.
+ Return what remains of the list."
+
+ ;; This is a good feature, but would make undo-start
+ ;; unable to do what is expected.
+ ;;(when (null (car (list)))
+ ;; ;; If the head of the list is a boundary, it is the boundary
+ ;; ;; preceding this command. Get rid of it and don't count it.
+ ;; (setq list (cdr list))))
+
+ (let ((arg n)
+ ;; In a writable buffer, enable undoing read-only text that is
+ ;; so because of text properties.
+ (inhibit-read-only t)
+ ;; Don't let `intangible' properties interfere with undo.
+ (inhibit-point-motion-hooks t)
+ ;; We use oldlist only to check for EQ. ++kfs
+ (oldlist buffer-undo-list)
+ (did-apply nil)
+ (next nil))
+ (while (> arg 0)
+ (while (setq next (pop list)) ;Exit inner loop at undo boundary.
+ ;; Handle an integer by setting point to that value.
+ (pcase next
+ ((pred integerp) (goto-char next))
+ ;; Element (t . TIME) records previous modtime.
+ ;; Preserve any flag of NONEXISTENT_MODTIME_NSECS or
+ ;; UNKNOWN_MODTIME_NSECS.
+ (`(t . ,time)
+ ;; If this records an obsolete save
+ ;; (not matching the actual disk file)
+ ;; then don't mark unmodified.
+ (when (or (equal time (visited-file-modtime))
+ (and (consp time)
+ (equal (list (car time) (cdr time))
+ (visited-file-modtime))))
+ (when (fboundp 'unlock-buffer)
+ (unlock-buffer))
+ (set-buffer-modified-p nil)))
+ ;; Element (nil PROP VAL BEG . END) is property change.
+ (`(nil . ,(or `(,prop ,val ,beg . ,end) pcase--dontcare))
+ (when (or (> (point-min) beg) (< (point-max) end))
+ (error "Changes to be undone are outside visible portion of buffer"))
+ (put-text-property beg end prop val))
+ ;; Element (BEG . END) means range was inserted.
+ (`(,(and beg (pred integerp)) . ,(and end (pred integerp)))
+ ;; (and `(,beg . ,end) `(,(pred integerp) . ,(pred integerp)))
+ ;; Ideally: `(,(pred integerp beg) . ,(pred integerp end))
+ (when (or (> (point-min) beg) (< (point-max) end))
+ (error "Changes to be undone are outside visible portion of buffer"))
+ ;; Set point first thing, so that undoing this undo
+ ;; does not send point back to where it is now.
+ (goto-char beg)
+ (delete-region beg end))
+ ;; Element (apply FUN . ARGS) means call FUN to undo.
+ (`(apply . ,fun-args)
+ (let ((currbuff (current-buffer)))
+ (if (integerp (car fun-args))
+ ;; Long format: (apply DELTA START END FUN . ARGS).
+ (pcase-let* ((`(,delta ,start ,end ,fun . ,args) fun-args)
+ (start-mark (copy-marker start nil))
+ (end-mark (copy-marker end t)))
+ (when (or (> (point-min) start) (< (point-max) end))
+ (error "Changes to be undone are outside visible portion of buffer"))
+ (apply fun args) ;; Use `save-current-buffer'?
+ ;; Check that the function did what the entry
+ ;; said it would do.
+ (unless (and (= start start-mark)
+ (= (+ delta end) end-mark))
+ (error "Changes to be undone by function different than announced"))
+ (set-marker start-mark nil)
+ (set-marker end-mark nil))
+ (apply fun-args))
+ (unless (eq currbuff (current-buffer))
+ (error "Undo function switched buffer"))
+ (setq did-apply t)))
+ ;; Element (STRING . POS) means STRING was deleted.
+ (`(,(and string (pred stringp)) . ,(and pos (pred integerp)))
+ (when (let ((apos (abs pos)))
+ (or (< apos (point-min)) (> apos (point-max))))
+ (error "Changes to be undone are outside visible portion of buffer"))
+ (let (valid-marker-adjustments)
+ ;; Check that marker adjustments which were recorded
+ ;; with the (STRING . POS) record are still valid, ie
+ ;; the markers haven't moved. We check their validity
+ ;; before reinserting the string so as we don't need to
+ ;; mind marker insertion-type.
+ (while (and (markerp (car-safe (car list)))
+ (integerp (cdr-safe (car list))))
+ (let* ((marker-adj (pop list))
+ (m (car marker-adj)))
+ (and (eq (marker-buffer m) (current-buffer))
+ (= pos m)
+ (push marker-adj valid-marker-adjustments))))
+ ;; Insert string and adjust point
+ (if (< pos 0)
+ (progn
+ (goto-char (- pos))
+ (insert string))
+ (goto-char pos)
+ (insert string)
+ (goto-char pos))
+ ;; Adjust the valid marker adjustments
+ (dolist (adj valid-marker-adjustments)
+ (set-marker (car adj)
+ (- (car adj) (cdr adj))))))
+ ;; (MARKER . OFFSET) means a marker MARKER was adjusted by OFFSET.
+ (`(,(and marker (pred markerp)) . ,(and offset (pred integerp)))
+ (warn "Encountered %S entry in undo list with no matching (TEXT . POS) entry"
+ next)
+ ;; Even though these elements are not expected in the undo
+ ;; list, adjust them to be conservative for the 24.4
+ ;; release. (Bug#16818)
+ (when (marker-buffer marker)
+ (set-marker marker
+ (- marker offset)
+ (marker-buffer marker))))
+ (_ (error "Unrecognized entry in undo list %S" next))))
+ (setq arg (1- arg)))
+ ;; Make sure an apply entry produces at least one undo entry,
+ ;; so the test in `undo' for continuing an undo series
+ ;; will work right.
+ (if (and did-apply
+ (eq oldlist buffer-undo-list))
+ (setq buffer-undo-list
+ (cons (list 'apply 'cdr nil) buffer-undo-list))))
+ list)
+
+ ;; Deep copy of a list
+ (defun undo-copy-list (list)
+ "Make a copy of undo list LIST."
+ (mapcar 'undo-copy-list-1 list))
+
+ (defun undo-copy-list-1 (elt)
+ (if (consp elt)
+ (cons (car elt) (undo-copy-list-1 (cdr elt)))
+ elt))
+
+ (defun undo-start (&optional beg end)
+ "Set `pending-undo-list' to the front of the undo list.
+ The next call to `undo-more' will undo the most recently made change.
+ If BEG and END are specified, then only undo elements
+ that apply to text between BEG and END are used; other undo elements
+ are ignored. If BEG and END are nil, all undo elements are used."
+ (if (eq buffer-undo-list t)
+ (user-error "No undo information in this buffer"))
+ (setq pending-undo-list
+ (if (and beg end (not (= beg end)))
+ (undo-make-selective-list (min beg end) (max beg end))
+ buffer-undo-list)))
+
+ (defun undo-make-selective-list (start end)
+ "Return a list of undo elements for the region START to END.
+ The elements come from `buffer-undo-list', but we keep only
+ the elements inside this region, and discard those outside this region.
+ If we find an element that crosses an edge of this region,
+ we stop and ignore all further elements."
+ (let ((undo-list-copy (undo-copy-list buffer-undo-list))
+ (undo-list (list nil))
+ some-rejected
+ undo-elt temp-undo-list delta)
+ (while undo-list-copy
+ (setq undo-elt (car undo-list-copy))
+ (let ((keep-this
+ (cond ((and (consp undo-elt) (eq (car undo-elt) t))
+ ;; This is a "was unmodified" element.
+ ;; Keep it if we have kept everything thus far.
+ (not some-rejected))
+ ;; Skip over marker adjustments, instead relying on
+ ;; finding them after (TEXT . POS) elements
+ ((markerp (car-safe undo-elt))
+ nil)
+ (t
+ (undo-elt-in-region undo-elt start end)))))
+ (if keep-this
+ (progn
+ (setq end (+ end (cdr (undo-delta undo-elt))))
+ ;; Don't put two nils together in the list
+ (when (not (and (eq (car undo-list) nil)
+ (eq undo-elt nil)))
+ (setq undo-list (cons undo-elt undo-list))
+ ;; If (TEXT . POS), "keep" its subsequent (MARKER
+ ;; . ADJUSTMENT) whose markers haven't moved.
+ (when (and (stringp (car-safe undo-elt))
+ (integerp (cdr-safe undo-elt)))
+ (let ((list-i (cdr undo-list-copy)))
+ (while (markerp (car-safe (car list-i)))
+ (let* ((adj-elt (pop list-i))
+ (m (car adj-elt)))
+ (and (eq (marker-buffer m) (current-buffer))
+ (= (cdr undo-elt) m)
+ (push adj-elt undo-list))))))))
+ (if (undo-elt-crosses-region undo-elt start end)
+ (setq undo-list-copy nil)
+ (setq some-rejected t)
+ (setq temp-undo-list (cdr undo-list-copy))
+ (setq delta (undo-delta undo-elt))
+
+ (when (/= (cdr delta) 0)
+ (let ((position (car delta))
+ (offset (cdr delta)))
+
+ ;; Loop down the earlier events adjusting their buffer
+ ;; positions to reflect the fact that a change to the buffer
+ ;; isn't being undone. We only need to process those element
+ ;; types which undo-elt-in-region will return as being in
+ ;; the region since only those types can ever get into the
+ ;; output
+
+ (while temp-undo-list
+ (setq undo-elt (car temp-undo-list))
+ (cond ((integerp undo-elt)
+ (if (>= undo-elt position)
+ (setcar temp-undo-list (- undo-elt offset))))
+ ((atom undo-elt) nil)
+ ((stringp (car undo-elt))
+ ;; (TEXT . POSITION)
+ (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)
+ (- text-pos offset))))))
+ ((integerp (car undo-elt))
+ ;; (BEGIN . END)
+ (when (>= (car undo-elt) position)
+ (setcar undo-elt (- (car undo-elt) offset))
+ (setcdr undo-elt (- (cdr undo-elt) offset))))
+ ((null (car undo-elt))
+ ;; (nil PROPERTY VALUE BEG . END)
+ (let ((tail (nthcdr 3 undo-elt)))
+ (when (>= (car tail) position)
+ (setcar tail (- (car tail) offset))
+ (setcdr tail (- (cdr tail) offset))))))
+ (setq temp-undo-list (cdr temp-undo-list))))))))
+ (setq undo-list-copy (cdr undo-list-copy)))
+ (nreverse undo-list)))
+
+ (defun undo-elt-in-region (undo-elt start end)
+ "Determine whether UNDO-ELT falls inside the region START ... END.
+ If it crosses the edge, we return nil.
+
+ Generally this function is not useful for determining
+ whether (MARKER . ADJUSTMENT) undo elements are in the region,
+ because markers can be arbitrarily relocated. Instead, pass the
+ marker adjustment's corresponding (TEXT . POS) element."
+ (cond ((integerp undo-elt)
+ (and (>= undo-elt start)
+ (<= undo-elt end)))
+ ((eq undo-elt nil)
+ t)
+ ((atom undo-elt)
+ nil)
+ ((stringp (car undo-elt))
+ ;; (TEXT . POSITION)
+ (and (>= (abs (cdr undo-elt)) start)
+ (<= (abs (cdr undo-elt)) end)))
+ ((and (consp undo-elt) (markerp (car undo-elt)))
+ ;; (MARKER . ADJUSTMENT)
+ (<= start (car undo-elt) end))
+ ((null (car undo-elt))
+ ;; (nil PROPERTY VALUE BEG . END)
+ (let ((tail (nthcdr 3 undo-elt)))
+ (and (>= (car tail) start)
+ (<= (cdr tail) end))))
+ ((integerp (car undo-elt))
+ ;; (BEGIN . END)
+ (and (>= (car undo-elt) start)
+ (<= (cdr undo-elt) end)))))
+
+ (defun undo-elt-crosses-region (undo-elt start end)
+ "Test whether UNDO-ELT crosses one edge of that region START ... END.
+ This assumes we have already decided that UNDO-ELT
+ is not *inside* the region START...END."
+ (cond ((atom undo-elt) nil)
+ ((null (car undo-elt))
+ ;; (nil PROPERTY VALUE BEG . END)
+ (let ((tail (nthcdr 3 undo-elt)))
+ (and (< (car tail) end)
+ (> (cdr tail) start))))
+ ((integerp (car undo-elt))
+ ;; (BEGIN . END)
+ (and (< (car undo-elt) end)
+ (> (cdr undo-elt) start)))))
+
+ ;; Return the first affected buffer position and the delta for an undo element
+ ;; delta is defined as the change in subsequent buffer positions if we *did*
+ ;; the undo.
+ (defun undo-delta (undo-elt)
+ (if (consp undo-elt)
+ (cond ((stringp (car undo-elt))
+ ;; (TEXT . POSITION)
+ (cons (abs (cdr undo-elt)) (length (car undo-elt))))
+ ((integerp (car undo-elt))
+ ;; (BEGIN . END)
+ (cons (car undo-elt) (- (car undo-elt) (cdr undo-elt))))
+ (t
+ '(0 . 0)))
+ '(0 . 0)))
+
+ (defcustom undo-ask-before-discard nil
+ "If non-nil ask about discarding undo info for the current command.
+ Normally, Emacs discards the undo info for the current command if
+ it exceeds `undo-outer-limit'. But if you set this option
+ non-nil, it asks in the echo area whether to discard the info.
+ If you answer no, there is a slight risk that Emacs might crash, so
+ only do it if you really want to undo the command.
+
+ This option is mainly intended for debugging. You have to be
+ careful if you use it for other purposes. Garbage collection is
+ inhibited while the question is asked, meaning that Emacs might
+ leak memory. So you should make sure that you do not wait
+ excessively long before answering the question."
+ :type 'boolean
+ :group 'undo
+ :version "22.1")
+
+ (defvar undo-extra-outer-limit nil
+ "If non-nil, an extra level of size that's ok in an undo item.
+ We don't ask the user about truncating the undo list until the
+ current item gets bigger than this amount.
+
+ This variable only matters if `undo-ask-before-discard' is non-nil.")
+ (make-variable-buffer-local 'undo-extra-outer-limit)
+
+ ;; When the first undo batch in an undo list is longer than
+ ;; undo-outer-limit, this function gets called to warn the user that
+ ;; the undo info for the current command was discarded. Garbage
+ ;; collection is inhibited around the call, so it had better not do a
+ ;; lot of consing.
+ (setq undo-outer-limit-function 'undo-outer-limit-truncate)
+ (defun undo-outer-limit-truncate (size)
+ (if undo-ask-before-discard
+ (when (or (null undo-extra-outer-limit)
+ (> size undo-extra-outer-limit))
+ ;; Don't ask the question again unless it gets even bigger.
+ ;; This applies, in particular, if the user quits from the question.
+ ;; Such a quit quits out of GC, but something else will call GC
+ ;; again momentarily. It will call this function again,
+ ;; but we don't want to ask the question again.
+ (setq undo-extra-outer-limit (+ size 50000))
+ (if (let (use-dialog-box track-mouse executing-kbd-macro )
+ (yes-or-no-p (format "Buffer `%s' undo info is %d bytes long; discard it? "
+ (buffer-name) size)))
+ (progn (setq buffer-undo-list nil)
+ (setq undo-extra-outer-limit nil)
+ t)
+ nil))
+ (display-warning '(undo discard-info)
+ (concat
+ (format "Buffer `%s' undo info was %d bytes long.\n"
+ (buffer-name) size)
+ "The undo info was discarded because it exceeded \
+ `undo-outer-limit'.
+
+ This is normal if you executed a command that made a huge change
+ to the buffer. In that case, to prevent similar problems in the
+ future, set `undo-outer-limit' to a value that is large enough to
+ cover the maximum size of normal changes you expect a single
+ command to make, but not so large that it might exceed the
+ maximum memory allotted to Emacs.
+
+ If you did not execute any such command, the situation is
+ probably due to a bug and you should report it.
+
+ You can disable the popping up of this buffer by adding the entry
+ \(undo discard-info) to the user option `warning-suppress-types',
+ which is defined in the `warnings' library.\n")
+ :warning)
+ (setq buffer-undo-list nil)
+ t))
+ \f
+ (defcustom password-word-equivalents
+ '("password" "passcode" "passphrase" "pass phrase"
+ ; These are sorted according to the GNU en_US locale.
+ "암호" ; ko
+ "パスワード" ; ja
+ "ପ୍ରବେଶ ସଙ୍କେତ" ; or
+ "ពាក្យសម្ងាត់" ; km
+ "adgangskode" ; da
+ "contraseña" ; es
+ "contrasenya" ; ca
+ "geslo" ; sl
+ "hasło" ; pl
+ "heslo" ; cs, sk
+ "iphasiwedi" ; zu
+ "jelszó" ; hu
+ "lösenord" ; sv
+ "lozinka" ; hr, sr
+ "mật khẩu" ; vi
+ "mot de passe" ; fr
+ "parola" ; tr
+ "pasahitza" ; eu
+ "passord" ; nb
+ "passwort" ; de
+ "pasvorto" ; eo
+ "salasana" ; fi
+ "senha" ; pt
+ "slaptažodis" ; lt
+ "wachtwoord" ; nl
+ "كلمة السر" ; ar
+ "ססמה" ; he
+ "лозинка" ; sr
+ "пароль" ; kk, ru, uk
+ "गुप्तशब्द" ; mr
+ "शब्दकूट" ; hi
+ "પાસવર્ડ" ; gu
+ "సంకేతపదము" ; te
+ "ਪਾਸਵਰਡ" ; pa
+ "ಗುಪ್ತಪದ" ; kn
+ "கடவுச்சொல்" ; ta
+ "അടയാളവാക്ക്" ; ml
+ "গুপ্তশব্দ" ; as
+ "পাসওয়ার্ড" ; bn_IN
+ "රහස්පදය" ; si
+ "密码" ; zh_CN
+ "密碼" ; zh_TW
+ )
+ "List of words equivalent to \"password\".
+ This is used by Shell mode and other parts of Emacs to recognize
+ password prompts, including prompts in languages other than
+ English. Different case choices should not be assumed to be
+ included; callers should bind `case-fold-search' to t."
+ :type '(repeat string)
+ :version "24.4"
+ :group 'processes)
+
+ (defvar shell-command-history nil
+ "History list for some commands that read shell commands.
+
+ Maximum length of the history list is determined by the value
+ of `history-length', which see.")
+
+ (defvar shell-command-switch (purecopy "-c")
+ "Switch used to have the shell execute its command line argument.")
+
+ (defvar shell-command-default-error-buffer nil
+ "Buffer name for `shell-command' and `shell-command-on-region' error output.
+ This buffer is used when `shell-command' or `shell-command-on-region'
+ is run interactively. A value of nil means that output to stderr and
+ stdout will be intermixed in the output stream.")
+
+ (declare-function mailcap-file-default-commands "mailcap" (files))
+ (declare-function dired-get-filename "dired" (&optional localp no-error-if-not-filep))
+
+ (defun minibuffer-default-add-shell-commands ()
+ "Return a list of all commands associated with the current file.
+ This function is used to add all related commands retrieved by `mailcap'
+ to the end of the list of defaults just after the default value."
+ (interactive)
+ (let* ((filename (if (listp minibuffer-default)
+ (car minibuffer-default)
+ minibuffer-default))
+ (commands (and filename (require 'mailcap nil t)
+ (mailcap-file-default-commands (list filename)))))
+ (setq commands (mapcar (lambda (command)
+ (concat command " " filename))
+ commands))
+ (if (listp minibuffer-default)
+ (append minibuffer-default commands)
+ (cons minibuffer-default commands))))
+
+ (declare-function shell-completion-vars "shell" ())
+
+ (defvar minibuffer-local-shell-command-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map minibuffer-local-map)
+ (define-key map "\t" 'completion-at-point)
+ map)
+ "Keymap used for completing shell commands in minibuffer.")
+
+ (defun read-shell-command (prompt &optional initial-contents hist &rest args)
+ "Read a shell command from the minibuffer.
+ The arguments are the same as the ones of `read-from-minibuffer',
+ except READ and KEYMAP are missing and HIST defaults
+ to `shell-command-history'."
+ (require 'shell)
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (shell-completion-vars)
+ (set (make-local-variable 'minibuffer-default-add-function)
+ 'minibuffer-default-add-shell-commands))
+ (apply 'read-from-minibuffer prompt initial-contents
+ minibuffer-local-shell-command-map
+ nil
+ (or hist 'shell-command-history)
+ args)))
+
+ (defcustom async-shell-command-buffer 'confirm-new-buffer
+ "What to do when the output buffer is used by another shell command.
+ This option specifies how to resolve the conflict where a new command
+ wants to direct its output to the buffer `*Async Shell Command*',
+ but this buffer is already taken by another running shell command.
+
+ The value `confirm-kill-process' is used to ask for confirmation before
+ killing the already running process and running a new process
+ in the same buffer, `confirm-new-buffer' for confirmation before running
+ the command in a new buffer with a name other than the default buffer name,
+ `new-buffer' for doing the same without confirmation,
+ `confirm-rename-buffer' for confirmation before renaming the existing
+ output buffer and running a new command in the default buffer,
+ `rename-buffer' for doing the same without confirmation."
+ :type '(choice (const :tag "Confirm killing of running command"
+ confirm-kill-process)
+ (const :tag "Confirm creation of a new buffer"
+ confirm-new-buffer)
+ (const :tag "Create a new buffer"
+ new-buffer)
+ (const :tag "Confirm renaming of existing buffer"
+ confirm-rename-buffer)
+ (const :tag "Rename the existing buffer"
+ rename-buffer))
+ :group 'shell
+ :version "24.3")
+
+ (defun async-shell-command (command &optional output-buffer error-buffer)
+ "Execute string COMMAND asynchronously in background.
+
+ Like `shell-command', but adds `&' at the end of COMMAND
+ to execute it asynchronously.
+
+ The output appears in the buffer `*Async Shell Command*'.
+ That buffer is in shell mode.
+
+ You can configure `async-shell-command-buffer' to specify what to do in
+ case when `*Async Shell Command*' buffer is already taken by another
+ running shell command. To run COMMAND without displaying the output
+ in a window you can configure `display-buffer-alist' to use the action
+ `display-buffer-no-window' for the buffer `*Async Shell Command*'.
+
+ In Elisp, you will often be better served by calling `start-process'
+ directly, since it offers more control and does not impose the use of a
+ shell (with its need to quote arguments)."
+ (interactive
+ (list
+ (read-shell-command "Async shell command: " nil nil
+ (let ((filename
+ (cond
+ (buffer-file-name)
+ ((eq major-mode 'dired-mode)
+ (dired-get-filename nil t)))))
+ (and filename (file-relative-name filename))))
+ current-prefix-arg
+ shell-command-default-error-buffer))
+ (unless (string-match "&[ \t]*\\'" command)
+ (setq command (concat command " &")))
+ (shell-command command output-buffer error-buffer))
+
+ (defun shell-command (command &optional output-buffer error-buffer)
+ "Execute string COMMAND in inferior shell; display output, if any.
+ With prefix argument, insert the COMMAND's output at point.
+
+ If COMMAND ends in `&', execute it asynchronously.
+ The output appears in the buffer `*Async Shell Command*'.
+ That buffer is in shell mode. You can also use
+ `async-shell-command' that automatically adds `&'.
+
+ Otherwise, COMMAND is executed synchronously. The output appears in
+ the buffer `*Shell Command Output*'. If the output is short enough to
+ display in the echo area (which is determined by the variables
+ `resize-mini-windows' and `max-mini-window-height'), it is shown
+ there, but it is nonetheless available in buffer `*Shell Command
+ Output*' even though that buffer is not automatically displayed.
+
+ To specify a coding system for converting non-ASCII characters
+ in the shell command output, use \\[universal-coding-system-argument] \
+ before this command.
+
+ Noninteractive callers can specify coding systems by binding
+ `coding-system-for-read' and `coding-system-for-write'.
+
+ The optional second argument OUTPUT-BUFFER, if non-nil,
+ says to put the output in some other buffer.
+ If OUTPUT-BUFFER is a buffer or buffer name, put the output there.
+ If OUTPUT-BUFFER is not a buffer and not nil,
+ insert output in current buffer. (This cannot be done asynchronously.)
+ In either case, the buffer is first erased, and the output is
+ inserted after point (leaving mark after it).
+
+ If the command terminates without error, but generates output,
+ and you did not specify \"insert it in the current buffer\",
+ the output can be displayed in the echo area or in its buffer.
+ If the output is short enough to display in the echo area
+ \(determined by the variable `max-mini-window-height' if
+ `resize-mini-windows' is non-nil), it is shown there.
+ Otherwise,the buffer containing the output is displayed.
+
+ If there is output and an error, and you did not specify \"insert it
+ in the current buffer\", a message about the error goes at the end
+ of the output.
+
+ If there is no output, or if output is inserted in the current buffer,
+ then `*Shell Command Output*' is deleted.
+
+ If the optional third argument ERROR-BUFFER is non-nil, it is a buffer
+ or buffer name to which to direct the command's standard error output.
+ If it is nil, error output is mingled with regular output.
+ In an interactive call, the variable `shell-command-default-error-buffer'
+ specifies the value of ERROR-BUFFER.
+
+ In Elisp, you will often be better served by calling `call-process' or
+ `start-process' directly, since it offers more control and does not impose
+ the use of a shell (with its need to quote arguments)."
+
+ (interactive
+ (list
+ (read-shell-command "Shell command: " nil nil
+ (let ((filename
+ (cond
+ (buffer-file-name)
+ ((eq major-mode 'dired-mode)
+ (dired-get-filename nil t)))))
+ (and filename (file-relative-name filename))))
+ current-prefix-arg
+ shell-command-default-error-buffer))
+ ;; Look for a handler in case default-directory is a remote file name.
+ (let ((handler
+ (find-file-name-handler (directory-file-name default-directory)
+ 'shell-command)))
+ (if handler
+ (funcall handler 'shell-command command output-buffer error-buffer)
+ (if (and output-buffer
+ (not (or (bufferp output-buffer) (stringp output-buffer))))
+ ;; Output goes in current buffer.
+ (let ((error-file
+ (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 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
+ (if error-file
+ (list t error-file)
+ t)
+ nil shell-command-switch command)
+ (when (and error-file (file-exists-p error-file))
+ (if (< 0 (nth 7 (file-attributes error-file)))
+ (with-current-buffer (get-buffer-create error-buffer)
+ (let ((pos-from-end (- (point-max) (point))))
+ (or (bobp)
+ (insert "\f\n"))
+ ;; Do no formatting while reading error file,
+ ;; because that can run a shell command, and we
+ ;; don't want that to cause an infinite recursion.
+ (format-insert-file error-file nil)
+ ;; Put point after the inserted errors.
+ (goto-char (- (point-max) pos-from-end)))
+ (display-buffer (current-buffer))))
+ (delete-file error-file))
+ ;; This is like exchange-point-and-mark, but doesn't
+ ;; activate the mark. It is cleaner to avoid activation,
+ ;; even though the command loop would deactivate the mark
+ ;; because we inserted text.
+ (goto-char (prog1 (mark t)
+ (set-marker (mark-marker) (point)
+ (current-buffer)))))
+ ;; Output goes in a separate buffer.
+ ;; Preserve the match data in case called from a program.
+ (save-match-data
+ (if (string-match "[ \t]*&[ \t]*\\'" command)
+ ;; Command ending with ampersand means asynchronous.
+ (let ((buffer (get-buffer-create
+ (or output-buffer "*Async Shell Command*")))
+ (directory default-directory)
+ proc)
+ ;; Remove the ampersand.
+ (setq command (substring command 0 (match-beginning 0)))
+ ;; Ask the user what to do with already running process.
+ (setq proc (get-buffer-process buffer))
+ (when proc
+ (cond
+ ((eq async-shell-command-buffer 'confirm-kill-process)
+ ;; If will kill a process, query first.
+ (if (yes-or-no-p "A command is running in the default buffer. Kill it? ")
+ (kill-process proc)
+ (error "Shell command in progress")))
+ ((eq async-shell-command-buffer 'confirm-new-buffer)
+ ;; If will create a new buffer, query first.
+ (if (yes-or-no-p "A command is running in the default buffer. Use a new buffer? ")
+ (setq buffer (generate-new-buffer
+ (or output-buffer "*Async Shell Command*")))
+ (error "Shell command in progress")))
+ ((eq async-shell-command-buffer 'new-buffer)
+ ;; It will create a new buffer.
+ (setq buffer (generate-new-buffer
+ (or output-buffer "*Async Shell Command*"))))
+ ((eq async-shell-command-buffer 'confirm-rename-buffer)
+ ;; If will rename the buffer, query first.
+ (if (yes-or-no-p "A command is running in the default buffer. Rename it? ")
+ (progn
+ (with-current-buffer buffer
+ (rename-uniquely))
+ (setq buffer (get-buffer-create
+ (or output-buffer "*Async Shell Command*"))))
+ (error "Shell command in progress")))
+ ((eq async-shell-command-buffer 'rename-buffer)
+ ;; It will rename the buffer.
+ (with-current-buffer buffer
+ (rename-uniquely))
+ (setq buffer (get-buffer-create
+ (or output-buffer "*Async Shell Command*"))))))
+ (with-current-buffer buffer
+ (setq buffer-read-only nil)
+ ;; Setting buffer-read-only to nil doesn't suffice
+ ;; if some text has a non-nil read-only property,
+ ;; which comint sometimes adds for prompts.
+ (let ((inhibit-read-only t))
+ (erase-buffer))
+ (display-buffer buffer '(nil (allow-no-window . t)))
+ (setq default-directory directory)
+ (setq proc (start-process "Shell" buffer shell-file-name
+ shell-command-switch command))
+ (setq mode-line-process '(":%s"))
+ (require 'shell) (shell-mode)
+ (set-process-sentinel proc 'shell-command-sentinel)
+ ;; Use the comint filter for proper handling of carriage motion
+ ;; (see `comint-inhibit-carriage-motion'),.
+ (set-process-filter proc 'comint-output-filter)
+ ))
+ ;; Otherwise, command is executed synchronously.
+ (shell-command-on-region (point) (point) command
+ output-buffer nil error-buffer)))))))
+
+ (defun display-message-or-buffer (message
+ &optional buffer-name not-this-window frame)
+ "Display MESSAGE in the echo area if possible, otherwise in a pop-up buffer.
+ MESSAGE may be either a string or a buffer.
+
+ A buffer is displayed using `display-buffer' if MESSAGE is too long for
+ the maximum height of the echo area, as defined by `max-mini-window-height'
+ if `resize-mini-windows' is non-nil.
+
+ Returns either the string shown in the echo area, or when a pop-up
+ buffer is used, the window used to display it.
+
+ If MESSAGE is a string, then the optional argument BUFFER-NAME is the
+ name of the buffer used to display it in the case where a pop-up buffer
+ is used, defaulting to `*Message*'. In the case where MESSAGE is a
+ string and it is displayed in the echo area, it is not specified whether
+ the contents are inserted into the buffer anyway.
+
+ Optional arguments NOT-THIS-WINDOW and FRAME are as for `display-buffer',
+ and only used if a buffer is displayed."
+ (cond ((and (stringp message) (not (string-match "\n" message)))
+ ;; Trivial case where we can use the echo area
+ (message "%s" message))
+ ((and (stringp message)
+ (= (string-match "\n" message) (1- (length message))))
+ ;; Trivial case where we can just remove single trailing newline
+ (message "%s" (substring message 0 (1- (length message)))))
+ (t
+ ;; General case
+ (with-current-buffer
+ (if (bufferp message)
+ message
+ (get-buffer-create (or buffer-name "*Message*")))
+
+ (unless (bufferp message)
+ (erase-buffer)
+ (insert message))
+
+ (let ((lines
+ (if (= (buffer-size) 0)
+ 0
+ (count-screen-lines nil nil nil (minibuffer-window)))))
+ (cond ((= lines 0))
+ ((and (or (<= lines 1)
+ (<= lines
+ (if resize-mini-windows
+ (cond ((floatp max-mini-window-height)
+ (* (frame-height)
+ max-mini-window-height))
+ ((integerp max-mini-window-height)
+ max-mini-window-height)
+ (t
+ 1))
+ 1)))
+ ;; Don't use the echo area if the output buffer is
+ ;; already displayed in the selected frame.
+ (not (get-buffer-window (current-buffer))))
+ ;; Echo area
+ (goto-char (point-max))
+ (when (bolp)
+ (backward-char 1))
+ (message "%s" (buffer-substring (point-min) (point))))
+ (t
+ ;; Buffer
+ (goto-char (point-min))
+ (display-buffer (current-buffer)
+ not-this-window frame))))))))
+
+
+ ;; We have a sentinel to prevent insertion of a termination message
+ ;; in the buffer itself.
+ (defun shell-command-sentinel (process signal)
+ (if (memq (process-status process) '(exit signal))
+ (message "%s: %s."
+ (car (cdr (cdr (process-command process))))
+ (substring signal 0 -1))))
+
+ (defun shell-command-on-region (start end command
+ &optional output-buffer replace
+ error-buffer display-error-buffer)
+ "Execute string COMMAND in inferior shell with region as input.
+ Normally display output (if any) in temp buffer `*Shell Command Output*';
+ Prefix arg means replace the region with it. Return the exit code of
+ COMMAND.
+
+ To specify a coding system for converting non-ASCII characters
+ in the input and output to the shell command, use \\[universal-coding-system-argument]
+ before this command. By default, the input (from the current buffer)
+ is encoded using coding-system specified by `process-coding-system-alist',
+ falling back to `default-process-coding-system' if no match for COMMAND
+ is found in `process-coding-system-alist'.
+
+ Noninteractive callers can specify coding systems by binding
+ `coding-system-for-read' and `coding-system-for-write'.
+
+ If the command generates output, the output may be displayed
+ in the echo area or in a buffer.
+ If the output is short enough to display in the echo area
+ \(determined by the variable `max-mini-window-height' if
+ `resize-mini-windows' is non-nil), it is shown there.
+ Otherwise it is displayed in the buffer `*Shell Command Output*'.
+ The output is available in that buffer in both cases.
+
+ If there is output and an error, a message about the error
+ appears at the end of the output. If there is no output, or if
+ output is inserted in the current buffer, the buffer `*Shell
+ Command Output*' is deleted.
+
+ Optional fourth arg OUTPUT-BUFFER specifies where to put the
+ command's output. If the value is a buffer or buffer name,
+ put the output there. If the value is nil, use the buffer
+ `*Shell Command Output*'. Any other value, excluding nil,
+ means to insert the output in the current buffer. In either case,
+ the output is inserted after point (leaving mark after it).
+
+ Optional fifth arg REPLACE, if non-nil, means to insert the
+ output in place of text from START to END, putting point and mark
+ around it.
+
+ Optional sixth arg ERROR-BUFFER, if non-nil, specifies a buffer
+ or buffer name to which to direct the command's standard error
+ output. If nil, error output is mingled with regular output.
+ When called interactively, `shell-command-default-error-buffer'
+ is used for ERROR-BUFFER.
+
+ Optional seventh arg DISPLAY-ERROR-BUFFER, if non-nil, means to
+ display the error buffer if there were any errors. When called
+ interactively, this is t."
+ (interactive (let (string)
+ (unless (mark)
+ (error "The mark is not set now, so there is no region"))
+ ;; Do this before calling region-beginning
+ ;; and region-end, in case subprocess output
+ ;; relocates them while we are in the minibuffer.
+ (setq string (read-shell-command "Shell command on region: "))
+ ;; call-interactively recognizes region-beginning and
+ ;; region-end specially, leaving them in the history.
+ (list (region-beginning) (region-end)
+ string
+ current-prefix-arg
+ current-prefix-arg
+ shell-command-default-error-buffer
+ t)))
+ (let ((error-file
+ (if error-buffer
+ (make-temp-file
+ (expand-file-name "scor"
+ (or small-temporary-file-directory
+ temporary-file-directory)))
+ nil))
+ exit-status)
+ (if (or replace
+ (and output-buffer
+ (not (or (bufferp output-buffer) (stringp output-buffer)))))
+ ;; Replace specified region with output from command.
+ (let ((swap (and replace (< start end))))
+ ;; Don't muck with mark unless REPLACE says we should.
+ (goto-char start)
+ (and replace (push-mark (point) 'nomsg))
+ (setq exit-status
+ (call-process-region start end shell-file-name replace
+ (if error-file
+ (list t error-file)
+ t)
+ nil shell-command-switch command))
+ ;; It is rude to delete a buffer which the command is not using.
+ ;; (let ((shell-buffer (get-buffer "*Shell Command Output*")))
+ ;; (and shell-buffer (not (eq shell-buffer (current-buffer)))
+ ;; (kill-buffer shell-buffer)))
+ ;; Don't muck with mark unless REPLACE says we should.
+ (and replace swap (exchange-point-and-mark)))
+ ;; No prefix argument: put the output in a temp buffer,
+ ;; replacing its entire contents.
+ (let ((buffer (get-buffer-create
+ (or output-buffer "*Shell Command Output*"))))
+ (unwind-protect
+ (if (eq buffer (current-buffer))
+ ;; If the input is the same buffer as the output,
+ ;; delete everything but the specified region,
+ ;; then replace that region with the output.
+ (progn (setq buffer-read-only nil)
+ (delete-region (max start end) (point-max))
+ (delete-region (point-min) (min start end))
+ (setq exit-status
+ (call-process-region (point-min) (point-max)
+ shell-file-name t
+ (if error-file
+ (list t error-file)
+ t)
+ nil shell-command-switch
+ command)))
+ ;; Clear the output buffer, then run the command with
+ ;; output there.
+ (let ((directory default-directory))
+ (with-current-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)))
+ ;; Report the output.
+ (with-current-buffer buffer
+ (setq mode-line-process
+ (cond ((null exit-status)
+ " - Error")
+ ((stringp exit-status)
+ (format " - Signal [%s]" exit-status))
+ ((not (equal 0 exit-status))
+ (format " - Exit [%d]" exit-status)))))
+ (if (with-current-buffer buffer (> (point-max) (point-min)))
+ ;; There's some output, display it
+ (display-message-or-buffer buffer)
+ ;; No output; error?
+ (let ((output
+ (if (and error-file
+ (< 0 (nth 7 (file-attributes error-file))))
+ (format "some error output%s"
+ (if shell-command-default-error-buffer
+ (format " to the \"%s\" buffer"
+ shell-command-default-error-buffer)
+ ""))
+ "no output")))
+ (cond ((null exit-status)
+ (message "(Shell command failed with error)"))
+ ((equal 0 exit-status)
+ (message "(Shell command succeeded with %s)"
+ output))
+ ((stringp exit-status)
+ (message "(Shell command killed by signal %s)"
+ exit-status))
+ (t
+ (message "(Shell command failed with code %d and %s)"
+ exit-status output))))
+ ;; Don't kill: there might be useful info in the undo-log.
+ ;; (kill-buffer buffer)
+ ))))
+
+ (when (and error-file (file-exists-p error-file))
+ (if (< 0 (nth 7 (file-attributes error-file)))
+ (with-current-buffer (get-buffer-create error-buffer)
+ (let ((pos-from-end (- (point-max) (point))))
+ (or (bobp)
+ (insert "\f\n"))
+ ;; Do no formatting while reading error file,
+ ;; because that can run a shell command, and we
+ ;; don't want that to cause an infinite recursion.
+ (format-insert-file error-file nil)
+ ;; Put point after the inserted errors.
+ (goto-char (- (point-max) pos-from-end)))
+ (and display-error-buffer
+ (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
+ (with-current-buffer
+ standard-output
+ (process-file shell-file-name nil t nil shell-command-switch command))))
+
+ (defun process-file (program &optional infile buffer display &rest args)
+ "Process files synchronously in a separate process.
+ Similar to `call-process', but may invoke a file handler based on
+ `default-directory'. The current working directory of the
+ subprocess is `default-directory'.
+
+ File names in INFILE and BUFFER are handled normally, but file
+ names in ARGS should be relative to `default-directory', as they
+ are passed to the process verbatim. (This is a difference to
+ `call-process' which does not support file handlers for INFILE
+ and BUFFER.)
+
+ Some file handlers might not support all variants, for example
+ they might behave as if DISPLAY was nil, regardless of the actual
+ value passed."
+ (let ((fh (find-file-name-handler default-directory 'process-file))
+ lc stderr-file)
+ (unwind-protect
+ (if fh (apply fh 'process-file program infile buffer display args)
+ (when infile (setq lc (file-local-copy infile)))
+ (setq stderr-file (when (and (consp buffer) (stringp (cadr buffer)))
+ (make-temp-file "emacs")))
+ (prog1
+ (apply 'call-process program
+ (or lc infile)
+ (if stderr-file (list (car buffer) stderr-file) buffer)
+ display args)
+ (when stderr-file (copy-file stderr-file (cadr buffer) t))))
+ (when stderr-file (delete-file stderr-file))
+ (when lc (delete-file lc)))))
+
+ (defvar process-file-side-effects t
+ "Whether a call of `process-file' changes remote files.
+
+ By default, this variable is always set to `t', meaning that a
+ call of `process-file' could potentially change any file on a
+ remote host. When set to `nil', a file handler could optimize
+ its behavior with respect to remote file attribute caching.
+
+ You should only ever change this variable with a let-binding;
+ never with `setq'.")
+
+ (defun start-file-process (name buffer program &rest program-args)
+ "Start a program in a subprocess. Return the process object for it.
+
+ Similar to `start-process', but may invoke a file handler based on
+ `default-directory'. See Info node `(elisp)Magic File Names'.
+
+ This handler ought to run PROGRAM, perhaps on the local host,
+ perhaps on a remote host that corresponds to `default-directory'.
+ In the latter case, the local part of `default-directory' becomes
+ the working directory of the process.
+
+ PROGRAM and PROGRAM-ARGS might be file names. They are not
+ objects of file handler invocation. File handlers might not
+ support pty association, if PROGRAM is nil."
+ (let ((fh (find-file-name-handler default-directory 'start-file-process)))
+ (if fh (apply fh 'start-file-process name buffer program program-args)
+ (apply 'start-process name buffer program program-args))))
+ \f
+ ;;;; Process menu
+
+ (defvar tabulated-list-format)
+ (defvar tabulated-list-entries)
+ (defvar tabulated-list-sort-key)
+ (declare-function tabulated-list-init-header "tabulated-list" ())
+ (declare-function tabulated-list-print "tabulated-list"
+ (&optional remember-pos))
+
+ (defvar process-menu-query-only nil)
+
+ (define-derived-mode process-menu-mode tabulated-list-mode "Process Menu"
+ "Major mode for listing the processes called by Emacs."
+ (setq tabulated-list-format [("Process" 15 t)
+ ("Status" 7 t)
+ ("Buffer" 15 t)
+ ("TTY" 12 t)
+ ("Command" 0 t)])
+ (make-local-variable 'process-menu-query-only)
+ (setq tabulated-list-sort-key (cons "Process" nil))
+ (add-hook 'tabulated-list-revert-hook 'list-processes--refresh nil t)
+ (tabulated-list-init-header))
+
+ (defun list-processes--refresh ()
+ "Recompute the list of processes for the Process List buffer.
+ Also, delete any process that is exited or signaled."
+ (setq tabulated-list-entries nil)
+ (dolist (p (process-list))
+ (cond ((memq (process-status p) '(exit signal closed))
+ (delete-process p))
+ ((or (not process-menu-query-only)
+ (process-query-on-exit-flag p))
+ (let* ((buf (process-buffer p))
+ (type (process-type p))
+ (name (process-name p))
+ (status (symbol-name (process-status p)))
+ (buf-label (if (buffer-live-p buf)
+ `(,(buffer-name buf)
+ face link
+ help-echo ,(concat "Visit buffer `"
+ (buffer-name buf) "'")
+ follow-link t
+ process-buffer ,buf
+ action process-menu-visit-buffer)
+ "--"))
+ (tty (or (process-tty-name p) "--"))
+ (cmd
+ (if (memq type '(network serial))
+ (let ((contact (process-contact p t)))
+ (if (eq type 'network)
+ (format "(%s %s)"
+ (if (plist-get contact :type)
+ "datagram"
+ "network")
+ (if (plist-get contact :server)
+ (format "server on %s"
+ (or
+ (plist-get contact :host)
+ (plist-get contact :local)))
+ (format "connection to %s"
+ (plist-get contact :host))))
+ (format "(serial port %s%s)"
+ (or (plist-get contact :port) "?")
+ (let ((speed (plist-get contact :speed)))
+ (if speed
+ (format " at %s b/s" speed)
+ "")))))
+ (mapconcat 'identity (process-command p) " "))))
+ (push (list p (vector name status buf-label tty cmd))
+ tabulated-list-entries))))))
+
+ (defun process-menu-visit-buffer (button)
+ (display-buffer (button-get button 'process-buffer)))
+
+ (defun list-processes (&optional query-only buffer)
+ "Display a list of all processes that are Emacs sub-processes.
+ If optional argument QUERY-ONLY is non-nil, only processes with
+ the query-on-exit flag set are listed.
+ Any process listed as exited or signaled is actually eliminated
+ after the listing is made.
+ Optional argument BUFFER specifies a buffer to use, instead of
+ \"*Process List*\".
+ The return value is always nil.
+
+ This function lists only processes that were launched by Emacs. To
+ see other processes running on the system, use `list-system-processes'."
+ (interactive)
+ (or (fboundp 'process-list)
+ (error "Asynchronous subprocesses are not supported on this system"))
+ (unless (bufferp buffer)
+ (setq buffer (get-buffer-create "*Process List*")))
+ (with-current-buffer buffer
+ (process-menu-mode)
+ (setq process-menu-query-only query-only)
+ (list-processes--refresh)
+ (tabulated-list-print))
+ (display-buffer buffer)
+ nil)
+ \f
+ (defvar universal-argument-map
+ (let ((map (make-sparse-keymap))
+ (universal-argument-minus
+ ;; For backward compatibility, minus with no modifiers is an ordinary
+ ;; command if digits have already been entered.
+ `(menu-item "" negative-argument
+ :filter ,(lambda (cmd)
+ (if (integerp prefix-arg) nil cmd)))))
+ (define-key map [switch-frame]
+ (lambda (e) (interactive "e")
+ (handle-switch-frame e) (universal-argument--mode)))
+ (define-key map [?\C-u] 'universal-argument-more)
+ (define-key map [?-] universal-argument-minus)
+ (define-key map [?0] 'digit-argument)
+ (define-key map [?1] 'digit-argument)
+ (define-key map [?2] 'digit-argument)
+ (define-key map [?3] 'digit-argument)
+ (define-key map [?4] 'digit-argument)
+ (define-key map [?5] 'digit-argument)
+ (define-key map [?6] 'digit-argument)
+ (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].")
+
+ (defun universal-argument--mode ()
+ (set-transient-map universal-argument-map))
+
+ (defun universal-argument ()
+ "Begin a numeric argument for the following command.
+ Digits or minus sign following \\[universal-argument] make up the numeric argument.
+ \\[universal-argument] following the digits or minus sign ends the argument.
+ \\[universal-argument] without digits or minus sign provides 4 as argument.
+ Repeating \\[universal-argument] without digits or minus sign
+ multiplies the argument by 4 each time.
+ For some commands, just \\[universal-argument] by itself serves as a flag
+ which is different in effect from any particular numeric argument.
+ These commands include \\[set-mark-command] and \\[start-kbd-macro]."
+ (interactive)
+ (setq prefix-arg (list 4))
+ (universal-argument--mode))
+
+ (defun universal-argument-more (arg)
+ ;; A subsequent C-u means to multiply the factor by 4 if we've typed
+ ;; nothing but C-u's; otherwise it means to terminate the prefix arg.
+ (interactive "P")
+ (setq prefix-arg (if (consp arg)
+ (list (* 4 (car arg)))
+ (if (eq arg '-)
+ (list -4)
+ arg)))
+ (when (consp prefix-arg) (universal-argument--mode)))
+
+ (defun negative-argument (arg)
+ "Begin a negative numeric argument for the next command.
+ \\[universal-argument] following digits or minus sign ends the argument."
+ (interactive "P")
+ (setq prefix-arg (cond ((integerp arg) (- arg))
+ ((eq arg '-) nil)
+ (t '-)))
+ (universal-argument--mode))
+
+ (defun digit-argument (arg)
+ "Part of the numeric argument for the next command.
+ \\[universal-argument] following digits or minus sign ends the argument."
+ (interactive "P")
+ (let* ((char (if (integerp last-command-event)
+ last-command-event
+ (get last-command-event 'ascii-character)))
+ (digit (- (logand char ?\177) ?0)))
+ (setq prefix-arg (cond ((integerp arg)
+ (+ (* arg 10)
+ (if (< arg 0) (- digit) digit)))
+ ((eq arg '-)
+ ;; Treat -0 as just -, so that -01 will work.
+ (if (zerop digit) '- (- digit)))
+ (t
+ digit))))
+ (universal-argument--mode))
+ \f
+
+ (defvar filter-buffer-substring-functions nil
+ "This variable is a wrapper hook around `buffer-substring--filter'.")
+ (make-obsolete-variable 'filter-buffer-substring-functions
+ 'filter-buffer-substring-function "24.4")
+
+ (defvar filter-buffer-substring-function #'buffer-substring--filter
+ "Function to perform the filtering in `filter-buffer-substring'.
+ The function is called with the same 3 arguments (BEG END DELETE)
+ that `filter-buffer-substring' received. It should return the
+ buffer substring between BEG and END, after filtering. If DELETE is
+ non-nil, it should delete the text between BEG and END from the buffer.")
+
+ (defvar buffer-substring-filters nil
+ "List of filter functions for `buffer-substring--filter'.
+ Each function must accept a single argument, a string, and return a string.
+ The buffer substring is passed to the first function in the list,
+ and the return value of each function is passed to the next.
+ As a special convention, point is set to the start of the buffer text
+ being operated on (i.e., the first argument of `buffer-substring--filter')
+ before these functions are called.")
+ (make-obsolete-variable 'buffer-substring-filters
+ 'filter-buffer-substring-function "24.1")
+
+ (defun filter-buffer-substring (beg end &optional delete)
+ "Return the buffer substring between BEG and END, after filtering.
+ If DELETE is non-nil, delete the text between BEG and END from the buffer.
+
+ This calls the function that `filter-buffer-substring-function' specifies
+ \(passing the same three arguments that it received) to do the work,
+ and returns whatever it does. The default function does no filtering,
+ unless a hook has been set.
+
+ Use `filter-buffer-substring' instead of `buffer-substring',
+ `buffer-substring-no-properties', or `delete-and-extract-region' when
+ you want to allow filtering to take place. For example, major or minor
+ modes can use `filter-buffer-substring-function' to extract characters
+ that are special to a buffer, and should not be copied into other buffers."
+ (funcall filter-buffer-substring-function beg end delete))
+
+ (defun buffer-substring--filter (beg end &optional delete)
+ "Default function to use for `filter-buffer-substring-function'.
+ Its arguments and return value are as specified for `filter-buffer-substring'.
+ This respects the wrapper hook `filter-buffer-substring-functions',
+ and the abnormal hook `buffer-substring-filters'.
+ No filtering is done unless a hook says to."
+ (with-wrapper-hook filter-buffer-substring-functions (beg end delete)
+ (cond
+ ((or delete buffer-substring-filters)
+ (save-excursion
+ (goto-char beg)
+ (let ((string (if delete (delete-and-extract-region beg end)
+ (buffer-substring beg end))))
+ (dolist (filter buffer-substring-filters)
+ (setq string (funcall filter string)))
+ string)))
+ (t
+ (buffer-substring beg end)))))
+
+
+ ;;;; Window system cut and paste hooks.
+
+ (defvar interprogram-cut-function nil
+ "Function to call to make a killed region available to other programs.
+ Most window systems provide a facility for cutting and pasting
+ text between different programs, such as the clipboard on X and
+ MS-Windows, or the pasteboard on Nextstep/Mac OS.
+
+ This variable holds a function that Emacs calls whenever text is
+ put in the kill ring, to make the new kill available to other
+ programs. The function takes one argument, TEXT, which is a
+ string containing the text which should be made available.")
+
+ (defvar interprogram-paste-function nil
+ "Function to call to get text cut from other programs.
+ Most window systems provide a facility for cutting and pasting
+ text between different programs, such as the clipboard on X and
+ MS-Windows, or the pasteboard on Nextstep/Mac OS.
+
+ This variable holds a function that Emacs calls to obtain text
+ that other programs have provided for pasting. The function is
+ called with no arguments. If no other program has provided text
+ to paste, the function should return nil (in which case the
+ caller, usually `current-kill', should use the top of the Emacs
+ kill ring). If another program has provided text to paste, the
+ function should return that text as a string (in which case the
+ caller should put this string in the kill ring as the latest
+ kill).
+
+ The function may also return a list of strings if the window
+ system supports multiple selections. The first string will be
+ used as the pasted text, but the other will be placed in the kill
+ ring for easy access via `yank-pop'.
+
+ Note that the function should return a string only if a program
+ other than Emacs has provided a string for pasting; if Emacs
+ provided the most recent string, the function should return nil.
+ If it is difficult to tell whether Emacs or some other program
+ provided the current string, it is probably good enough to return
+ nil if the string is equal (according to `string=') to the last
+ text Emacs provided.")
+ \f
+
+
+ ;;;; The kill ring data structure.
+
+ (defvar kill-ring nil
+ "List of killed text sequences.
+ Since the kill ring is supposed to interact nicely with cut-and-paste
+ facilities offered by window systems, use of this variable should
+ interact nicely with `interprogram-cut-function' and
+ `interprogram-paste-function'. The functions `kill-new',
+ `kill-append', and `current-kill' are supposed to implement this
+ interaction; you may want to use them instead of manipulating the kill
+ ring directly.")
+
+ (defcustom kill-ring-max 60
+ "Maximum length of kill ring before oldest elements are thrown away."
+ :type 'integer
+ :group 'killing)
+
+ (defvar kill-ring-yank-pointer nil
+ "The tail of the kill ring whose car is the last thing yanked.")
+
+ (defcustom save-interprogram-paste-before-kill nil
+ "Save clipboard strings into kill ring before replacing them.
+ When one selects something in another program to paste it into Emacs,
+ but kills something in Emacs before actually pasting it,
+ this selection is gone unless this variable is non-nil,
+ in which case the other program's selection is saved in the `kill-ring'
+ before the Emacs kill and one can still paste it using \\[yank] \\[yank-pop]."
+ :type 'boolean
+ :group 'killing
+ :version "23.2")
+
+ (defcustom kill-do-not-save-duplicates nil
+ "Do not add a new string to `kill-ring' if it duplicates the last one.
+ The comparison is done using `equal-including-properties'."
+ :type 'boolean
+ :group 'killing
+ :version "23.2")
+
+ (defun kill-new (string &optional replace)
+ "Make STRING the latest kill in the kill ring.
+ Set `kill-ring-yank-pointer' to point to it.
+ If `interprogram-cut-function' is non-nil, apply it to STRING.
+ Optional second argument REPLACE non-nil means that STRING will replace
+ the front of the kill ring, rather than being added to the list.
+
+ When `save-interprogram-paste-before-kill' and `interprogram-paste-function'
+ are non-nil, saves the interprogram paste string(s) into `kill-ring' before
+ STRING.
+
+ When the yank handler has a non-nil PARAM element, the original STRING
+ argument is not used by `insert-for-yank'. However, since Lisp code
+ may access and use elements from the kill ring directly, the STRING
+ argument should still be a \"useful\" string for such uses."
+ (unless (and kill-do-not-save-duplicates
+ ;; Due to text properties such as 'yank-handler that
+ ;; can alter the contents to yank, comparison using
+ ;; `equal' is unsafe.
+ (equal-including-properties string (car kill-ring)))
+ (if (fboundp 'menu-bar-update-yank-menu)
+ (menu-bar-update-yank-menu string (and replace (car kill-ring)))))
+ (when save-interprogram-paste-before-kill
+ (let ((interprogram-paste (and interprogram-paste-function
+ (funcall interprogram-paste-function))))
+ (when interprogram-paste
+ (dolist (s (if (listp interprogram-paste)
+ (nreverse interprogram-paste)
+ (list interprogram-paste)))
+ (unless (and kill-do-not-save-duplicates
+ (equal-including-properties s (car kill-ring)))
+ (push s kill-ring))))))
+ (unless (and kill-do-not-save-duplicates
+ (equal-including-properties string (car kill-ring)))
+ (if (and replace kill-ring)
+ (setcar kill-ring string)
+ (push string kill-ring)
+ (if (> (length kill-ring) kill-ring-max)
+ (setcdr (nthcdr (1- kill-ring-max) kill-ring) nil))))
+ (setq kill-ring-yank-pointer kill-ring)
+ (if interprogram-cut-function
+ (funcall interprogram-cut-function string)))
+
+ (defun kill-append (string before-p)
+ "Append STRING to the end of the latest kill in the kill ring.
+ If BEFORE-P is non-nil, prepend STRING to the kill.
+ If `interprogram-cut-function' is set, pass the resulting kill to it."
+ (let* ((cur (car kill-ring)))
+ (kill-new (if before-p (concat string cur) (concat cur string))
+ (or (= (length cur) 0)
+ (equal nil (get-text-property 0 'yank-handler cur))))))
+
+ (defcustom yank-pop-change-selection nil
+ "Whether rotating the kill ring changes the window system selection.
+ If non-nil, whenever the kill ring is rotated (usually via the
+ `yank-pop' command), Emacs also calls `interprogram-cut-function'
+ to copy the new kill to the window system selection."
+ :type 'boolean
+ :group 'killing
+ :version "23.1")
+
+ (defun current-kill (n &optional do-not-move)
+ "Rotate the yanking point by N places, and then return that kill.
+ If N is zero and `interprogram-paste-function' is set to a
+ function that returns a string or a list of strings, and if that
+ function doesn't return nil, then that string (or list) is added
+ to the front of the kill ring and the string (or first string in
+ the list) is returned as the latest kill.
+
+ If N is not zero, and if `yank-pop-change-selection' is
+ non-nil, use `interprogram-cut-function' to transfer the
+ kill at the new yank point into the window system selection.
+
+ 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
+ (funcall interprogram-paste-function))))
+ (if interprogram-paste
+ (progn
+ ;; Disable the interprogram cut function when we add the new
+ ;; text to the kill ring, so Emacs doesn't try to own the
+ ;; selection, with identical text.
+ (let ((interprogram-cut-function nil))
+ (if (listp interprogram-paste)
+ (mapc 'kill-new (nreverse interprogram-paste))
+ (kill-new interprogram-paste)))
+ (car kill-ring))
+ (or kill-ring (error "Kill ring is empty"))
+ (let ((ARGth-kill-element
+ (nthcdr (mod (- n (length kill-ring-yank-pointer))
+ (length kill-ring))
+ kill-ring)))
+ (unless do-not-move
+ (setq kill-ring-yank-pointer ARGth-kill-element)
+ (when (and yank-pop-change-selection
+ (> n 0)
+ interprogram-cut-function)
+ (funcall interprogram-cut-function (car ARGth-kill-element))))
+ (car ARGth-kill-element)))))
+
+
+
+ ;;;; Commands for manipulating the kill ring.
+
+ (defcustom kill-read-only-ok nil
+ "Non-nil means don't signal an error for killing read-only text."
+ :type 'boolean
+ :group 'killing)
+
+ (defun kill-region (beg end &optional region)
+ "Kill (\"cut\") text between point and mark.
+ This deletes the text from the buffer and saves it in the kill ring.
+ The command \\[yank] can retrieve it from there.
+ \(If you want to save the region without killing it, use \\[kill-ring-save].)
+
+ If you want to append the killed region to the last killed text,
+ use \\[append-next-kill] before \\[kill-region].
+
+ If the buffer is read-only, Emacs will beep and refrain from deleting
+ the text, but put the text in the kill ring anyway. This means that
+ you can use the killing commands to copy text from a read-only buffer.
+
+ Lisp programs should use this function for killing text.
+ (To delete text, use `delete-region'.)
+ Supply two arguments, character positions indicating the stretch of text
+ to be killed.
+ Any command that calls this function is a \"kill command\".
+ If the previous command was also a kill command,
+ the text killed this time appends to the text killed last time
+ to make one entry in the kill ring.
+
+ The optional argument REGION if non-nil, indicates that we're not just killing
+ some text between BEG and END, but we're killing the region."
+ ;; Pass mark first, then point, because the order matters when
+ ;; calling `kill-append'.
+ (interactive (list (mark) (point) 'region))
+ (unless (and beg end)
+ (error "The mark is not set now, so there is no region"))
+ (condition-case nil
+ (let ((string (if region
+ (funcall region-extract-function 'delete)
+ (filter-buffer-substring beg end 'delete))))
+ (when string ;STRING is nil if BEG = END
+ ;; Add that string to the kill ring, one way or another.
+ (if (eq last-command 'kill-region)
+ (kill-append string (< end beg))
+ (kill-new string nil)))
+ (when (or string (eq last-command 'kill-region))
+ (setq this-command 'kill-region))
+ (setq deactivate-mark t)
+ nil)
+ ((buffer-read-only text-read-only)
+ ;; The code above failed because the buffer, or some of the characters
+ ;; in the region, are read-only.
+ ;; We should beep, in case the user just isn't aware of this.
+ ;; However, there's no harm in putting
+ ;; the region's text in the kill ring, anyway.
+ (copy-region-as-kill beg end region)
+ ;; Set this-command now, so it will be set even if we get an error.
+ (setq this-command 'kill-region)
+ ;; This should barf, if appropriate, and give us the correct error.
+ (if kill-read-only-ok
+ (progn (message "Read only text copied to kill ring") nil)
+ ;; Signal an error if the buffer is read-only.
+ (barf-if-buffer-read-only)
+ ;; If the buffer isn't read-only, the text is.
+ (signal 'text-read-only (list (current-buffer)))))))
+
+ ;; copy-region-as-kill no longer sets this-command, because it's confusing
+ ;; to get two copies of the text when the user accidentally types M-w and
+ ;; then corrects it with the intended C-w.
+ (defun copy-region-as-kill (beg end &optional region)
+ "Save the region as if killed, but don't kill it.
+ In Transient Mark mode, deactivate the mark.
+ If `interprogram-cut-function' is non-nil, also save the text for a window
+ system cut and paste.
+
+ The optional argument REGION if non-nil, indicates that we're not just copying
+ some text between BEG and END, but we're copying the region.
+
+ This command's old key binding has been given to `kill-ring-save'."
+ ;; Pass mark first, then point, because the order matters when
+ ;; calling `kill-append'.
+ (interactive (list (mark) (point)
+ (prefix-numeric-value current-prefix-arg)))
+ (let ((str (if region
+ (funcall region-extract-function nil)
+ (filter-buffer-substring beg end))))
+ (if (eq last-command 'kill-region)
+ (kill-append str (< end beg))
+ (kill-new str)))
+ (setq deactivate-mark t)
+ nil)
+
+ (defun kill-ring-save (beg end &optional region)
+ "Save the region as if killed, but don't kill it.
+ In Transient Mark mode, deactivate the mark.
+ If `interprogram-cut-function' is non-nil, also save the text for a window
+ system cut and paste.
+
+ If you want to append the killed line to the last killed text,
+ use \\[append-next-kill] before \\[kill-ring-save].
+
+ The optional argument REGION if non-nil, indicates that we're not just copying
+ some text between BEG and END, but we're copying the region.
+
+ This command is similar to `copy-region-as-kill', except that it gives
+ visual feedback indicating the extent of the region being copied."
+ ;; Pass mark first, then point, because the order matters when
+ ;; calling `kill-append'.
+ (interactive (list (mark) (point)
+ (prefix-numeric-value current-prefix-arg)))
+ (copy-region-as-kill beg end region)
+ ;; This use of called-interactively-p is correct because the code it
+ ;; controls just gives the user visual feedback.
+ (if (called-interactively-p 'interactive)
+ (indicate-copied-region)))
+
+ (defun indicate-copied-region (&optional message-len)
+ "Indicate that the region text has been copied interactively.
+ If the mark is visible in the selected window, blink the cursor
+ between point and mark if there is currently no active region
+ highlighting.
+
+ If the mark lies outside the selected window, display an
+ informative message containing a sample of the copied text. The
+ optional argument MESSAGE-LEN, if non-nil, specifies the length
+ of this sample text; it defaults to 40."
+ (let ((mark (mark t))
+ (point (point))
+ ;; Inhibit quitting so we can make a quit here
+ ;; look like a C-g typed as a command.
+ (inhibit-quit t))
+ (if (pos-visible-in-window-p mark (selected-window))
+ ;; Swap point-and-mark quickly so as to show the region that
+ ;; was selected. Don't do it if the region is highlighted.
+ (unless (and (region-active-p)
+ (face-background 'region))
+ ;; Swap point and mark.
+ (set-marker (mark-marker) (point) (current-buffer))
+ (goto-char mark)
+ (sit-for blink-matching-delay)
+ ;; Swap back.
+ (set-marker (mark-marker) mark (current-buffer))
+ (goto-char point)
+ ;; If user quit, deactivate the mark
+ ;; as C-g would as a command.
+ (and quit-flag mark-active
+ (deactivate-mark)))
+ (let ((len (min (abs (- mark point))
+ (or message-len 40))))
+ (if (< point mark)
+ ;; Don't say "killed"; that is misleading.
+ (message "Saved text until \"%s\""
+ (buffer-substring-no-properties (- mark len) mark))
+ (message "Saved text from \"%s\""
+ (buffer-substring-no-properties mark (+ mark len))))))))
+
+ (defun append-next-kill (&optional interactive)
+ "Cause following command, if it kills, to add to previous kill.
+ If the next command kills forward from point, the kill is
+ appended to the previous killed text. If the command kills
+ backward, the kill is prepended. Kill commands that act on the
+ region, such as `kill-region', are regarded as killing forward if
+ point is after mark, and killing backward if point is before
+ mark.
+
+ If the next command is not a kill command, `append-next-kill' has
+ no effect.
+
+ The argument is used for internal purposes; do not supply one."
+ (interactive "p")
+ ;; We don't use (interactive-p), since that breaks kbd macros.
+ (if interactive
+ (progn
+ (setq this-command 'kill-region)
+ (message "If the next command is a kill, it will append"))
+ (setq last-command 'kill-region)))
+ \f
+ ;; Yanking.
+
+ (defcustom yank-handled-properties
+ '((font-lock-face . yank-handle-font-lock-face-property)
+ (category . yank-handle-category-property))
+ "List of special text property handling conditions for yanking.
+ Each element should have the form (PROP . FUN), where PROP is a
+ property symbol and FUN is a function. When the `yank' command
+ inserts text into the buffer, it scans the inserted text for
+ stretches of text that have `eq' values of the text property
+ PROP; for each such stretch of text, FUN is called with three
+ arguments: the property's value in that text, and the start and
+ end positions of the text.
+
+ This is done prior to removing the properties specified by
+ `yank-excluded-properties'."
+ :group 'killing
+ :type '(repeat (cons (symbol :tag "property symbol")
+ function))
+ :version "24.3")
+
+ ;; This is actually used in subr.el but defcustom does not work there.
+ (defcustom yank-excluded-properties
+ '(category field follow-link fontified font-lock-face help-echo
+ intangible invisible keymap local-map mouse-face read-only
+ yank-handler)
+ "Text properties to discard when yanking.
+ The value should be a list of text properties to discard or t,
+ which means to discard all text properties.
+
+ See also `yank-handled-properties'."
+ :type '(choice (const :tag "All" t) (repeat symbol))
+ :group 'killing
+ :version "24.3")
+
+ (defvar yank-window-start nil)
+ (defvar yank-undo-function nil
+ "If non-nil, function used by `yank-pop' to delete last stretch of yanked text.
+ Function is called with two parameters, START and END corresponding to
+ the value of the mark and point; it is guaranteed that START <= END.
+ Normally set from the UNDO element of a yank-handler; see `insert-for-yank'.")
+
+ (defun yank-pop (&optional arg)
+ "Replace just-yanked stretch of killed text with a different stretch.
+ This command is allowed only immediately after a `yank' or a `yank-pop'.
+ At such a time, the region contains a stretch of reinserted
+ previously-killed text. `yank-pop' deletes that text and inserts in its
+ place a different stretch of killed text.
+
+ With no argument, the previous kill is inserted.
+ With argument N, insert the Nth previous kill.
+ If N is negative, this is a more recent kill.
+
+ The sequence of kills wraps around, so that after the oldest one
+ comes the newest one.
+
+ When this command inserts killed text into the buffer, it honors
+ `yank-excluded-properties' and `yank-handler' as described in the
+ doc string for `insert-for-yank-1', which see."
+ (interactive "*p")
+ (if (not (eq last-command 'yank))
+ (error "Previous command was not a yank"))
+ (setq this-command 'yank)
+ (unless arg (setq arg 1))
+ (let ((inhibit-read-only t)
+ (before (< (point) (mark t))))
+ (if before
+ (funcall (or yank-undo-function 'delete-region) (point) (mark t))
+ (funcall (or yank-undo-function 'delete-region) (mark t) (point)))
+ (setq yank-undo-function nil)
+ (set-marker (mark-marker) (point) (current-buffer))
+ (insert-for-yank (current-kill arg))
+ ;; Set the window start back where it was in the yank command,
+ ;; if possible.
+ (set-window-start (selected-window) yank-window-start t)
+ (if before
+ ;; This is like exchange-point-and-mark, but doesn't activate the mark.
+ ;; It is cleaner to avoid activation, even though the command
+ ;; loop would deactivate the mark because we inserted text.
+ (goto-char (prog1 (mark t)
+ (set-marker (mark-marker) (point) (current-buffer))))))
+ nil)
+
+ (defun yank (&optional arg)
+ "Reinsert (\"paste\") the last stretch of killed text.
+ More precisely, reinsert the most recent kill, which is the
+ stretch of killed text most recently killed OR yanked. Put point
+ at the end, and set mark at the beginning without activating it.
+ With just \\[universal-argument] as argument, put point at beginning, and mark at end.
+ With argument N, reinsert the Nth most recent kill.
+
+ When this command inserts text into the buffer, it honors the
+ `yank-handled-properties' and `yank-excluded-properties'
+ variables, and the `yank-handler' text property. See
+ `insert-for-yank-1' for details.
+
+ See also the command `yank-pop' (\\[yank-pop])."
+ (interactive "*P")
+ (setq yank-window-start (window-start))
+ ;; If we don't get all the way thru, make last-command indicate that
+ ;; for the following command.
+ (setq this-command t)
+ (push-mark (point))
+ (insert-for-yank (current-kill (cond
+ ((listp arg) 0)
+ ((eq arg '-) -2)
+ (t (1- arg)))))
+ (if (consp arg)
+ ;; This is like exchange-point-and-mark, but doesn't activate the mark.
+ ;; It is cleaner to avoid activation, even though the command
+ ;; loop would deactivate the mark because we inserted text.
+ (goto-char (prog1 (mark t)
+ (set-marker (mark-marker) (point) (current-buffer)))))
+ ;; If we do get all the way thru, make this-command indicate that.
+ (if (eq this-command t)
+ (setq this-command 'yank))
+ nil)
+
+ (defun rotate-yank-pointer (arg)
+ "Rotate the yanking point in the kill ring.
+ With ARG, 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) (+ (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) (- (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))
+ :version "20.3"
+ :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 ?\s col)
+ (delete-char 1)))
+ (forward-char -1)
+ (setq count (1- count))))))
+ (let* ((skip (cond ((eq backward-delete-char-untabify-method 'hungry) " \t")
+ ((eq backward-delete-char-untabify-method 'all)
+ " \t\n\r")))
+ (n (if skip
+ (let* ((oldpt (point))
+ (wh (- oldpt (save-excursion
+ (skip-chars-backward skip)
+ (constrain-to-field nil oldpt)))))
+ (+ arg (if (zerop wh) 0 (1- wh))))
+ arg)))
+ ;; Avoid warning about delete-backward-char
+ (with-no-warnings (delete-backward-char n killp))))
+
+ (defun zap-to-char (arg char)
+ "Kill up to and including ARGth 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 (list (prefix-numeric-value current-prefix-arg)
+ (read-char "Zap to char: " t)))
+ ;; Avoid "obsolete" warnings for translation-table-for-input.
+ (with-no-warnings
+ (if (char-table-p translation-table-for-input)
+ (setq char (or (aref translation-table-for-input char) char))))
+ (kill-region (point) (progn
+ (search-forward (char-to-string char) nil nil arg)
+ (point))))
+
+ ;; kill-line and its subroutines.
+
+ (defcustom kill-whole-line nil
+ "If non-nil, `kill-line' with no arg at start 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 ARG, kill that many lines from point.
+ Negative arguments kill lines backward.
+ With zero argument, kills the text before point on the current line.
+
+ 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 \
+ \\[move-beginning-of-line] \\[kill-line] \\[kill-line].
+
+ If `show-trailing-whitespace' is non-nil, this command will just
+ kill the rest of the current line, even if there are only
+ nonblanks there.
+
+ If option `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 \\[move-beginning-of-line] \\[kill-line].
+
+ If you want to append the killed line to the last killed text,
+ use \\[append-next-kill] before \\[kill-line].
+
+ If the buffer is read-only, Emacs will beep and refrain from deleting
+ the line, but put the line in the kill ring anyway. This means that
+ you can use this command to copy text from a read-only buffer.
+ \(If the variable `kill-read-only-ok' is non-nil, then this won't
+ even beep.)"
+ (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))
+ (let ((end
+ (save-excursion
+ (end-of-visible-line) (point))))
+ (if (or (save-excursion
+ ;; If trailing whitespace is visible,
+ ;; don't treat it as nothing.
+ (unless show-trailing-whitespace
+ (skip-chars-forward " \t" end))
+ (= (point) end))
+ (and kill-whole-line (bolp)))
+ (forward-visible-line 1)
+ (goto-char end))))
+ (point))))
+
+ (defun kill-whole-line (&optional arg)
+ "Kill current line.
+ With prefix ARG, kill that many lines starting from the current line.
+ If ARG is negative, kill backward. Also kill the preceding newline.
+ \(This is meant to make \\[repeat] work well with negative arguments.)
+ If ARG is zero, kill current line but exclude the trailing newline."
+ (interactive "p")
+ (or arg (setq arg 1))
+ (if (and (> arg 0) (eobp) (save-excursion (forward-visible-line 0) (eobp)))
+ (signal 'end-of-buffer nil))
+ (if (and (< arg 0) (bobp) (save-excursion (end-of-visible-line) (bobp)))
+ (signal 'beginning-of-buffer nil))
+ (unless (eq last-command 'kill-region)
+ (kill-new "")
+ (setq last-command 'kill-region))
+ (cond ((zerop arg)
+ ;; We need to kill in two steps, because the previous command
+ ;; could have been a kill command, in which case the text
+ ;; before point needs to be prepended to the current kill
+ ;; ring entry and the text after point appended. Also, we
+ ;; need to use save-excursion to avoid copying the same text
+ ;; twice to the kill ring in read-only buffers.
+ (save-excursion
+ (kill-region (point) (progn (forward-visible-line 0) (point))))
+ (kill-region (point) (progn (end-of-visible-line) (point))))
+ ((< arg 0)
+ (save-excursion
+ (kill-region (point) (progn (end-of-visible-line) (point))))
+ (kill-region (point)
+ (progn (forward-visible-line (1+ arg))
+ (unless (bobp) (backward-char))
+ (point))))
+ (t
+ (save-excursion
+ (kill-region (point) (progn (forward-visible-line 0) (point))))
+ (kill-region (point)
+ (progn (forward-visible-line arg) (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)
+ (progn
+ (while (> arg 0)
+ (or (zerop (forward-line 1))
+ (signal 'end-of-buffer nil))
+ ;; If the newline we just skipped is invisible,
+ ;; don't count it.
+ (let ((prop
+ (get-char-property (1- (point)) 'invisible)))
+ (if (if (eq buffer-invisibility-spec t)
+ prop
+ (or (memq prop buffer-invisibility-spec)
+ (assq prop buffer-invisibility-spec)))
+ (setq arg (1+ arg))))
+ (setq arg (1- arg)))
+ ;; If invisible text follows, and it is a number of complete lines,
+ ;; skip it.
+ (let ((opoint (point)))
+ (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)))))
+ (unless (bolp)
+ (goto-char opoint))))
+ (let ((first t))
+ (while (or first (<= arg 0))
+ (if first
+ (beginning-of-line)
+ (or (zerop (forward-line -1))
+ (signal 'beginning-of-buffer nil)))
+ ;; If the newline we just moved to is invisible,
+ ;; don't count it.
+ (unless (bobp)
+ (let ((prop
+ (get-char-property (1- (point)) 'invisible)))
+ (unless (if (eq buffer-invisibility-spec t)
+ prop
+ (or (memq prop buffer-invisibility-spec)
+ (assq prop buffer-invisibility-spec)))
+ (setq arg (1+ arg)))))
+ (setq first nil))
+ ;; If invisible text follows, and it is a number of complete lines,
+ ;; skip it.
+ (let ((opoint (point)))
+ (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)))))
+ (unless (bolp)
+ (goto-char opoint)))))
+ ((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))
+ (save-excursion
+ (skip-chars-forward "^\n")
+ (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))))))
+ (skip-chars-forward "^\n")
+ (if (get-text-property (point) 'invisible)
+ (goto-char (or (next-single-property-change (point) 'invisible)
+ (point-max)))
+ (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.
+
+ This function is meant for the user to run interactively.
+ Don't call it from programs: use `insert-buffer-substring' instead!"
+ (interactive
+ (list
+ (progn
+ (barf-if-buffer-read-only)
+ (read-buffer "Insert buffer: "
+ (if (eq (selected-window) (next-window))
+ (other-buffer (current-buffer))
+ (window-buffer (next-window)))
+ t))))
+ (push-mark
+ (save-excursion
+ (insert-buffer-substring (get-buffer buffer))
+ (point)))
+ nil)
+ (put 'insert-buffer 'interactive-only 'insert-buffer-substring)
+
+ (defun append-to-buffer (buffer start end)
+ "Append to specified buffer the text of the region.
+ It is inserted into that buffer before its point.
+
+ When calling from a program, give three arguments:
+ BUFFER (or buffer name), START and END.
+ START and END specify the portion of the current buffer to be copied."
+ (interactive
+ (list (read-buffer "Append to buffer: " (other-buffer (current-buffer) t))
+ (region-beginning) (region-end)))
+ (let* ((oldbuf (current-buffer))
+ (append-to (get-buffer-create buffer))
+ (windows (get-buffer-window-list append-to t t))
+ point)
+ (save-excursion
+ (with-current-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.
+ It is inserted into that buffer after its point.
+
+ When calling from a program, give three arguments:
+ BUFFER (or buffer name), START and END.
+ START and END specify the portion of the current buffer to be copied."
+ (interactive "BPrepend to buffer: \nr")
+ (let ((oldbuf (current-buffer)))
+ (with-current-buffer (get-buffer-create buffer)
+ (barf-if-buffer-read-only)
+ (save-excursion
+ (insert-buffer-substring oldbuf start end)))))
+
+ (defun copy-to-buffer (buffer start end)
+ "Copy to specified buffer the text of the region.
+ It is inserted into that buffer, replacing existing text there.
+
+ When calling from a program, give three arguments:
+ BUFFER (or buffer name), START and END.
+ START and END specify the portion of the current buffer to be copied."
+ (interactive "BCopy to buffer: \nr")
+ (let ((oldbuf (current-buffer)))
+ (with-current-buffer (get-buffer-create buffer)
+ (barf-if-buffer-read-only)
+ (erase-buffer)
+ (save-excursion
+ (insert-buffer-substring oldbuf start end)))))
+ \f
+ (define-error 'mark-inactive (purecopy "The mark is not active now"))
+
+ (defvar activate-mark-hook nil
+ "Hook run when the mark becomes active.
+ It is also run at the end of a command, if the mark is active and
+ it is possible that the region may have changed.")
+
+ (defvar deactivate-mark-hook nil
+ "Hook run when the mark becomes inactive.")
+
+ (defun mark (&optional force)
+ "Return this buffer's mark value as integer, or nil if never set.
+
+ In Transient Mark mode, this function signals an error if
+ the mark is not active. However, if `mark-even-if-inactive' is non-nil,
+ or the argument FORCE is non-nil, it disregards whether the mark
+ is active, and returns an integer or nil in the usual way.
+
+ If you are using this in an editing command, you are most likely making
+ a mistake; see the documentation of `set-mark'."
+ (if (or force (not transient-mark-mode) mark-active mark-even-if-inactive)
+ (marker-position (mark-marker))
+ (signal 'mark-inactive nil)))
+
+ ;; Behind display-selections-p.
+ (declare-function x-selection-owner-p "xselect.c"
+ (&optional selection terminal))
+ (declare-function x-selection-exists-p "xselect.c"
+ (&optional selection terminal))
+
+ (defun deactivate-mark (&optional force)
+ "Deactivate the mark.
+ If Transient Mark mode is disabled, this function normally does
+ nothing; but if FORCE is non-nil, it deactivates the mark anyway.
+
+ Deactivating the mark sets `mark-active' to nil, updates the
+ primary selection according to `select-active-regions', and runs
+ `deactivate-mark-hook'.
+
+ If Transient Mark mode was temporarily enabled, reset the value
+ of the variable `transient-mark-mode'; if this causes Transient
+ Mark mode to be disabled, don't change `mark-active' to nil or
+ run `deactivate-mark-hook'."
+ (when (or transient-mark-mode force)
+ (when (and (if (eq select-active-regions 'only)
+ (eq (car-safe transient-mark-mode) 'only)
+ select-active-regions)
+ (region-active-p)
+ (display-selections-p))
+ ;; The var `saved-region-selection', if non-nil, is the text in
+ ;; the region prior to the last command modifying the buffer.
+ ;; Set the selection to that, or to the current region.
+ (cond (saved-region-selection
+ (if (x-selection-owner-p 'PRIMARY)
+ (x-set-selection 'PRIMARY saved-region-selection))
+ (setq saved-region-selection nil))
+ ;; If another program has acquired the selection, region
+ ;; deactivation should not clobber it (Bug#11772).
+ ((and (/= (region-beginning) (region-end))
+ (or (x-selection-owner-p 'PRIMARY)
+ (null (x-selection-exists-p 'PRIMARY))))
+ (x-set-selection 'PRIMARY
+ (funcall region-extract-function nil)))))
+ (when mark-active (force-mode-line-update)) ;Refresh toolbar (bug#16382).
+ (cond
+ ((eq (car-safe transient-mark-mode) 'only)
+ (setq transient-mark-mode (cdr transient-mark-mode)))
+ ((eq transient-mark-mode 'lambda)
+ (setq transient-mark-mode nil)))
+ (setq mark-active nil)
+ (run-hooks 'deactivate-mark-hook)
+ (redisplay--update-region-highlight (selected-window))))
+
+ (defun activate-mark (&optional no-tmm)
+ "Activate the mark.
+ If NO-TMM is non-nil, leave `transient-mark-mode' alone."
+ (when (mark t)
+ (unless (region-active-p)
+ (force-mode-line-update) ;Refresh toolbar (bug#16382).
+ (setq mark-active t)
+ (unless (or transient-mark-mode no-tmm)
+ (setq transient-mark-mode 'lambda))
+ (run-hooks 'activate-mark-hook))))
+
+ (defun set-mark (pos)
+ "Set this buffer's mark to POS. Don't use this function!
+ That is to say, don't use this function unless you want
+ the user to see that the mark has moved, and you want the previous
+ mark position to be lost.
+
+ Normally, when a new mark is set, the old one should go on the stack.
+ This is why most applications should use `push-mark', not `set-mark'.
+
+ Novice Emacs Lisp programmers often try to use the mark for the wrong
+ purposes. The mark saves a location for the user's convenience.
+ Most editing commands should not alter the mark.
+ To remember a location for internal use in the Lisp program,
+ store it in a Lisp variable. Example:
+
+ (let ((beg (point))) (forward-line 1) (delete-region beg (point)))."
+ (if pos
+ (progn
+ (set-marker (mark-marker) pos (current-buffer))
+ (activate-mark 'no-tmm))
+ ;; Normally we never clear mark-active except in Transient Mark mode.
+ ;; But when we actually clear out the mark value too, we must
+ ;; clear mark-active in any mode.
+ (deactivate-mark t)
+ ;; `deactivate-mark' sometimes leaves mark-active non-nil, but
+ ;; it should never be nil if the mark is nil.
+ (setq mark-active nil)
+ (set-marker (mark-marker) nil)))
+
+ (defcustom use-empty-active-region nil
+ "Whether \"region-aware\" commands should act on empty regions.
+ If nil, region-aware commands treat empty regions as inactive.
+ If non-nil, region-aware commands treat the region as active as
+ long as the mark is active, even if the region is empty.
+
+ Region-aware commands are those that act on the region if it is
+ active and Transient Mark mode is enabled, and on the text near
+ point otherwise."
+ :type 'boolean
+ :version "23.1"
+ :group 'editing-basics)
+
+ (defun use-region-p ()
+ "Return t if the region is active and it is appropriate to act on it.
+ This is used by commands that act specially on the region under
+ Transient Mark mode.
+
+ The return value is t if Transient Mark mode is enabled and the
+ mark is active; furthermore, if `use-empty-active-region' is nil,
+ the region must not be empty. Otherwise, the return value is nil.
+
+ For some commands, it may be appropriate to ignore the value of
+ `use-empty-active-region'; in that case, use `region-active-p'."
+ (and (region-active-p)
+ (or use-empty-active-region (> (region-end) (region-beginning)))))
+
+ (defun region-active-p ()
+ "Return t if Transient Mark mode is enabled and the mark is active.
+
+ Some commands act specially on the region when Transient Mark
+ mode is enabled. Usually, such commands should use
+ `use-region-p' instead of this function, because `use-region-p'
+ also checks the value of `use-empty-active-region'."
+ (and transient-mark-mode mark-active
+ ;; FIXME: Somehow we sometimes end up with mark-active non-nil but
+ ;; without the mark being set (e.g. bug#17324). We really should fix
+ ;; that problem, but in the mean time, let's make sure we don't say the
+ ;; region is active when there's no mark.
+ (mark)))
+
+
+ (defvar redisplay-unhighlight-region-function
+ (lambda (rol) (when (overlayp rol) (delete-overlay rol))))
+
+ (defvar redisplay-highlight-region-function
+ (lambda (start end window rol)
+ (if (not (overlayp rol))
+ (let ((nrol (make-overlay start end)))
+ (funcall redisplay-unhighlight-region-function rol)
+ (overlay-put nrol 'window window)
+ (overlay-put nrol 'face 'region)
+ ;; Normal priority so that a large region doesn't hide all the
+ ;; overlays within it, but high secondary priority so that if it
+ ;; ends/starts in the middle of a small overlay, that small overlay
+ ;; won't hide the region's boundaries.
+ (overlay-put nrol 'priority '(nil . 100))
+ nrol)
+ (unless (and (eq (overlay-buffer rol) (current-buffer))
+ (eq (overlay-start rol) start)
+ (eq (overlay-end rol) end))
+ (move-overlay rol start end (current-buffer)))
+ rol)))
+
+ (defun redisplay--update-region-highlight (window)
+ (with-current-buffer (window-buffer window)
+ (let ((rol (window-parameter window 'internal-region-overlay)))
+ (if (not (region-active-p))
+ (funcall redisplay-unhighlight-region-function rol)
+ (let* ((pt (window-point window))
+ (mark (mark))
+ (start (min pt mark))
+ (end (max pt mark))
+ (new
+ (funcall redisplay-highlight-region-function
+ start end window rol)))
+ (unless (equal new rol)
+ (set-window-parameter window 'internal-region-overlay
+ new)))))))
+
+ (defun redisplay--update-region-highlights (windows)
+ (with-demoted-errors "redisplay--update-region-highlights: %S"
+ (if (null windows)
+ (redisplay--update-region-highlight (selected-window))
+ (unless (listp windows) (setq windows (window-list-1 nil nil t)))
+ (if highlight-nonselected-windows
+ (mapc #'redisplay--update-region-highlight windows)
+ (let ((msw (and (window-minibuffer-p) (minibuffer-selected-window))))
+ (dolist (w windows)
+ (if (or (eq w (selected-window)) (eq w msw))
+ (redisplay--update-region-highlight w)
+ (funcall redisplay-unhighlight-region-function
+ (window-parameter w 'internal-region-overlay)))))))))
+
+ (add-function :before pre-redisplay-function
+ #'redisplay--update-region-highlights)
+
+
+ (defvar-local mark-ring nil
+ "The list of former marks of the current buffer, most recent first.")
+ (put 'mark-ring 'permanent-local t)
+
+ (defcustom mark-ring-max 16
+ "Maximum size of mark ring. Start discarding off end if gets this big."
+ :type 'integer
+ :group 'editing-basics)
+
+ (defvar global-mark-ring nil
+ "The list of saved global marks, most recent first.")
+
+ (defcustom global-mark-ring-max 16
+ "Maximum size of global mark ring. \
+ Start discarding off end if gets this big."
+ :type 'integer
+ :group 'editing-basics)
+
+ (defun pop-to-mark-command ()
+ "Jump to mark, and pop a new position for mark off the ring.
+ \(Does not affect global mark ring)."
+ (interactive)
+ (if (null (mark t))
+ (error "No mark set in this buffer")
+ (if (= (point) (mark t))
+ (message "Mark popped"))
+ (goto-char (mark t))
+ (pop-mark)))
+
+ (defun push-mark-command (arg &optional nomsg)
+ "Set mark at where point is.
+ If no prefix ARG and mark is already set there, just activate it.
+ Display `Mark set' unless the optional second arg NOMSG is non-nil."
+ (interactive "P")
+ (let ((mark (mark t)))
+ (if (or arg (null mark) (/= mark (point)))
+ (push-mark nil nomsg t)
+ (activate-mark 'no-tmm)
+ (unless nomsg
+ (message "Mark activated")))))
+
+ (defcustom set-mark-command-repeat-pop nil
+ "Non-nil means repeating \\[set-mark-command] after popping mark pops it again.
+ That means that C-u \\[set-mark-command] \\[set-mark-command]
+ will pop the mark twice, and
+ C-u \\[set-mark-command] \\[set-mark-command] \\[set-mark-command]
+ will pop the mark three times.
+
+ A value of nil means \\[set-mark-command]'s behavior does not change
+ after C-u \\[set-mark-command]."
+ :type 'boolean
+ :group 'editing-basics)
+
+ (defun set-mark-command (arg)
+ "Set the mark where point is, or jump to the mark.
+ Setting the mark also alters the region, which is the text
+ between point and mark; this is the closest equivalent in
+ Emacs to what some editors call the \"selection\".
+
+ With no prefix argument, set the mark at point, and push the
+ old mark position on local mark ring. Also push the old mark on
+ global mark ring, if the previous mark was set in another buffer.
+
+ When Transient Mark Mode is off, immediately repeating this
+ command activates `transient-mark-mode' temporarily.
+
+ With prefix argument (e.g., \\[universal-argument] \\[set-mark-command]), \
+ jump to the mark, and set the mark from
+ position popped off the local mark ring (this does not affect the global
+ mark ring). Use \\[pop-global-mark] to jump to a mark popped off the global
+ mark ring (see `pop-global-mark').
+
+ If `set-mark-command-repeat-pop' is non-nil, repeating
+ the \\[set-mark-command] command with no prefix argument pops the next position
+ off the local (or global) mark ring and jumps there.
+
+ With \\[universal-argument] \\[universal-argument] as prefix
+ argument, unconditionally set mark where point is, even if
+ `set-mark-command-repeat-pop' is non-nil.
+
+ Novice Emacs Lisp programmers often try to use the mark for the wrong
+ purposes. See the documentation of `set-mark' for more information."
+ (interactive "P")
+ (cond ((eq transient-mark-mode 'lambda)
+ (setq transient-mark-mode nil))
+ ((eq (car-safe transient-mark-mode) 'only)
+ (deactivate-mark)))
+ (cond
+ ((and (consp arg) (> (prefix-numeric-value arg) 4))
+ (push-mark-command nil))
+ ((not (eq this-command 'set-mark-command))
+ (if arg
+ (pop-to-mark-command)
+ (push-mark-command t)))
+ ((and set-mark-command-repeat-pop
+ (eq last-command 'pop-to-mark-command))
+ (setq this-command 'pop-to-mark-command)
+ (pop-to-mark-command))
+ ((and set-mark-command-repeat-pop
+ (eq last-command 'pop-global-mark)
+ (not arg))
+ (setq this-command 'pop-global-mark)
+ (pop-global-mark))
+ (arg
+ (setq this-command 'pop-to-mark-command)
+ (pop-to-mark-command))
+ ((eq last-command 'set-mark-command)
+ (if (region-active-p)
+ (progn
+ (deactivate-mark)
+ (message "Mark deactivated"))
+ (activate-mark)
+ (message "Mark activated")))
+ (t
+ (push-mark-command nil))))
+
+ (defun push-mark (&optional location nomsg activate)
+ "Set mark at LOCATION (point, by default) and push old mark on mark ring.
+ If the last global mark pushed was not in the current buffer,
+ also push LOCATION on the global mark ring.
+ Display `Mark set' unless the optional second arg NOMSG is non-nil.
+
+ Novice Emacs Lisp programmers often try to use the mark for the wrong
+ purposes. See the documentation of `set-mark' for more information.
+
+ In Transient Mark mode, activate mark if optional third arg ACTIVATE non-nil."
+ (unless (null (mark t))
+ (setq mark-ring (cons (copy-marker (mark-marker)) mark-ring))
+ (when (> (length mark-ring) mark-ring-max)
+ (move-marker (car (nthcdr mark-ring-max mark-ring)) nil)
+ (setcdr (nthcdr (1- mark-ring-max) mark-ring) nil)))
+ (set-marker (mark-marker) (or location (point)) (current-buffer))
+ ;; Now push the mark on the global mark ring.
+ (if (and global-mark-ring
+ (eq (marker-buffer (car global-mark-ring)) (current-buffer)))
+ ;; The last global mark pushed was in this same buffer.
+ ;; Don't push another one.
+ nil
+ (setq global-mark-ring (cons (copy-marker (mark-marker)) global-mark-ring))
+ (when (> (length global-mark-ring) global-mark-ring-max)
+ (move-marker (car (nthcdr global-mark-ring-max global-mark-ring)) nil)
+ (setcdr (nthcdr (1- global-mark-ring-max) global-mark-ring) nil)))
+ (or nomsg executing-kbd-macro (> (minibuffer-depth) 0)
+ (message "Mark set"))
+ (if (or activate (not transient-mark-mode))
+ (set-mark (mark t)))
+ nil)
+
+ (defun pop-mark ()
+ "Pop off mark ring into the buffer's actual mark.
+ Does not set point. Does nothing if mark ring is empty."
+ (when mark-ring
+ (setq mark-ring (nconc mark-ring (list (copy-marker (mark-marker)))))
+ (set-marker (mark-marker) (+ 0 (car mark-ring)) (current-buffer))
+ (move-marker (car mark-ring) nil)
+ (if (null (mark t)) (ding))
+ (setq mark-ring (cdr mark-ring)))
+ (deactivate-mark))
+
+ (define-obsolete-function-alias
+ 'exchange-dot-and-mark 'exchange-point-and-mark "23.3")
+ (defun exchange-point-and-mark (&optional arg)
+ "Put the mark where point is now, and point where the mark is now.
+ This command works even when the mark is not active,
+ and it reactivates the mark.
+
+ If Transient Mark mode is on, a prefix ARG deactivates the mark
+ if it is active, and otherwise avoids reactivating it. If
+ Transient Mark mode is off, a prefix ARG enables Transient Mark
+ mode temporarily."
+ (interactive "P")
+ (let ((omark (mark t))
+ (temp-highlight (eq (car-safe transient-mark-mode) 'only)))
+ (if (null omark)
+ (error "No mark set in this buffer"))
+ (set-mark (point))
+ (goto-char omark)
+ (cond (temp-highlight
+ (setq transient-mark-mode (cons 'only transient-mark-mode)))
+ ((or (and arg (region-active-p)) ; (xor arg (not (region-active-p)))
+ (not (or arg (region-active-p))))
+ (deactivate-mark))
+ (t (activate-mark)))
+ nil))
+
+ (defcustom shift-select-mode t
+ "When non-nil, shifted motion keys activate the mark momentarily.
+
+ While the mark is activated in this way, any shift-translated point
+ motion key extends the region, and if Transient Mark mode was off, it
+ is temporarily turned on. Furthermore, the mark will be deactivated
+ by any subsequent point motion key that was not shift-translated, or
+ by any action that normally deactivates the mark in Transient Mark mode.
+
+ See `this-command-keys-shift-translated' for the meaning of
+ shift-translation."
+ :type 'boolean
+ :group 'editing-basics)
+
+ (defun handle-shift-selection ()
+ "Activate/deactivate mark depending on invocation thru shift translation.
+ This function is called by `call-interactively' when a command
+ with a `^' character in its `interactive' spec is invoked, before
+ running the command itself.
+
+ If `shift-select-mode' is enabled and the command was invoked
+ through shift translation, set the mark and activate the region
+ temporarily, unless it was already set in this way. See
+ `this-command-keys-shift-translated' for the meaning of shift
+ translation.
+
+ Otherwise, if the region has been activated temporarily,
+ deactivate it, and restore the variable `transient-mark-mode' to
+ its earlier value."
+ (cond ((and shift-select-mode this-command-keys-shift-translated)
+ (unless (and mark-active
+ (eq (car-safe transient-mark-mode) 'only))
+ (setq transient-mark-mode
+ (cons 'only
+ (unless (eq transient-mark-mode 'lambda)
+ transient-mark-mode)))
+ (push-mark nil nil t)))
+ ((eq (car-safe transient-mark-mode) 'only)
+ (setq transient-mark-mode (cdr transient-mark-mode))
+ (deactivate-mark))))
+
+ (define-minor-mode transient-mark-mode
+ "Toggle Transient Mark mode.
+ With a prefix argument ARG, enable Transient Mark mode if ARG is
+ positive, and disable it otherwise. If called from Lisp, enable
+ Transient Mark mode if ARG is omitted or nil.
+
+ Transient Mark mode is a global minor mode. When enabled, the
+ region is highlighted with the `region' face whenever the mark
+ is active. The mark is \"deactivated\" by changing the buffer,
+ and after certain other operations that set the mark but whose
+ main purpose is something else--for example, incremental search,
+ \\[beginning-of-buffer], and \\[end-of-buffer].
+
+ You can also deactivate the mark by typing \\[keyboard-quit] or
+ \\[keyboard-escape-quit].
+
+ Many commands change their behavior when Transient Mark mode is
+ in effect and the mark is active, by acting on the region instead
+ of their usual default part of the buffer's text. Examples of
+ such commands include \\[comment-dwim], \\[flush-lines], \\[keep-lines],
+ \\[query-replace], \\[query-replace-regexp], \\[ispell], and \\[undo].
+ To see the documentation of commands which are sensitive to the
+ Transient Mark mode, invoke \\[apropos-documentation] and type \"transient\"
+ or \"mark.*active\" at the prompt."
+ :global t
+ ;; It's defined in C/cus-start, this stops the d-m-m macro defining it again.
+ :variable transient-mark-mode)
+
+ (defvar widen-automatically t
+ "Non-nil means it is ok for commands to call `widen' when they want to.
+ Some commands will do this in order to go to positions outside
+ the current accessible part of the buffer.
+
+ If `widen-automatically' is nil, these commands will do something else
+ as a fallback, and won't change the buffer bounds.")
+
+ (defvar non-essential nil
+ "Whether the currently executing code is performing an essential task.
+ This variable should be non-nil only when running code which should not
+ disturb the user. E.g. it can be used to prevent Tramp from prompting the
+ user for a password when we are simply scanning a set of files in the
+ background or displaying possible completions before the user even asked
+ for it.")
+
+ (defun pop-global-mark ()
+ "Pop off global mark ring and jump to the top location."
+ (interactive)
+ ;; Pop entries which refer to non-existent buffers.
+ (while (and global-mark-ring (not (marker-buffer (car global-mark-ring))))
+ (setq global-mark-ring (cdr global-mark-ring)))
+ (or global-mark-ring
+ (error "No global mark set"))
+ (let* ((marker (car global-mark-ring))
+ (buffer (marker-buffer marker))
+ (position (marker-position marker)))
+ (setq global-mark-ring (nconc (cdr global-mark-ring)
+ (list (car global-mark-ring))))
+ (set-buffer buffer)
+ (or (and (>= position (point-min))
+ (<= position (point-max)))
+ (if widen-automatically
+ (widen)
+ (error "Global mark position is outside accessible part of buffer")))
+ (goto-char position)
+ (switch-to-buffer buffer)))
+ \f
+ (defcustom next-line-add-newlines nil
+ "If non-nil, `next-line' inserts newline to avoid `end of buffer' error."
+ :type 'boolean
+ :version "21.1"
+ :group 'editing-basics)
+
+ (defun next-line (&optional arg try-vscroll)
+ "Move cursor vertically down ARG lines.
+ Interactively, vscroll tall lines if `auto-window-vscroll' is enabled.
+ Non-interactively, use TRY-VSCROLL to control whether to vscroll tall
+ lines: if either `auto-window-vscroll' or TRY-VSCROLL is nil, this
+ function will not vscroll.
+
+ ARG defaults to 1.
+
+ If there is no character in the target line exactly under the current column,
+ the cursor is positioned after the character in that line which spans this
+ column, or at the end of the line if it is not long enough.
+ If there is no line in the buffer after this one, behavior depends on the
+ value of `next-line-add-newlines'. If non-nil, it inserts a newline character
+ to create a line, and moves the cursor to that line. Otherwise it moves the
+ cursor to the end of the buffer.
+
+ If the variable `line-move-visual' is non-nil, this command moves
+ by display lines. Otherwise, it moves by buffer lines, without
+ taking variable-width characters or continued lines into account.
+
+ The command \\[set-goal-column] can be used to create
+ a semipermanent goal column for this command.
+ Then instead of trying to move exactly vertically (or as close as possible),
+ this command moves to the specified goal column (or as close as possible).
+ The goal column is stored in the variable `goal-column', which is nil
+ when there is no goal column. Note that setting `goal-column'
+ overrides `line-move-visual' and causes this command to move by buffer
+ lines rather than by display lines.
+
+ If you are thinking of using this in a Lisp program, consider
+ using `forward-line' instead. It is usually easier to use
+ and more reliable (no dependence on goal column, etc.)."
+ (interactive "^p\np")
+ (or arg (setq arg 1))
+ (if (and next-line-add-newlines (= arg 1))
+ (if (save-excursion (end-of-line) (eobp))
+ ;; When adding a newline, don't expand an abbrev.
+ (let ((abbrev-mode nil))
+ (end-of-line)
+ (insert (if use-hard-newlines hard-newline "\n")))
+ (line-move arg nil nil try-vscroll))
+ (if (called-interactively-p 'interactive)
+ (condition-case err
+ (line-move arg nil nil try-vscroll)
+ ((beginning-of-buffer end-of-buffer)
+ (signal (car err) (cdr err))))
+ (line-move arg nil nil try-vscroll)))
+ nil)
+ (put 'next-line 'interactive-only 'forward-line)
+
+ (defun previous-line (&optional arg try-vscroll)
+ "Move cursor vertically up ARG lines.
+ Interactively, vscroll tall lines if `auto-window-vscroll' is enabled.
+ Non-interactively, use TRY-VSCROLL to control whether to vscroll tall
+ lines: if either `auto-window-vscroll' or TRY-VSCROLL is nil, this
+ function will not vscroll.
+
+ ARG defaults to 1.
+
+ If there is no character in the target line exactly over the current column,
+ the cursor is positioned after the character in that line which spans this
+ column, or at the end of the line if it is not long enough.
+
+ If the variable `line-move-visual' is non-nil, this command moves
+ by display lines. Otherwise, it moves by buffer lines, without
+ taking variable-width characters or continued lines into account.
+
+ The command \\[set-goal-column] can be used to create
+ a semipermanent goal column for this command.
+ Then instead of trying to move exactly vertically (or as close as possible),
+ this command moves to the specified goal column (or as close as possible).
+ The goal column is stored in the variable `goal-column', which is nil
+ when there is no goal column. Note that setting `goal-column'
+ overrides `line-move-visual' and causes this command to move by buffer
+ lines rather than by display lines.
+
+ If you are thinking of using this in a Lisp program, consider using
+ `forward-line' with a negative argument instead. It is usually easier
+ to use and more reliable (no dependence on goal column, etc.)."
+ (interactive "^p\np")
+ (or arg (setq arg 1))
+ (if (called-interactively-p 'interactive)
+ (condition-case err
+ (line-move (- arg) nil nil try-vscroll)
+ ((beginning-of-buffer end-of-buffer)
+ (signal (car err) (cdr err))))
+ (line-move (- arg) nil nil try-vscroll))
+ nil)
+ (put 'previous-line 'interactive-only
+ "use `forward-line' with negative argument instead.")
+
+ (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.
+ The beginning of a blank line does not count as the end of a line.
+ This has no effect when the variable `line-move-visual' is non-nil."
+ :type 'boolean
+ :group 'editing-basics)
+
+ (defcustom goal-column nil
+ "Semipermanent goal column for vertical motion, as set by \\[set-goal-column], or nil.
+ A non-nil setting overrides the variable `line-move-visual', which see."
+ :type '(choice integer
+ (const :tag "None" nil))
+ :group 'editing-basics)
+ (make-variable-buffer-local 'goal-column)
+
+ (defvar temporary-goal-column 0
+ "Current goal column for vertical motion.
+ It is the column where point was at the start of the current run
+ of vertical motion commands.
+
+ When moving by visual lines via the function `line-move-visual', it is a cons
+ cell (COL . HSCROLL), where COL is the x-position, in pixels,
+ divided by the default column width, and HSCROLL is the number of
+ columns by which window is scrolled from left margin.
+
+ When the `track-eol' feature is doing its job, the value is
+ `most-positive-fixnum'.")
+
+ (defcustom line-move-ignore-invisible t
+ "Non-nil means commands that move by lines ignore invisible newlines.
+ When this option is non-nil, \\[next-line], \\[previous-line], \\[move-end-of-line], and \\[move-beginning-of-line] behave
+ as if newlines that are invisible didn't exist, and count
+ only visible newlines. Thus, moving across across 2 newlines
+ one of which is invisible will be counted as a one-line move.
+ Also, a non-nil value causes invisible text to be ignored when
+ counting columns for the purposes of keeping point in the same
+ column by \\[next-line] and \\[previous-line].
+
+ Outline mode sets this."
+ :type 'boolean
+ :group 'editing-basics)
+
+ (defcustom line-move-visual t
+ "When non-nil, `line-move' moves point by visual lines.
+ This movement is based on where the cursor is displayed on the
+ screen, instead of relying on buffer contents alone. It takes
+ into account variable-width characters and line continuation.
+ If nil, `line-move' moves point by logical lines.
+ A non-nil setting of `goal-column' overrides the value of this variable
+ and forces movement by logical lines.
+ A window that is horizontally scrolled also forces movement by logical
+ lines."
+ :type 'boolean
+ :group 'editing-basics
+ :version "23.1")
+
+ ;; Only used if display-graphic-p.
+ (declare-function font-info "font.c" (name &optional frame))
+
+ (defun default-font-height ()
+ "Return the height in pixels of the current buffer's default face font."
+ (let ((default-font (face-font 'default)))
+ (cond
+ ((and (display-multi-font-p)
+ ;; Avoid calling font-info if the frame's default font was
+ ;; not changed since the frame was created. That's because
+ ;; font-info is expensive for some fonts, see bug #14838.
+ (not (string= (frame-parameter nil 'font) default-font)))
+ (aref (font-info default-font) 3))
+ (t (frame-char-height)))))
+
+ (defun default-line-height ()
+ "Return the pixel height of current buffer's default-face text line.
+
+ The value includes `line-spacing', if any, defined for the buffer
+ or the frame."
+ (let ((dfh (default-font-height))
+ (lsp (if (display-graphic-p)
+ (or line-spacing
+ (default-value 'line-spacing)
+ (frame-parameter nil 'line-spacing)
+ 0)
+ 0)))
+ (if (floatp lsp)
+ (setq lsp (truncate (* (frame-char-height) lsp))))
+ (+ dfh lsp)))
+
+ (defun window-screen-lines ()
+ "Return the number of screen lines in the text area of the selected window.
+
+ This is different from `window-text-height' in that this function counts
+ lines in units of the height of the font used by the default face displayed
+ in the window, not in units of the frame's default font, and also accounts
+ for `line-spacing', if any, defined for the window's buffer or frame.
+
+ The value is a floating-point number."
+ (let ((edges (window-inside-pixel-edges))
+ (dlh (default-line-height)))
+ (/ (float (- (nth 3 edges) (nth 1 edges))) dlh)))
+
+ ;; Returns non-nil if partial move was done.
+ (defun line-move-partial (arg noerror to-end)
+ (if (< arg 0)
+ ;; Move backward (up).
+ ;; If already vscrolled, reduce vscroll
+ (let ((vs (window-vscroll nil t))
+ (dlh (default-line-height)))
+ (when (> vs dlh)
+ (set-window-vscroll nil (- vs dlh) t)))
+
+ ;; Move forward (down).
+ (let* ((lh (window-line-height -1))
+ (rowh (car lh))
+ (vpos (nth 1 lh))
+ (ypos (nth 2 lh))
+ (rbot (nth 3 lh))
+ (this-lh (window-line-height))
+ (this-height (car this-lh))
+ (this-ypos (nth 2 this-lh))
+ (dlh (default-line-height))
+ (wslines (window-screen-lines))
+ (edges (window-inside-pixel-edges))
+ (winh (- (nth 3 edges) (nth 1 edges) 1))
+ py vs last-line)
+ (if (> (mod wslines 1.0) 0.0)
+ (setq wslines (round (+ wslines 0.5))))
+ (when (or (null lh)
+ (>= rbot dlh)
+ (<= ypos (- dlh))
+ (null this-lh)
+ (<= this-ypos (- dlh)))
+ (unless lh
+ (let ((wend (pos-visible-in-window-p t nil t)))
+ (setq rbot (nth 3 wend)
+ rowh (nth 4 wend)
+ vpos (nth 5 wend))))
+ (unless this-lh
+ (let ((wstart (pos-visible-in-window-p nil nil t)))
+ (setq this-ypos (nth 2 wstart)
+ this-height (nth 4 wstart))))
+ (setq py
+ (or (nth 1 this-lh)
+ (let ((ppos (posn-at-point))
+ col-row)
+ (setq col-row (posn-actual-col-row ppos))
+ (if col-row
+ (- (cdr col-row) (window-vscroll))
+ (cdr (posn-col-row ppos))))))
+ ;; VPOS > 0 means the last line is only partially visible.
+ ;; But if the part that is visible is at least as tall as the
+ ;; default font, that means the line is actually fully
+ ;; readable, and something like line-spacing is hidden. So in
+ ;; that case we accept the last line in the window as still
+ ;; visible, and consider the margin as starting one line
+ ;; later.
+ (if (and vpos (> vpos 0))
+ (if (and rowh
+ (>= rowh (default-font-height))
+ (< rowh dlh))
+ (setq last-line (min (- wslines scroll-margin) vpos))
+ (setq last-line (min (- wslines scroll-margin 1) (1- vpos)))))
+ (cond
+ ;; If last line of window is fully visible, and vscrolling
+ ;; more would make this line invisible, move forward.
+ ((and (or (< (setq vs (window-vscroll nil t)) dlh)
+ (null this-height)
+ (<= this-height dlh))
+ (or (null rbot) (= rbot 0)))
+ nil)
+ ;; If cursor is not in the bottom scroll margin, and the
+ ;; current line is is not too tall, move forward.
+ ((and (or (null this-height) (<= this-height winh))
+ vpos
+ (> vpos 0)
+ (< py last-line))
+ nil)
+ ;; When already vscrolled, we vscroll some more if we can,
+ ;; or clear vscroll and move forward at end of tall image.
+ ((> vs 0)
+ (when (or (and rbot (> rbot 0))
+ (and this-height (> this-height dlh)))
+ (set-window-vscroll nil (+ vs dlh) t)))
+ ;; If cursor just entered the bottom scroll margin, move forward,
+ ;; but also optionally vscroll one line so redisplay won't recenter.
+ ((and vpos
+ (> vpos 0)
+ (= py last-line))
+ ;; Don't vscroll if the partially-visible line at window
+ ;; bottom is not too tall (a.k.a. "just one more text
+ ;; line"): in that case, we do want redisplay to behave
+ ;; normally, i.e. recenter or whatever.
+ ;;
+ ;; Note: ROWH + RBOT from the value returned by
+ ;; pos-visible-in-window-p give the total height of the
+ ;; partially-visible glyph row at the end of the window. As
+ ;; we are dealing with floats, we disregard sub-pixel
+ ;; discrepancies between that and DLH.
+ (if (and rowh rbot (>= (- (+ rowh rbot) winh) 1))
+ (set-window-vscroll nil dlh t))
+ (line-move-1 arg noerror to-end)
+ t)
+ ;; If there are lines above the last line, scroll-up one line.
+ ((and vpos (> vpos 0))
+ (scroll-up 1)
+ t)
+ ;; Finally, start vscroll.
+ (t
+ (set-window-vscroll nil dlh t)))))))
+
+
+ ;; This is like line-move-1 except that it also performs
+ ;; vertical scrolling of tall images if appropriate.
+ ;; That is not really a clean thing to do, since it mixes
+ ;; scrolling with cursor motion. But so far we don't have
+ ;; a cleaner solution to the problem of making C-n do something
+ ;; useful given a tall image.
+ (defun line-move (arg &optional noerror to-end try-vscroll)
+ "Move forward ARG lines.
+ If NOERROR, don't signal an error if we can't move ARG lines.
+ TO-END is unused.
+ TRY-VSCROLL controls whether to vscroll tall lines: if either
+ `auto-window-vscroll' or TRY-VSCROLL is nil, this function will
+ not vscroll."
+ (if noninteractive
+ (line-move-1 arg noerror to-end)
+ (unless (and auto-window-vscroll try-vscroll
+ ;; Only vscroll for single line moves
+ (= (abs arg) 1)
+ ;; Under scroll-conservatively, the display engine
+ ;; does this better.
+ (zerop scroll-conservatively)
+ ;; But don't vscroll in a keyboard macro.
+ (not defining-kbd-macro)
+ (not executing-kbd-macro)
+ (line-move-partial arg noerror to-end))
+ (set-window-vscroll nil 0 t)
+ (if (and line-move-visual
+ ;; Display-based column are incompatible with goal-column.
+ (not goal-column)
+ ;; When the text in the window is scrolled to the left,
+ ;; display-based motion doesn't make sense (because each
+ ;; logical line occupies exactly one screen line).
+ (not (> (window-hscroll) 0))
+ ;; Likewise when the text _was_ scrolled to the left
+ ;; when the current run of vertical motion commands
+ ;; started.
+ (not (and (memq last-command
+ `(next-line previous-line ,this-command))
+ auto-hscroll-mode
+ (numberp temporary-goal-column)
+ (>= temporary-goal-column
+ (- (window-width) hscroll-margin)))))
+ (prog1 (line-move-visual arg noerror)
+ ;; If we moved into a tall line, set vscroll to make
+ ;; scrolling through tall images more smooth.
+ (let ((lh (line-pixel-height))
+ (edges (window-inside-pixel-edges))
+ (dlh (default-line-height))
+ winh)
+ (setq winh (- (nth 3 edges) (nth 1 edges) 1))
+ (if (and (< arg 0)
+ (< (point) (window-start))
+ (> lh winh))
+ (set-window-vscroll
+ nil
+ (- lh dlh) t))))
+ (line-move-1 arg noerror to-end)))))
+
+ ;; Display-based alternative to line-move-1.
+ ;; Arg says how many lines to move. The value is t if we can move the
+ ;; specified number of lines.
+ (defun line-move-visual (arg &optional noerror)
+ "Move ARG lines forward.
+ If NOERROR, don't signal an error if we can't move that many lines."
+ (let ((opoint (point))
+ (hscroll (window-hscroll))
+ target-hscroll)
+ ;; Check if the previous command was a line-motion command, or if
+ ;; we were called from some other command.
+ (if (and (consp temporary-goal-column)
+ (memq last-command `(next-line previous-line ,this-command)))
+ ;; If so, there's no need to reset `temporary-goal-column',
+ ;; but we may need to hscroll.
+ (if (or (/= (cdr temporary-goal-column) hscroll)
+ (> (cdr temporary-goal-column) 0))
+ (setq target-hscroll (cdr temporary-goal-column)))
+ ;; Otherwise, we should reset `temporary-goal-column'.
+ (let ((posn (posn-at-point))
+ x-pos)
+ (cond
+ ;; Handle the `overflow-newline-into-fringe' case:
+ ((eq (nth 1 posn) 'right-fringe)
+ (setq temporary-goal-column (cons (- (window-width) 1) hscroll)))
+ ((car (posn-x-y posn))
+ (setq x-pos (car (posn-x-y posn)))
+ ;; In R2L lines, the X pixel coordinate is measured from the
+ ;; left edge of the window, but columns are still counted
+ ;; from the logical-order beginning of the line, i.e. from
+ ;; the right edge in this case. We need to adjust for that.
+ (if (eq (current-bidi-paragraph-direction) 'right-to-left)
+ (setq x-pos (- (window-body-width nil t) 1 x-pos)))
+ (setq temporary-goal-column
+ (cons (/ (float x-pos)
+ (frame-char-width))
+ hscroll))))))
+ (if target-hscroll
+ (set-window-hscroll (selected-window) target-hscroll))
+ ;; vertical-motion can move more than it was asked to if it moves
+ ;; across display strings with newlines. We don't want to ring
+ ;; the bell and announce beginning/end of buffer in that case.
+ (or (and (or (and (>= arg 0)
+ (>= (vertical-motion
+ (cons (or goal-column
+ (if (consp temporary-goal-column)
+ (car temporary-goal-column)
+ temporary-goal-column))
+ arg))
+ arg))
+ (and (< arg 0)
+ (<= (vertical-motion
+ (cons (or goal-column
+ (if (consp temporary-goal-column)
+ (car temporary-goal-column)
+ temporary-goal-column))
+ arg))
+ arg)))
+ (or (>= arg 0)
+ (/= (point) opoint)
+ ;; If the goal column lies on a display string,
+ ;; `vertical-motion' advances the cursor to the end
+ ;; of the string. For arg < 0, this can cause the
+ ;; cursor to get stuck. (Bug#3020).
+ (= (vertical-motion arg) arg)))
+ (unless noerror
+ (signal (if (< arg 0) 'beginning-of-buffer 'end-of-buffer)
+ nil)))))
+
+ ;; This is the guts of next-line and previous-line.
+ ;; Arg says how many lines to move.
+ ;; The value is t if we can move the specified number of lines.
+ (defun line-move-1 (arg &optional noerror _to-end)
+ ;; Don't run any point-motion hooks, and disregard intangibility,
+ ;; for intermediate positions.
+ (let ((inhibit-point-motion-hooks t)
+ (opoint (point))
+ (orig-arg arg))
+ (if (consp temporary-goal-column)
+ (setq temporary-goal-column (+ (car temporary-goal-column)
+ (cdr temporary-goal-column))))
+ (unwind-protect
+ (progn
+ (if (not (memq last-command '(next-line previous-line)))
+ (setq temporary-goal-column
+ (if (and track-eol (eolp)
+ ;; Don't count beg of empty line as end of line
+ ;; unless we just did explicit end-of-line.
+ (or (not (bolp)) (eq last-command 'move-end-of-line)))
+ most-positive-fixnum
+ (current-column))))
+
+ (if (not (or (integerp selective-display)
+ line-move-ignore-invisible))
+ ;; Use just newline characters.
+ ;; Set ARG to 0 if we move as many lines as requested.
+ (or (if (> arg 0)
+ (progn (if (> arg 1) (forward-line (1- arg)))
+ ;; This way of moving forward ARG lines
+ ;; verifies that we have a newline after the last one.
+ ;; It doesn't get confused by intangible text.
+ (end-of-line)
+ (if (zerop (forward-line 1))
+ (setq arg 0)))
+ (and (zerop (forward-line arg))
+ (bolp)
+ (setq arg 0)))
+ (unless noerror
+ (signal (if (< arg 0)
+ 'beginning-of-buffer
+ 'end-of-buffer)
+ nil)))
+ ;; Move by arg lines, but ignore invisible ones.
+ (let (done)
+ (while (and (> arg 0) (not done))
+ ;; If the following character is currently invisible,
+ ;; skip all characters with that same `invisible' property value.
+ (while (and (not (eobp)) (invisible-p (point)))
+ (goto-char (next-char-property-change (point))))
+ ;; Move a line.
+ ;; We don't use `end-of-line', since we want to escape
+ ;; from field boundaries occurring exactly at point.
+ (goto-char (constrain-to-field
+ (let ((inhibit-field-text-motion t))
+ (line-end-position))
+ (point) t t
+ 'inhibit-line-move-field-capture))
+ ;; If there's no invisibility here, move over the newline.
+ (cond
+ ((eobp)
+ (if (not noerror)
+ (signal 'end-of-buffer nil)
+ (setq done t)))
+ ((and (> arg 1) ;; Use vertical-motion for last move
+ (not (integerp selective-display))
+ (not (invisible-p (point))))
+ ;; We avoid vertical-motion when possible
+ ;; because that has to fontify.
+ (forward-line 1))
+ ;; Otherwise move a more sophisticated way.
+ ((zerop (vertical-motion 1))
+ (if (not noerror)
+ (signal 'end-of-buffer nil)
+ (setq done t))))
+ (unless done
+ (setq arg (1- arg))))
+ ;; The logic of this is the same as the loop above,
+ ;; it just goes in the other direction.
+ (while (and (< arg 0) (not done))
+ ;; For completely consistency with the forward-motion
+ ;; case, we should call beginning-of-line here.
+ ;; However, if point is inside a field and on a
+ ;; continued line, the call to (vertical-motion -1)
+ ;; below won't move us back far enough; then we return
+ ;; to the same column in line-move-finish, and point
+ ;; gets stuck -- cyd
+ (forward-line 0)
+ (cond
+ ((bobp)
+ (if (not noerror)
+ (signal 'beginning-of-buffer nil)
+ (setq done t)))
+ ((and (< arg -1) ;; Use vertical-motion for last move
+ (not (integerp selective-display))
+ (not (invisible-p (1- (point)))))
+ (forward-line -1))
+ ((zerop (vertical-motion -1))
+ (if (not noerror)
+ (signal 'beginning-of-buffer nil)
+ (setq done t))))
+ (unless done
+ (setq arg (1+ arg))
+ (while (and ;; Don't move over previous invis lines
+ ;; if our target is the middle of this line.
+ (or (zerop (or goal-column temporary-goal-column))
+ (< arg 0))
+ (not (bobp)) (invisible-p (1- (point))))
+ (goto-char (previous-char-property-change (point))))))))
+ ;; This is the value the function returns.
+ (= arg 0))
+
+ (cond ((> arg 0)
+ ;; If we did not move down as far as desired, at least go
+ ;; to end of line. Be sure to call point-entered and
+ ;; point-left-hooks.
+ (let* ((npoint (prog1 (line-end-position)
+ (goto-char opoint)))
+ (inhibit-point-motion-hooks nil))
+ (goto-char npoint)))
+ ((< arg 0)
+ ;; If we did not move up as far as desired,
+ ;; at least go to beginning of line.
+ (let* ((npoint (prog1 (line-beginning-position)
+ (goto-char opoint)))
+ (inhibit-point-motion-hooks nil))
+ (goto-char npoint)))
+ (t
+ (line-move-finish (or goal-column temporary-goal-column)
+ opoint (> orig-arg 0)))))))
+
+ (defun line-move-finish (column opoint forward)
+ (let ((repeat t))
+ (while repeat
+ ;; Set REPEAT to t to repeat the whole thing.
+ (setq repeat nil)
+
+ (let (new
+ (old (point))
+ (line-beg (line-beginning-position))
+ (line-end
+ ;; Compute the end of the line
+ ;; ignoring effectively invisible newlines.
+ (save-excursion
+ ;; Like end-of-line but ignores fields.
+ (skip-chars-forward "^\n")
+ (while (and (not (eobp)) (invisible-p (point)))
+ (goto-char (next-char-property-change (point)))
+ (skip-chars-forward "^\n"))
+ (point))))
+
+ ;; Move to the desired column.
+ (line-move-to-column (truncate column))
+
+ ;; Corner case: suppose we start out in a field boundary in
+ ;; the middle of a continued line. When we get to
+ ;; line-move-finish, point is at the start of a new *screen*
+ ;; line but the same text line; then line-move-to-column would
+ ;; move us backwards. Test using C-n with point on the "x" in
+ ;; (insert "a" (propertize "x" 'field t) (make-string 89 ?y))
+ (and forward
+ (< (point) old)
+ (goto-char old))
+
+ (setq new (point))
+
+ ;; Process intangibility within a line.
+ ;; With inhibit-point-motion-hooks bound to nil, a call to
+ ;; goto-char moves point past intangible text.
+
+ ;; However, inhibit-point-motion-hooks controls both the
+ ;; intangibility and the point-entered/point-left hooks. The
+ ;; following hack avoids calling the point-* hooks
+ ;; unnecessarily. Note that we move *forward* past intangible
+ ;; text when the initial and final points are the same.
+ (goto-char new)
+ (let ((inhibit-point-motion-hooks nil))
+ (goto-char new)
+
+ ;; If intangibility moves us to a different (later) place
+ ;; in the same line, use that as the destination.
+ (if (<= (point) line-end)
+ (setq new (point))
+ ;; If that position is "too late",
+ ;; try the previous allowable position.
+ ;; See if it is ok.
+ (backward-char)
+ (if (if forward
+ ;; If going forward, don't accept the previous
+ ;; allowable position if it is before the target line.
+ (< line-beg (point))
+ ;; If going backward, don't accept the previous
+ ;; allowable position if it is still after the target line.
+ (<= (point) line-end))
+ (setq new (point))
+ ;; As a last resort, use the end of the line.
+ (setq new line-end))))
+
+ ;; Now move to the updated destination, processing fields
+ ;; as well as intangibility.
+ (goto-char opoint)
+ (let ((inhibit-point-motion-hooks nil))
+ (goto-char
+ ;; Ignore field boundaries if the initial and final
+ ;; positions have the same `field' property, even if the
+ ;; fields are non-contiguous. This seems to be "nicer"
+ ;; behavior in many situations.
+ (if (eq (get-char-property new 'field)
+ (get-char-property opoint 'field))
+ new
+ (constrain-to-field new opoint t t
+ 'inhibit-line-move-field-capture))))
+
+ ;; If all this moved us to a different line,
+ ;; retry everything within that new line.
+ (when (or (< (point) line-beg) (> (point) line-end))
+ ;; Repeat the intangibility and field processing.
+ (setq repeat t))))))
+
+ (defun line-move-to-column (col)
+ "Try to find column COL, considering invisibility.
+ This function works only in certain cases,
+ because what we really need is for `move-to-column'
+ and `current-column' to be able to ignore invisible text."
+ (if (zerop col)
+ (beginning-of-line)
+ (move-to-column col))
+
+ (when (and line-move-ignore-invisible
+ (not (bolp)) (invisible-p (1- (point))))
+ (let ((normal-location (point))
+ (normal-column (current-column)))
+ ;; If the following character is currently invisible,
+ ;; skip all characters with that same `invisible' property value.
+ (while (and (not (eobp))
+ (invisible-p (point)))
+ (goto-char (next-char-property-change (point))))
+ ;; Have we advanced to a larger column position?
+ (if (> (current-column) normal-column)
+ ;; We have made some progress towards the desired column.
+ ;; See if we can make any further progress.
+ (line-move-to-column (+ (current-column) (- col normal-column)))
+ ;; Otherwise, go to the place we originally found
+ ;; and move back over invisible text.
+ ;; that will get us to the same place on the screen
+ ;; but with a more reasonable buffer position.
+ (goto-char normal-location)
+ (let ((line-beg (line-beginning-position)))
+ (while (and (not (bolp)) (invisible-p (1- (point))))
+ (goto-char (previous-char-property-change (point) line-beg))))))))
+
+ (defun move-end-of-line (arg)
+ "Move point to end of current line as displayed.
+ With argument ARG not nil or 1, move forward ARG - 1 lines first.
+ If point reaches the beginning or end of buffer, it stops there.
+
+ To ignore the effects of the `intangible' text or overlay
+ property, bind `inhibit-point-motion-hooks' to t.
+ If there is an image in the current line, this function
+ disregards newlines that are part of the text on which the image
+ rests."
+ (interactive "^p")
+ (or arg (setq arg 1))
+ (let (done)
+ (while (not done)
+ (let ((newpos
+ (save-excursion
+ (let ((goal-column 0)
+ (line-move-visual nil))
+ (and (line-move arg t)
+ ;; With bidi reordering, we may not be at bol,
+ ;; so make sure we are.
+ (skip-chars-backward "^\n")
+ (not (bobp))
+ (progn
+ (while (and (not (bobp)) (invisible-p (1- (point))))
+ (goto-char (previous-single-char-property-change
+ (point) 'invisible)))
+ (backward-char 1)))
+ (point)))))
+ (goto-char newpos)
+ (if (and (> (point) newpos)
+ (eq (preceding-char) ?\n))
+ (backward-char 1)
+ (if (and (> (point) newpos) (not (eobp))
+ (not (eq (following-char) ?\n)))
+ ;; If we skipped something intangible and now we're not
+ ;; really at eol, keep going.
+ (setq arg 1)
+ (setq done t)))))))
+
+ (defun move-beginning-of-line (arg)
+ "Move point to beginning of current line as displayed.
+ \(If there's an image in the line, this disregards newlines
+ which are part of the text that the image rests on.)
+
+ With argument ARG not nil or 1, move forward ARG - 1 lines first.
+ If point reaches the beginning or end of buffer, it stops there.
+ To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
+ (interactive "^p")
+ (or arg (setq arg 1))
+
+ (let ((orig (point))
+ first-vis first-vis-field-value)
+
+ ;; Move by lines, if ARG is not 1 (the default).
+ (if (/= arg 1)
+ (let ((line-move-visual nil))
+ (line-move (1- arg) t)))
+
+ ;; Move to beginning-of-line, ignoring fields and invisible text.
+ (skip-chars-backward "^\n")
+ (while (and (not (bobp)) (invisible-p (1- (point))))
+ (goto-char (previous-char-property-change (point)))
+ (skip-chars-backward "^\n"))
+
+ ;; Now find first visible char in the line.
+ (while (and (< (point) orig) (invisible-p (point)))
+ (goto-char (next-char-property-change (point) orig)))
+ (setq first-vis (point))
+
+ ;; See if fields would stop us from reaching FIRST-VIS.
+ (setq first-vis-field-value
+ (constrain-to-field first-vis orig (/= arg 1) t nil))
+
+ (goto-char (if (/= first-vis-field-value first-vis)
+ ;; If yes, obey them.
+ first-vis-field-value
+ ;; Otherwise, move to START with attention to fields.
+ ;; (It is possible that fields never matter in this case.)
+ (constrain-to-field (point) orig
+ (/= arg 1) t nil)))))
+
+
+ ;; Many people have said they rarely use this feature, and often type
+ ;; it by accident. Maybe it shouldn't even be on a key.
+ (put 'set-goal-column 'disabled t)
+
+ (defun set-goal-column (arg)
+ "Set the current horizontal position as a goal for \\[next-line] and \\[previous-line].
+ Those commands will move to this position in the line moved to
+ rather than trying to keep the same horizontal position.
+ With a non-nil argument ARG, clears out the goal column
+ so that \\[next-line] and \\[previous-line] resume vertical motion.
+ The goal column is stored in the variable `goal-column'."
+ (interactive "P")
+ (if arg
+ (progn
+ (setq goal-column nil)
+ (message "No goal column"))
+ (setq goal-column (current-column))
+ ;; The older method below can be erroneous if `set-goal-column' is bound
+ ;; to a sequence containing %
+ ;;(message (substitute-command-keys
+ ;;"Goal column %d (use \\[set-goal-column] with an arg to unset it)")
+ ;;goal-column)
+ (message "%s"
+ (concat
+ (format "Goal column %d " goal-column)
+ (substitute-command-keys
+ "(use \\[set-goal-column] with an arg to unset it)")))
+
+ )
+ nil)
+ \f
+ ;;; Editing based on visual lines, as opposed to logical lines.
+
+ (defun end-of-visual-line (&optional n)
+ "Move point to end of current visual line.
+ With argument N not nil or 1, move forward N - 1 visual lines first.
+ If point reaches the beginning or end of buffer, it stops there.
+ To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
+ (interactive "^p")
+ (or n (setq n 1))
+ (if (/= n 1)
+ (let ((line-move-visual t))
+ (line-move (1- n) t)))
+ ;; Unlike `move-beginning-of-line', `move-end-of-line' doesn't
+ ;; constrain to field boundaries, so we don't either.
+ (vertical-motion (cons (window-width) 0)))
+
+ (defun beginning-of-visual-line (&optional n)
+ "Move point to beginning of current visual line.
+ With argument N not nil or 1, move forward N - 1 visual lines first.
+ If point reaches the beginning or end of buffer, it stops there.
+ To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
+ (interactive "^p")
+ (or n (setq n 1))
+ (let ((opoint (point)))
+ (if (/= n 1)
+ (let ((line-move-visual t))
+ (line-move (1- n) t)))
+ (vertical-motion 0)
+ ;; Constrain to field boundaries, like `move-beginning-of-line'.
+ (goto-char (constrain-to-field (point) opoint (/= n 1)))))
+
+ (defun kill-visual-line (&optional arg)
+ "Kill the rest of the visual line.
+ With prefix argument ARG, kill that many visual lines from point.
+ If ARG is negative, kill visual lines backward.
+ If ARG is zero, kill the text before point on the current visual
+ line.
+
+ If you want to append the killed line to the last killed text,
+ use \\[append-next-kill] before \\[kill-line].
+
+ If the buffer is read-only, Emacs will beep and refrain from deleting
+ the line, but put the line in the kill ring anyway. This means that
+ you can use this command to copy text from a read-only buffer.
+ \(If the variable `kill-read-only-ok' is non-nil, then this won't
+ even beep.)"
+ (interactive "P")
+ ;; Like in `kill-line', it's better to move point to the other end
+ ;; of the kill before killing.
+ (let ((opoint (point))
+ (kill-whole-line (and kill-whole-line (bolp))))
+ (if arg
+ (vertical-motion (prefix-numeric-value arg))
+ (end-of-visual-line 1)
+ (if (= (point) opoint)
+ (vertical-motion 1)
+ ;; Skip any trailing whitespace at the end of the visual line.
+ ;; We used to do this only if `show-trailing-whitespace' is
+ ;; nil, but that's wrong; the correct thing would be to check
+ ;; whether the trailing whitespace is highlighted. But, it's
+ ;; OK to just do this unconditionally.
+ (skip-chars-forward " \t")))
+ (kill-region opoint (if (and kill-whole-line (looking-at "\n"))
+ (1+ (point))
+ (point)))))
+
+ (defun next-logical-line (&optional arg try-vscroll)
+ "Move cursor vertically down ARG lines.
+ This is identical to `next-line', except that it always moves
+ by logical lines instead of visual lines, ignoring the value of
+ the variable `line-move-visual'."
+ (interactive "^p\np")
+ (let ((line-move-visual nil))
+ (with-no-warnings
+ (next-line arg try-vscroll))))
+
+ (defun previous-logical-line (&optional arg try-vscroll)
+ "Move cursor vertically up ARG lines.
+ This is identical to `previous-line', except that it always moves
+ by logical lines instead of visual lines, ignoring the value of
+ the variable `line-move-visual'."
+ (interactive "^p\np")
+ (let ((line-move-visual nil))
+ (with-no-warnings
+ (previous-line arg try-vscroll))))
+
+ (defgroup visual-line nil
+ "Editing based on visual lines."
+ :group 'convenience
+ :version "23.1")
+
+ (defvar visual-line-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [remap kill-line] 'kill-visual-line)
+ (define-key map [remap move-beginning-of-line] 'beginning-of-visual-line)
+ (define-key map [remap move-end-of-line] 'end-of-visual-line)
+ ;; These keybindings interfere with xterm function keys. Are
+ ;; there any other suitable bindings?
+ ;; (define-key map "\M-[" 'previous-logical-line)
+ ;; (define-key map "\M-]" 'next-logical-line)
+ map))
+
+ (defcustom visual-line-fringe-indicators '(nil nil)
+ "How fringe indicators are shown for wrapped lines in `visual-line-mode'.
+ The value should be a list of the form (LEFT RIGHT), where LEFT
+ and RIGHT are symbols representing the bitmaps to display, to
+ indicate wrapped lines, in the left and right fringes respectively.
+ See also `fringe-indicator-alist'.
+ The default is not to display fringe indicators for wrapped lines.
+ This variable does not affect fringe indicators displayed for
+ other purposes."
+ :type '(list (choice (const :tag "Hide left indicator" nil)
+ (const :tag "Left curly arrow" left-curly-arrow)
+ (symbol :tag "Other bitmap"))
+ (choice (const :tag "Hide right indicator" nil)
+ (const :tag "Right curly arrow" right-curly-arrow)
+ (symbol :tag "Other bitmap")))
+ :set (lambda (symbol value)
+ (dolist (buf (buffer-list))
+ (with-current-buffer buf
+ (when (and (boundp 'visual-line-mode)
+ (symbol-value 'visual-line-mode))
+ (setq fringe-indicator-alist
+ (cons (cons 'continuation value)
+ (assq-delete-all
+ 'continuation
+ (copy-tree fringe-indicator-alist)))))))
+ (set-default symbol value)))
+
+ (defvar visual-line--saved-state nil)
+
+ (define-minor-mode visual-line-mode
+ "Toggle visual line based editing (Visual Line mode).
+ With a prefix argument ARG, enable Visual Line mode if ARG is
+ positive, and disable it otherwise. If called from Lisp, enable
+ the mode if ARG is omitted or nil.
+
+ When Visual Line mode is enabled, `word-wrap' is turned on in
+ this buffer, and simple editing commands are redefined to act on
+ visual lines, not logical lines. See Info node `Visual Line
+ Mode' for details."
+ :keymap visual-line-mode-map
+ :group 'visual-line
+ :lighter " Wrap"
+ (if visual-line-mode
+ (progn
+ (set (make-local-variable 'visual-line--saved-state) nil)
+ ;; Save the local values of some variables, to be restored if
+ ;; visual-line-mode is turned off.
+ (dolist (var '(line-move-visual truncate-lines
+ truncate-partial-width-windows
+ word-wrap fringe-indicator-alist))
+ (if (local-variable-p var)
+ (push (cons var (symbol-value var))
+ visual-line--saved-state)))
+ (set (make-local-variable 'line-move-visual) t)
+ (set (make-local-variable 'truncate-partial-width-windows) nil)
+ (setq truncate-lines nil
+ word-wrap t
+ fringe-indicator-alist
+ (cons (cons 'continuation visual-line-fringe-indicators)
+ fringe-indicator-alist)))
+ (kill-local-variable 'line-move-visual)
+ (kill-local-variable 'word-wrap)
+ (kill-local-variable 'truncate-lines)
+ (kill-local-variable 'truncate-partial-width-windows)
+ (kill-local-variable 'fringe-indicator-alist)
+ (dolist (saved visual-line--saved-state)
+ (set (make-local-variable (car saved)) (cdr saved)))
+ (kill-local-variable 'visual-line--saved-state)))
+
+ (defun turn-on-visual-line-mode ()
+ (visual-line-mode 1))
+
+ (define-globalized-minor-mode global-visual-line-mode
+ visual-line-mode turn-on-visual-line-mode)
+
+ \f
+ (defun transpose-chars (arg)
+ "Interchange characters around point, moving forward one character.
+ With prefix arg ARG, effect is to take character before point
+ and drag it forward past ARG other characters (backward if ARG negative).
+ If no argument and at end of line, the previous two chars are exchanged."
+ (interactive "*P")
+ (and (null arg) (eolp) (forward-char -1))
+ (transpose-subr 'forward-char (prefix-numeric-value arg)))
+
+ (defun transpose-words (arg)
+ "Interchange words around point, leaving point at end of them.
+ With prefix arg ARG, effect is to take word before or around point
+ and drag it forward past ARG other words (backward if ARG negative).
+ If ARG is zero, the words around or after point and around or after mark
+ are interchanged."
+ ;; FIXME: `foo a!nd bar' should transpose into `bar and foo'.
+ (interactive "*p")
+ (transpose-subr 'forward-word arg))
+
+ (defun transpose-sexps (arg)
+ "Like \\[transpose-words] but applies to sexps.
+ Does not work on a sexp that point is in the middle of
+ if it is a list or string."
+ (interactive "*p")
+ (transpose-subr
+ (lambda (arg)
+ ;; Here we should try to simulate the behavior of
+ ;; (cons (progn (forward-sexp x) (point))
+ ;; (progn (forward-sexp (- x)) (point)))
+ ;; Except that we don't want to rely on the second forward-sexp
+ ;; putting us back to where we want to be, since forward-sexp-function
+ ;; might do funny things like infix-precedence.
+ (if (if (> arg 0)
+ (looking-at "\\sw\\|\\s_")
+ (and (not (bobp))
+ (save-excursion (forward-char -1) (looking-at "\\sw\\|\\s_"))))
+ ;; Jumping over a symbol. We might be inside it, mind you.
+ (progn (funcall (if (> arg 0)
+ 'skip-syntax-backward 'skip-syntax-forward)
+ "w_")
+ (cons (save-excursion (forward-sexp arg) (point)) (point)))
+ ;; Otherwise, we're between sexps. Take a step back before jumping
+ ;; to make sure we'll obey the same precedence no matter which direction
+ ;; we're going.
+ (funcall (if (> arg 0) 'skip-syntax-backward 'skip-syntax-forward) " .")
+ (cons (save-excursion (forward-sexp arg) (point))
+ (progn (while (or (forward-comment (if (> arg 0) 1 -1))
+ (not (zerop (funcall (if (> arg 0)
+ 'skip-syntax-forward
+ 'skip-syntax-backward)
+ ".")))))
+ (point)))))
+ arg 'special))
+
+ (defun transpose-lines (arg)
+ "Exchange current line and previous line, leaving point after both.
+ With argument ARG, takes previous line and moves it past ARG lines.
+ With argument 0, interchanges line point is in with line mark is in."
+ (interactive "*p")
+ (transpose-subr (function
+ (lambda (arg)
+ (if (> arg 0)
+ (progn
+ ;; Move forward over ARG lines,
+ ;; but create newlines if necessary.
+ (setq arg (forward-line arg))
+ (if (/= (preceding-char) ?\n)
+ (setq arg (1+ arg)))
+ (if (> arg 0)
+ (newline arg)))
+ (forward-line arg))))
+ arg))
+
+ ;; FIXME seems to leave point BEFORE the current object when ARG = 0,
+ ;; which seems inconsistent with the ARG /= 0 case.
+ ;; FIXME document SPECIAL.
+ (defun transpose-subr (mover arg &optional special)
+ "Subroutine to do the work of transposing objects.
+ Works for lines, sentences, paragraphs, etc. MOVER is a function that
+ moves forward by units of the given object (e.g. forward-sentence,
+ forward-paragraph). If ARG is zero, exchanges the current object
+ with the one containing mark. If ARG is an integer, moves the
+ current object past ARG following (if ARG is positive) or
+ preceding (if ARG is negative) objects, leaving point after the
+ current object."
+ (let ((aux (if special mover
+ (lambda (x)
+ (cons (progn (funcall mover x) (point))
+ (progn (funcall mover (- x)) (point))))))
+ pos1 pos2)
+ (cond
+ ((= arg 0)
+ (save-excursion
+ (setq pos1 (funcall aux 1))
+ (goto-char (or (mark) (error "No mark set in this buffer")))
+ (setq pos2 (funcall aux 1))
+ (transpose-subr-1 pos1 pos2))
+ (exchange-point-and-mark))
+ ((> arg 0)
+ (setq pos1 (funcall aux -1))
+ (setq pos2 (funcall aux arg))
+ (transpose-subr-1 pos1 pos2)
+ (goto-char (car pos2)))
+ (t
+ (setq pos1 (funcall aux -1))
+ (goto-char (car pos1))
+ (setq pos2 (funcall aux arg))
+ (transpose-subr-1 pos1 pos2)))))
+
+ (defun transpose-subr-1 (pos1 pos2)
+ (when (> (car pos1) (cdr pos1)) (setq pos1 (cons (cdr pos1) (car pos1))))
+ (when (> (car pos2) (cdr pos2)) (setq pos2 (cons (cdr pos2) (car pos2))))
+ (when (> (car pos1) (car pos2))
+ (let ((swap pos1))
+ (setq pos1 pos2 pos2 swap)))
+ (if (> (cdr pos1) (car pos2)) (error "Don't have two things to transpose"))
+ (atomic-change-group
+ ;; This sequence of insertions attempts to preserve marker
+ ;; positions at the start and end of the transposed objects.
+ (let* ((word (buffer-substring (car pos2) (cdr pos2)))
+ (len1 (- (cdr pos1) (car pos1)))
+ (len2 (length word))
+ (boundary (make-marker)))
+ (set-marker boundary (car pos2))
+ (goto-char (cdr pos1))
+ (insert-before-markers word)
+ (setq word (delete-and-extract-region (car pos1) (+ (car pos1) len1)))
+ (goto-char boundary)
+ (insert word)
+ (goto-char (+ boundary len1))
+ (delete-region (point) (+ (point) len2))
+ (set-marker boundary nil))))
+ \f
+ (defun backward-word (&optional arg)
+ "Move backward until encountering the beginning of a word.
+ With argument ARG, do this that many times.
+ If ARG is omitted or nil, move point backward one word."
+ (interactive "^p")
+ (forward-word (- (or arg 1))))
+
+ (defun mark-word (&optional arg allow-extend)
+ "Set mark ARG words away from point.
+ The place mark goes is the same place \\[forward-word] would
+ move to with the same argument.
+ Interactively, if this command is repeated
+ or (in Transient Mark mode) if the mark is active,
+ it marks the next ARG words after the ones already marked."
+ (interactive "P\np")
+ (cond ((and allow-extend
+ (or (and (eq last-command this-command) (mark t))
+ (region-active-p)))
+ (setq arg (if arg (prefix-numeric-value arg)
+ (if (< (mark) (point)) -1 1)))
+ (set-mark
+ (save-excursion
+ (goto-char (mark))
+ (forward-word arg)
+ (point))))
+ (t
+ (push-mark
+ (save-excursion
+ (forward-word (prefix-numeric-value arg))
+ (point))
+ nil t))))
+
+ (defun kill-word (arg)
+ "Kill characters forward until encountering the end of a word.
+ With argument ARG, do this that many times."
+ (interactive "p")
+ (kill-region (point) (progn (forward-word arg) (point))))
+
+ (defun backward-kill-word (arg)
+ "Kill characters backward until encountering the beginning of a word.
+ With argument ARG, do this that many times."
+ (interactive "p")
+ (kill-word (- arg)))
+
+ (defun current-word (&optional strict really-word)
+ "Return the symbol or word that point is on (or a nearby one) as a string.
+ The return value includes no text properties.
+ If optional arg STRICT is non-nil, return nil unless point is within
+ or adjacent to a symbol or word. In all cases the value can be nil
+ if there is no word nearby.
+ The function, belying its name, normally finds a symbol.
+ If optional arg REALLY-WORD is non-nil, it finds just a word."
+ (save-excursion
+ (let* ((oldpoint (point)) (start (point)) (end (point))
+ (syntaxes (if really-word "w" "w_"))
+ (not-syntaxes (concat "^" syntaxes)))
+ (skip-syntax-backward syntaxes) (setq start (point))
+ (goto-char oldpoint)
+ (skip-syntax-forward syntaxes) (setq end (point))
+ (when (and (eq start oldpoint) (eq end oldpoint)
+ ;; Point is neither within nor adjacent to a word.
+ (not strict))
+ ;; Look for preceding word in same line.
+ (skip-syntax-backward not-syntaxes (line-beginning-position))
+ (if (bolp)
+ ;; No preceding word in same line.
+ ;; Look for following word in same line.
+ (progn
+ (skip-syntax-forward not-syntaxes (line-end-position))
+ (setq start (point))
+ (skip-syntax-forward syntaxes)
+ (setq end (point)))
+ (setq end (point))
+ (skip-syntax-backward syntaxes)
+ (setq start (point))))
+ ;; If we found something nonempty, return it as a string.
+ (unless (= start end)
+ (buffer-substring-no-properties start end)))))
+ \f
+ (defcustom fill-prefix nil
+ "String for filling to insert at front of new line, or nil for none."
+ :type '(choice (const :tag "None" nil)
+ string)
+ :group 'fill)
+ (make-variable-buffer-local 'fill-prefix)
+ (put 'fill-prefix 'safe-local-variable 'string-or-null-p)
+
+ (defcustom auto-fill-inhibit-regexp nil
+ "Regexp to match lines which should not be auto-filled."
+ :type '(choice (const :tag "None" nil)
+ regexp)
+ :group 'fill)
+
+ (defun do-auto-fill ()
+ "The default value for `normal-auto-fill-function'.
+ This is the default auto-fill function, some major modes use a different one.
+ Returns t if it really did any work."
+ (let (fc justify give-up
+ (fill-prefix fill-prefix))
+ (if (or (not (setq justify (current-justification)))
+ (null (setq fc (current-fill-column)))
+ (and (eq justify 'left)
+ (<= (current-column) fc))
+ (and auto-fill-inhibit-regexp
+ (save-excursion (beginning-of-line)
+ (looking-at auto-fill-inhibit-regexp))))
+ nil ;; Auto-filling not required
+ (if (memq justify '(full center right))
+ (save-excursion (unjustify-current-line)))
+
+ ;; Choose a fill-prefix automatically.
+ (when (and adaptive-fill-mode
+ (or (null fill-prefix) (string= fill-prefix "")))
+ (let ((prefix
+ (fill-context-prefix
+ (save-excursion (fill-forward-paragraph -1) (point))
+ (save-excursion (fill-forward-paragraph 1) (point)))))
+ (and prefix (not (equal prefix ""))
+ ;; Use auto-indentation rather than a guessed empty prefix.
+ (not (and fill-indent-according-to-mode
+ (string-match "\\`[ \t]*\\'" prefix)))
+ (setq fill-prefix prefix))))
+
+ (while (and (not give-up) (> (current-column) fc))
+ ;; Determine where to split the line.
+ (let* (after-prefix
+ (fill-point
+ (save-excursion
+ (beginning-of-line)
+ (setq after-prefix (point))
+ (and fill-prefix
+ (looking-at (regexp-quote fill-prefix))
+ (setq after-prefix (match-end 0)))
+ (move-to-column (1+ fc))
+ (fill-move-to-break-point after-prefix)
+ (point))))
+
+ ;; See whether the place we found is any good.
+ (if (save-excursion
+ (goto-char fill-point)
+ (or (bolp)
+ ;; There is no use breaking at end of line.
+ (save-excursion (skip-chars-forward " ") (eolp))
+ ;; It is futile to split at the end of the prefix
+ ;; since we would just insert the prefix again.
+ (and after-prefix (<= (point) after-prefix))
+ ;; Don't split right after a comment starter
+ ;; since we would just make another comment starter.
+ (and comment-start-skip
+ (let ((limit (point)))
+ (beginning-of-line)
+ (and (re-search-forward comment-start-skip
+ limit t)
+ (eq (point) limit))))))
+ ;; No good place to break => stop trying.
+ (setq give-up t)
+ ;; Ok, we have a useful place to break the line. Do it.
+ (let ((prev-column (current-column)))
+ ;; If point is at the fill-point, do not `save-excursion'.
+ ;; Otherwise, if a comment prefix or fill-prefix is inserted,
+ ;; point will end up before it rather than after it.
+ (if (save-excursion
+ (skip-chars-backward " \t")
+ (= (point) fill-point))
+ (default-indent-new-line t)
+ (save-excursion
+ (goto-char fill-point)
+ (default-indent-new-line t)))
+ ;; Now do justification, if required
+ (if (not (eq justify 'left))
+ (save-excursion
+ (end-of-line 0)
+ (justify-current-line justify nil t)))
+ ;; If making the new line didn't reduce the hpos of
+ ;; the end of the line, then give up now;
+ ;; trying again will not help.
+ (if (>= (current-column) prev-column)
+ (setq give-up t))))))
+ ;; Justify last line.
+ (justify-current-line justify t t)
+ t)))
+
+ (defvar comment-line-break-function 'comment-indent-new-line
+ "Mode-specific function which line breaks and continues a comment.
+ This function is called during auto-filling when a comment syntax
+ is defined.
+ The function should take a single optional argument, which is a flag
+ indicating whether it should use soft newlines.")
+
+ (defun default-indent-new-line (&optional soft)
+ "Break line at point and indent.
+ If a comment syntax is defined, call `comment-indent-new-line'.
+
+ The inserted newline is marked hard if variable `use-hard-newlines' is true,
+ unless optional argument SOFT is non-nil."
+ (interactive)
+ (if comment-start
+ (funcall comment-line-break-function soft)
+ ;; Insert the newline before removing empty space so that markers
+ ;; get preserved better.
+ (if soft (insert-and-inherit ?\n) (newline 1))
+ (save-excursion (forward-char -1) (delete-horizontal-space))
+ (delete-horizontal-space)
+
+ (if (and fill-prefix (not adaptive-fill-mode))
+ ;; Blindly trust a non-adaptive fill-prefix.
+ (progn
+ (indent-to-left-margin)
+ (insert-before-markers-and-inherit fill-prefix))
+
+ (cond
+ ;; If there's an adaptive prefix, use it unless we're inside
+ ;; a comment and the prefix is not a comment starter.
+ (fill-prefix
+ (indent-to-left-margin)
+ (insert-and-inherit fill-prefix))
+ ;; If we're not inside a comment, just try to indent.
+ (t (indent-according-to-mode))))))
+
+ (defvar normal-auto-fill-function 'do-auto-fill
+ "The function to use for `auto-fill-function' if Auto Fill mode is turned on.
+ Some major modes set this.")
+
+ (put 'auto-fill-function :minor-mode-function 'auto-fill-mode)
+ ;; `functions' and `hooks' are usually unsafe to set, but setting
+ ;; auto-fill-function to nil in a file-local setting is safe and
+ ;; can be useful to prevent auto-filling.
+ (put 'auto-fill-function 'safe-local-variable 'null)
+
+ (define-minor-mode auto-fill-mode
+ "Toggle automatic line breaking (Auto Fill mode).
+ With a prefix argument ARG, enable Auto Fill mode if ARG is
+ positive, and disable it otherwise. If called from Lisp, enable
+ the mode if ARG is omitted or nil.
+
+ When Auto Fill mode is enabled, inserting a space at a column
+ beyond `current-fill-column' automatically breaks the line at a
+ previous space.
+
+ When `auto-fill-mode' is on, the `auto-fill-function' variable is
+ non-`nil'.
+
+ The value of `normal-auto-fill-function' specifies the function to use
+ for `auto-fill-function' when turning Auto Fill mode on."
+ :variable (auto-fill-function
+ . (lambda (v) (setq auto-fill-function
+ (if v normal-auto-fill-function)))))
+
+ ;; This holds a document string used to document auto-fill-mode.
+ (defun auto-fill-function ()
+ "Automatically break line at a previous space, in insertion of text."
+ nil)
+
+ (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)
+ "Set `fill-column' to specified argument.
+ Use \\[universal-argument] followed by a number to specify a column.
+ Just \\[universal-argument] as argument means to use the current column."
+ (interactive
+ (list (or current-prefix-arg
+ ;; We used to use current-column silently, but C-x f is too easily
+ ;; typed as a typo for C-x C-f, so we turned it into an error and
+ ;; now an interactive prompt.
+ (read-number "Set fill-column to: " (current-column)))))
+ (if (consp arg)
+ (setq arg (current-column)))
+ (if (not (integerp arg))
+ ;; Disallow missing argument; it's probably a typo for C-x C-f.
+ (error "set-fill-column requires an explicit argument")
+ (message "Fill column set to %d (was %d)" arg fill-column)
+ (setq fill-column arg)))
+ \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,
+ lines whose indentation is >= that value are not displayed.
+ The variable `selective-display' has a separate value for each buffer."
+ (interactive "P")
+ (if (eq selective-display t)
+ (error "selective-display already in use for marked lines"))
+ (let ((current-vpos
+ (save-restriction
+ (narrow-to-region (point-min) (point))
+ (goto-char (window-start))
+ (vertical-motion (window-height)))))
+ (setq selective-display
+ (and arg (prefix-numeric-value arg)))
+ (recenter current-vpos))
+ (set-window-start (selected-window) (window-start))
+ (princ "selective-display set to " t)
+ (prin1 selective-display t)
+ (princ "." t))
+
+ (defvaralias 'indicate-unused-lines 'indicate-empty-lines)
+
+ (defun toggle-truncate-lines (&optional arg)
+ "Toggle truncating of long lines for the current buffer.
+ When truncating is off, long lines are folded.
+ With prefix argument ARG, truncate long lines if ARG is positive,
+ otherwise fold them. Note that in side-by-side windows, this
+ command has no effect if `truncate-partial-width-windows' is
+ non-nil."
+ (interactive "P")
+ (setq truncate-lines
+ (if (null arg)
+ (not truncate-lines)
+ (> (prefix-numeric-value arg) 0)))
+ (force-mode-line-update)
+ (unless truncate-lines
+ (let ((buffer (current-buffer)))
+ (walk-windows (lambda (window)
+ (if (eq buffer (window-buffer window))
+ (set-window-hscroll window 0)))
+ nil t)))
+ (message "Truncate long lines %s"
+ (if truncate-lines "enabled" "disabled")))
+
+ (defun toggle-word-wrap (&optional arg)
+ "Toggle whether to use word-wrapping for continuation lines.
+ With prefix argument ARG, wrap continuation lines at word boundaries
+ if ARG is positive, otherwise wrap them at the right screen edge.
+ This command toggles the value of `word-wrap'. It has no effect
+ if long lines are truncated."
+ (interactive "P")
+ (setq word-wrap
+ (if (null arg)
+ (not word-wrap)
+ (> (prefix-numeric-value arg) 0)))
+ (force-mode-line-update)
+ (message "Word wrapping %s"
+ (if word-wrap "enabled" "disabled")))
+
+ (defvar overwrite-mode-textual (purecopy " Ovwrt")
+ "The string displayed in the mode line when in overwrite mode.")
+ (defvar overwrite-mode-binary (purecopy " Bin Ovwrt")
+ "The string displayed in the mode line when in binary overwrite mode.")
+
+ (define-minor-mode overwrite-mode
+ "Toggle Overwrite mode.
+ With a prefix argument ARG, enable Overwrite mode if ARG is
+ positive, and disable it otherwise. If called from Lisp, enable
+ the mode if ARG is omitted or nil.
+
+ When Overwrite mode is enabled, printing characters typed in
+ replace existing text on a one-for-one basis, rather than pushing
+ it to the right. At the end of a line, such characters extend
+ the line. Before a tab, such characters insert until the tab is
+ filled in. \\[quoted-insert] still inserts characters in
+ overwrite mode; this is supposed to make it easier to insert
+ characters when necessary."
+ :variable (overwrite-mode
+ . (lambda (v) (setq overwrite-mode (if v 'overwrite-mode-textual)))))
+
+ (define-minor-mode binary-overwrite-mode
+ "Toggle Binary Overwrite mode.
+ With a prefix argument ARG, enable Binary Overwrite mode if ARG
+ is positive, and disable it otherwise. If called from Lisp,
+ enable the mode if ARG is omitted or nil.
+
+ When Binary Overwrite mode is enabled, printing characters typed
+ in replace existing text. Newlines are not treated specially, so
+ typing at the end of a line joins the line to the next, with the
+ typed character between them. Typing before a tab character
+ simply replaces the tab with the character typed.
+ \\[quoted-insert] replaces the text at the cursor, just as
+ ordinary typing characters do.
+
+ Note that Binary Overwrite mode is not its own minor mode; it is
+ a specialization of overwrite mode, entered by setting the
+ `overwrite-mode' variable to `overwrite-mode-binary'."
+ :variable (overwrite-mode
+ . (lambda (v) (setq overwrite-mode (if v 'overwrite-mode-binary)))))
+
+ (define-minor-mode line-number-mode
+ "Toggle line number display in the mode line (Line Number mode).
+ With a prefix argument ARG, enable Line Number mode if ARG is
+ positive, and disable it otherwise. If called from Lisp, enable
+ the mode if ARG is omitted or nil.
+
+ Line numbers do not appear for very large buffers and buffers
+ with very long lines; see variables `line-number-display-limit'
+ and `line-number-display-limit-width'."
+ :init-value t :global t :group 'mode-line)
+
+ (define-minor-mode column-number-mode
+ "Toggle column number display in the mode line (Column Number mode).
+ With a prefix argument ARG, enable Column Number mode if ARG is
+ positive, and disable it otherwise.
+
+ If called from Lisp, enable the mode if ARG is omitted or nil."
+ :global t :group 'mode-line)
+
+ (define-minor-mode size-indication-mode
+ "Toggle buffer size display in the mode line (Size Indication mode).
+ With a prefix argument ARG, enable Size Indication mode if ARG is
+ positive, and disable it otherwise.
+
+ If called from Lisp, enable the mode if ARG is omitted or nil."
+ :global t :group 'mode-line)
+
+ (define-minor-mode auto-save-mode
+ "Toggle auto-saving in the current buffer (Auto Save mode).
+ With a prefix argument ARG, enable Auto Save mode if ARG is
+ positive, and disable it otherwise.
+
+ If called from Lisp, enable the mode if ARG is omitted or nil."
+ :variable ((and buffer-auto-save-file-name
+ ;; If auto-save is off because buffer has shrunk,
+ ;; then toggling should turn it on.
+ (>= buffer-saved-size 0))
+ . (lambda (val)
+ (setq buffer-auto-save-file-name
+ (cond
+ ((null val) nil)
+ ((and buffer-file-name auto-save-visited-file-name
+ (not buffer-read-only))
+ buffer-file-name)
+ (t (make-auto-save-file-name))))))
+ ;; If -1 was stored here, to temporarily turn off saving,
+ ;; turn it back on.
+ (and (< buffer-saved-size 0)
+ (setq buffer-saved-size 0)))
+ \f
+ (defgroup paren-blinking nil
+ "Blinking matching of parens and expressions."
+ :prefix "blink-matching-"
+ :group 'paren-matching)
+
+ (defcustom blink-matching-paren t
+ "Non-nil means show matching open-paren when close-paren is inserted.
+ If t, highlight the paren. If `jump', move cursor to its position."
+ :type '(choice
+ (const :tag "Disable" nil)
+ (const :tag "Highlight" t)
+ (const :tag "Move cursor" jump))
+ :group 'paren-blinking)
+
+ (defcustom blink-matching-paren-on-screen t
+ "Non-nil means show matching open-paren when it is on screen.
+ If nil, don't show it (but the open-paren can still be shown
+ when it is off screen).
+
+ This variable has no effect if `blink-matching-paren' is nil.
+ \(In that case, the open-paren is never shown.)
+ It is also ignored if `show-paren-mode' is enabled."
+ :type 'boolean
+ :group 'paren-blinking)
+
+ (defcustom blink-matching-paren-distance (* 100 1024)
+ "If non-nil, maximum distance to search backwards for matching open-paren.
+ If nil, search stops at the beginning of the accessible portion of the buffer."
+ :version "23.2" ; 25->100k
+ :type '(choice (const nil) integer)
+ :group 'paren-blinking)
+
+ (defcustom blink-matching-delay 1
+ "Time in seconds to delay after showing a matching paren."
+ :type 'number
+ :group 'paren-blinking)
+
+ (defcustom blink-matching-paren-dont-ignore-comments nil
+ "If nil, `blink-matching-paren' ignores comments.
+ More precisely, when looking for the matching parenthesis,
+ it skips the contents of comments that end before point."
+ :type 'boolean
+ :group 'paren-blinking)
+
+ (defun blink-matching-check-mismatch (start end)
+ "Return whether or not START...END are matching parens.
+ END is the current point and START is the blink position.
+ START might be nil if no matching starter was found.
+ Returns non-nil if we find there is a mismatch."
+ (let* ((end-syntax (syntax-after (1- end)))
+ (matching-paren (and (consp end-syntax)
+ (eq (syntax-class end-syntax) 5)
+ (cdr end-syntax))))
+ ;; For self-matched chars like " and $, we can't know when they're
+ ;; mismatched or unmatched, so we can only do it for parens.
+ (when matching-paren
+ (not (and start
+ (or
+ (eq (char-after start) matching-paren)
+ ;; The cdr might hold a new paren-class info rather than
+ ;; a matching-char info, in which case the two CDRs
+ ;; should match.
+ (eq matching-paren (cdr-safe (syntax-after start)))))))))
+
+ (defvar blink-matching-check-function #'blink-matching-check-mismatch
+ "Function to check parentheses mismatches.
+ The function takes two arguments (START and END) where START is the
+ position just before the opening token and END is the position right after.
+ START can be nil, if it was not found.
+ The function should return non-nil if the two tokens do not match.")
+
+ (defvar blink-matching--overlay
+ (let ((ol (make-overlay (point) (point) nil t)))
+ (overlay-put ol 'face 'show-paren-match)
+ (delete-overlay ol)
+ ol)
+ "Overlay used to highlight the matching paren.")
+
+ (defun blink-matching-open ()
+ "Momentarily highlight the beginning of the sexp before point."
+ (interactive)
+ (when (and (not (bobp))
+ blink-matching-paren)
+ (let* ((oldpos (point))
+ (message-log-max nil) ; Don't log messages about paren matching.
+ (blinkpos
+ (save-excursion
+ (save-restriction
+ (if blink-matching-paren-distance
+ (narrow-to-region
+ (max (minibuffer-prompt-end) ;(point-min) unless minibuf.
+ (- (point) blink-matching-paren-distance))
+ oldpos))
+ (let ((parse-sexp-ignore-comments
+ (and parse-sexp-ignore-comments
+ (not blink-matching-paren-dont-ignore-comments))))
+ (condition-case ()
+ (progn
+ (forward-sexp -1)
+ ;; backward-sexp skips backward over prefix chars,
+ ;; so move back to the matching paren.
+ (while (and (< (point) (1- oldpos))
+ (let ((code (syntax-after (point))))
+ (or (eq (syntax-class code) 6)
+ (eq (logand 1048576 (car code))
+ 1048576))))
+ (forward-char 1))
+ (point))
+ (error nil))))))
+ (mismatch (funcall blink-matching-check-function blinkpos oldpos)))
+ (cond
+ (mismatch
+ (if blinkpos
+ (if (minibufferp)
+ (minibuffer-message "Mismatched parentheses")
+ (message "Mismatched parentheses"))
+ (if (minibufferp)
+ (minibuffer-message "No matching parenthesis found")
+ (message "No matching parenthesis found"))))
+ ((not blinkpos) nil)
+ ((pos-visible-in-window-p blinkpos)
+ ;; Matching open within window, temporarily move to or highlight
+ ;; char after blinkpos but only if `blink-matching-paren-on-screen'
+ ;; is non-nil.
+ (and blink-matching-paren-on-screen
+ (not show-paren-mode)
+ (if (eq blink-matching-paren 'jump)
+ (save-excursion
+ (goto-char blinkpos)
+ (sit-for blink-matching-delay))
+ (unwind-protect
+ (progn
+ (move-overlay blink-matching--overlay blinkpos (1+ blinkpos)
+ (current-buffer))
+ (sit-for blink-matching-delay))
+ (delete-overlay blink-matching--overlay)))))
+ (t
+ (save-excursion
+ (goto-char blinkpos)
+ (let ((open-paren-line-string
+ ;; Show what precedes the open in its line, if anything.
+ (cond
+ ((save-excursion (skip-chars-backward " \t") (not (bolp)))
+ (buffer-substring (line-beginning-position)
+ (1+ blinkpos)))
+ ;; Show what follows the open in its line, if anything.
+ ((save-excursion
+ (forward-char 1)
+ (skip-chars-forward " \t")
+ (not (eolp)))
+ (buffer-substring blinkpos
+ (line-end-position)))
+ ;; Otherwise show the previous nonblank line,
+ ;; if there is one.
+ ((save-excursion (skip-chars-backward "\n \t") (not (bobp)))
+ (concat
+ (buffer-substring (progn
+ (skip-chars-backward "\n \t")
+ (line-beginning-position))
+ (progn (end-of-line)
+ (skip-chars-backward " \t")
+ (point)))
+ ;; Replace the newline and other whitespace with `...'.
+ "..."
+ (buffer-substring blinkpos (1+ blinkpos))))
+ ;; There is nothing to show except the char itself.
+ (t (buffer-substring blinkpos (1+ blinkpos))))))
+ (message "Matches %s"
+ (substring-no-properties open-paren-line-string)))))))))
+
+ (defvar blink-paren-function 'blink-matching-open
+ "Function called, if non-nil, whenever a close parenthesis is inserted.
+ More precisely, a char with closeparen syntax is self-inserted.")
+
+ (defun blink-paren-post-self-insert-function ()
+ (when (and (eq (char-before) last-command-event) ; Sanity check.
+ (memq (char-syntax last-command-event) '(?\) ?\$))
+ blink-paren-function
+ (not executing-kbd-macro)
+ (not noninteractive)
+ ;; Verify an even number of quoting characters precede the close.
+ (= 1 (logand 1 (- (point)
+ (save-excursion
+ (forward-char -1)
+ (skip-syntax-backward "/\\")
+ (point))))))
+ (funcall blink-paren-function)))
+
+ (put 'blink-paren-post-self-insert-function 'priority 100)
+
+ (add-hook 'post-self-insert-hook #'blink-paren-post-self-insert-function
+ ;; Most likely, this hook is nil, so this arg doesn't matter,
+ ;; but I use it as a reminder that this function usually
+ ;; likes to be run after others since it does
+ ;; `sit-for'. That's also the reason it get a `priority' prop
+ ;; of 100.
+ 'append)
+ \f
+ ;; This executes C-g typed while Emacs is waiting for a command.
+ ;; Quitting out of a program does not go through here;
+ ;; that happens in the QUIT macro at the C code level.
+ (defun keyboard-quit ()
+ "Signal a `quit' condition.
+ During execution of Lisp code, this character causes a quit directly.
+ At top-level, as an editor command, this simply beeps."
+ (interactive)
+ ;; Avoid adding the region to the window selection.
+ (setq saved-region-selection nil)
+ (let (select-active-regions)
+ (deactivate-mark))
+ (if (fboundp 'kmacro-keyboard-quit)
+ (kmacro-keyboard-quit))
+ ;; Force the next redisplay cycle to remove the "Def" indicator from
+ ;; all the mode lines.
+ (if defining-kbd-macro
+ (force-mode-line-update t))
+ (setq defining-kbd-macro nil)
+ (let ((debug-on-quit nil))
+ (signal 'quit nil)))
+
+ (defvar buffer-quit-function nil
+ "Function to call to \"quit\" the current buffer, or nil if none.
+ \\[keyboard-escape-quit] calls this function when its more local actions
+ \(such as canceling a prefix argument, minibuffer or region) do not apply.")
+
+ (defun keyboard-escape-quit ()
+ "Exit the current \"mode\" (in a generalized sense of the word).
+ This command can exit an interactive command such as `query-replace',
+ can clear out a prefix argument or a region,
+ can get out of the minibuffer or other recursive edit,
+ cancel the use of the current buffer (for special-purpose buffers),
+ or go back to just one window (by deleting all but the selected window)."
+ (interactive)
+ (cond ((eq last-command 'mode-exited) nil)
+ ((region-active-p)
+ (deactivate-mark))
+ ((> (minibuffer-depth) 0)
+ (abort-recursive-edit))
+ (current-prefix-arg
+ nil)
+ ((> (recursion-depth) 0)
+ (exit-recursive-edit))
+ (buffer-quit-function
+ (funcall buffer-quit-function))
+ ((not (one-window-p t))
+ (delete-other-windows))
+ ((string-match "^ \\*" (buffer-name (current-buffer)))
+ (bury-buffer))))
+
+ (defun play-sound-file (file &optional volume device)
+ "Play sound stored in FILE.
+ VOLUME and DEVICE correspond to the keywords of the sound
+ specification for `play-sound'."
+ (interactive "fPlay sound file: ")
+ (let ((sound (list :file file)))
+ (if volume
+ (plist-put sound :volume volume))
+ (if device
+ (plist-put sound :device device))
+ (push 'sound sound)
+ (play-sound sound)))
+
+ \f
+ (defcustom read-mail-command 'rmail
+ "Your preference for a mail reading package.
+ This is used by some keybindings which support reading mail.
+ See also `mail-user-agent' concerning sending mail."
+ :type '(radio (function-item :tag "Rmail" :format "%t\n" rmail)
+ (function-item :tag "Gnus" :format "%t\n" gnus)
+ (function-item :tag "Emacs interface to MH"
+ :format "%t\n" mh-rmail)
+ (function :tag "Other"))
+ :version "21.1"
+ :group 'mail)
+
+ (defcustom mail-user-agent 'message-user-agent
+ "Your preference for a mail composition package.
+ 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:
+
+ `message-user-agent' -- use the Message package.
+ See Info node `(message)'.
+ `sendmail-user-agent' -- use the 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)'.
+ `gnus-user-agent' -- like `message-user-agent', but with Gnus
+ paraphernalia if Gnus is running, particularly
+ the Gcc: header for archiving.
+
+ Additional valid symbols may be available; check with the author of
+ your package for details. The function should return non-nil if it
+ succeeds.
+
+ See also `read-mail-command' concerning reading mail."
+ :type '(radio (function-item :tag "Message package"
+ :format "%t\n"
+ message-user-agent)
+ (function-item :tag "Mail package"
+ :format "%t\n"
+ sendmail-user-agent)
+ (function-item :tag "Emacs interface to MH"
+ :format "%t\n"
+ mh-e-user-agent)
+ (function-item :tag "Message with full Gnus features"
+ :format "%t\n"
+ gnus-user-agent)
+ (function :tag "Other"))
+ :version "23.2" ; sendmail->message
+ :group 'mail)
+
+ (defcustom compose-mail-user-agent-warnings t
+ "If non-nil, `compose-mail' warns about changes in `mail-user-agent'.
+ If the value of `mail-user-agent' is the default, and the user
+ appears to have customizations applying to the old default,
+ `compose-mail' issues a warning."
+ :type 'boolean
+ :version "23.2"
+ :group 'mail)
+
+ (defun rfc822-goto-eoh ()
+ "If the buffer starts with a mail header, move point to the header's end.
+ Otherwise, moves to `point-min'.
+ The end of the header is the start of the next line, if there is one,
+ else the end of the last line. This function obeys RFC822."
+ (goto-char (point-min))
+ (when (re-search-forward
+ "^\\([:\n]\\|[^: \t\n]+[ \t\n]\\)" nil 'move)
+ (goto-char (match-beginning 0))))
+
+ ;; Used by Rmail (e.g., rmail-forward).
+ (defvar mail-encode-mml nil
+ "If non-nil, mail-user-agent's `sendfunc' command should mml-encode
+ the outgoing message before sending it.")
+
+ (defun compose-mail (&optional to subject other-headers continue
+ switch-function yank-action send-actions
+ return-action)
+ "Start composing a mail message to send.
+ This uses the user's chosen mail composition package
+ as selected with the variable `mail-user-agent'.
+ The optional arguments TO and SUBJECT specify recipients
+ and the initial Subject field, respectively.
+
+ OTHER-HEADERS is an alist specifying additional
+ header fields. Elements look like (HEADER . VALUE) where both
+ HEADER and VALUE are strings.
+
+ CONTINUE, if non-nil, says to continue editing a message already
+ being composed. Interactively, CONTINUE is the prefix argument.
+
+ SWITCH-FUNCTION, if non-nil, is a function to use to
+ switch to and display the buffer used for mail composition.
+
+ YANK-ACTION, if non-nil, is an action to perform, if and when necessary,
+ to insert the raw text of the message being replied to.
+ It has the form (FUNCTION . ARGS). The user agent will apply
+ FUNCTION to ARGS, to insert the raw text of the original message.
+ \(The user agent will also run `mail-citation-hook', *after* the
+ original text has been inserted in this way.)
+
+ SEND-ACTIONS is a list of actions to call when the message is sent.
+ Each action has the form (FUNCTION . ARGS).
+
+ RETURN-ACTION, if non-nil, is an action for returning to the
+ caller. It has the form (FUNCTION . ARGS). The function is
+ called after the mail has been sent or put aside, and the mail
+ buffer buried."
+ (interactive
+ (list nil nil nil current-prefix-arg))
+
+ ;; In Emacs 23.2, the default value of `mail-user-agent' changed
+ ;; from sendmail-user-agent to message-user-agent. Some users may
+ ;; encounter incompatibilities. This hack tries to detect problems
+ ;; and warn about them.
+ (and compose-mail-user-agent-warnings
+ (eq mail-user-agent 'message-user-agent)
+ (let (warn-vars)
+ (dolist (var '(mail-mode-hook mail-send-hook mail-setup-hook
+ mail-yank-hooks mail-archive-file-name
+ mail-default-reply-to mail-mailing-lists
+ mail-self-blind))
+ (and (boundp var)
+ (symbol-value var)
+ (push var warn-vars)))
+ (when warn-vars
+ (display-warning 'mail
+ (format "\
+ The default mail mode is now Message mode.
+ You have the following Mail mode variable%s customized:
+ \n %s\n\nTo use Mail mode, set `mail-user-agent' to sendmail-user-agent.
+ To disable this warning, set `compose-mail-user-agent-warnings' to nil."
+ (if (> (length warn-vars) 1) "s" "")
+ (mapconcat 'symbol-name
+ warn-vars " "))))))
+
+ (let ((function (get mail-user-agent 'composefunc)))
+ (funcall function to subject other-headers continue switch-function
+ yank-action send-actions return-action)))
+
+ (defun compose-mail-other-window (&optional to subject other-headers continue
+ yank-action send-actions
+ return-action)
+ "Like \\[compose-mail], but edit the outgoing message in another window."
+ (interactive (list nil nil nil current-prefix-arg))
+ (compose-mail to subject other-headers continue
+ 'switch-to-buffer-other-window yank-action send-actions
+ return-action))
+
+ (defun compose-mail-other-frame (&optional to subject other-headers continue
+ yank-action send-actions
+ return-action)
+ "Like \\[compose-mail], but edit the outgoing message in another frame."
+ (interactive (list nil nil nil current-prefix-arg))
+ (compose-mail to subject other-headers continue
+ 'switch-to-buffer-other-frame yank-action send-actions
+ return-action))
+
+ \f
+ (defvar set-variable-value-history nil
+ "History of values entered with `set-variable'.
+
+ Maximum length of the history list is determined by the value
+ of `history-length', which see.")
+
+ (defun set-variable (variable value &optional make-local)
+ "Set VARIABLE to VALUE. VALUE is a Lisp object.
+ VARIABLE should be a user option variable name, a Lisp variable
+ meant to be customized by users. You should enter VALUE in Lisp syntax,
+ so if you want VALUE to be a string, you must surround it with doublequotes.
+ VALUE is used literally, not evaluated.
+
+ If VARIABLE has a `variable-interactive' property, that is used as if
+ it were the arg to `interactive' (which see) to interactively read VALUE.
+
+ If VARIABLE has been defined with `defcustom', then the type information
+ in the definition is used to check that VALUE is valid.
+
+ With a prefix argument, set VARIABLE to VALUE buffer-locally."
+ (interactive
+ (let* ((default-var (variable-at-point))
+ (var (if (custom-variable-p default-var)
+ (read-variable (format "Set variable (default %s): " default-var)
+ default-var)
+ (read-variable "Set variable: ")))
+ (minibuffer-help-form '(describe-variable var))
+ (prop (get var 'variable-interactive))
+ (obsolete (car (get var 'byte-obsolete-variable)))
+ (prompt (format "Set %s %s to value: " var
+ (cond ((local-variable-p var)
+ "(buffer-local)")
+ ((or current-prefix-arg
+ (local-variable-if-set-p var))
+ "buffer-locally")
+ (t "globally"))))
+ (val (progn
+ (when obsolete
+ (message (concat "`%S' is obsolete; "
+ (if (symbolp obsolete) "use `%S' instead" "%s"))
+ var obsolete)
+ (sit-for 3))
+ (if prop
+ ;; Use VAR's `variable-interactive' property
+ ;; as an interactive spec for prompting.
+ (call-interactively `(lambda (arg)
+ (interactive ,prop)
+ arg))
+ (read-from-minibuffer prompt nil
+ read-expression-map t
+ 'set-variable-value-history
+ (format "%S" (symbol-value var)))))))
+ (list var val current-prefix-arg)))
+
+ (and (custom-variable-p variable)
+ (not (get variable 'custom-type))
+ (custom-load-symbol variable))
+ (let ((type (get variable 'custom-type)))
+ (when type
+ ;; Match with custom type.
+ (require 'cus-edit)
+ (setq type (widget-convert type))
+ (unless (widget-apply type :match value)
+ (error "Value `%S' does not match type %S of %S"
+ value (car type) variable))))
+
+ (if make-local
+ (make-local-variable variable))
+
+ (set variable value)
+
+ ;; Force a thorough redisplay for the case that the variable
+ ;; has an effect on the display, like `tab-width' has.
+ (force-mode-line-update))
+ \f
+ ;; Define the major mode for lists of completions.
+
+ (defvar completion-list-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [mouse-2] 'choose-completion)
+ (define-key map [follow-link] 'mouse-face)
+ (define-key map [down-mouse-2] nil)
+ (define-key map "\C-m" 'choose-completion)
+ (define-key map "\e\e\e" 'delete-completion-window)
+ (define-key map [left] 'previous-completion)
+ (define-key map [right] 'next-completion)
+ (define-key map "q" 'quit-window)
+ (define-key map "z" 'kill-this-buffer)
+ map)
+ "Local map for completion list buffers.")
+
+ ;; Completion mode is suitable only for specially formatted data.
+ (put 'completion-list-mode 'mode-class 'special)
+
+ (defvar completion-reference-buffer nil
+ "Record the buffer that was current when the completion list was requested.
+ This is a local variable in the completion list buffer.
+ Initial value is nil to avoid some compiler warnings.")
+
+ (defvar completion-no-auto-exit nil
+ "Non-nil means `choose-completion-string' should never exit the minibuffer.
+ This also applies to other functions such as `choose-completion'.")
+
+ (defvar completion-base-position nil
+ "Position of the base of the text corresponding to the shown completions.
+ This variable is used in the *Completions* buffers.
+ Its value is a list of the form (START END) where START is the place
+ where the completion should be inserted and END (if non-nil) is the end
+ of the text to replace. If END is nil, point is used instead.")
+
+ (defvar completion-list-insert-choice-function #'completion--replace
+ "Function to use to insert the text chosen in *Completions*.
+ Called with three arguments (BEG END TEXT), it should replace the text
+ between BEG and END with TEXT. Expected to be set buffer-locally
+ in the *Completions* buffer.")
+
+ (defvar completion-base-size nil
+ "Number of chars before point not involved in completion.
+ This is a local variable in the completion list buffer.
+ It refers to the chars in the minibuffer if completing in the
+ minibuffer, or in `completion-reference-buffer' otherwise.
+ Only characters in the field at point are included.
+
+ If nil, Emacs determines which part of the tail end of the
+ buffer's text is involved in completion by comparing the text
+ directly.")
+ (make-obsolete-variable 'completion-base-size 'completion-base-position "23.2")
+
+ (defun delete-completion-window ()
+ "Delete the completion list window.
+ Go to the window from which completion was requested."
+ (interactive)
+ (let ((buf completion-reference-buffer))
+ (if (one-window-p t)
+ (if (window-dedicated-p) (delete-frame))
+ (delete-window (selected-window))
+ (if (get-buffer-window buf)
+ (select-window (get-buffer-window buf))))))
+
+ (defun previous-completion (n)
+ "Move to the previous item in the completion list."
+ (interactive "p")
+ (next-completion (- n)))
+
+ (defun next-completion (n)
+ "Move to the next item in the completion list.
+ With prefix argument N, move N items (negative N means move backward)."
+ (interactive "p")
+ (let ((beg (point-min)) (end (point-max)))
+ (while (and (> n 0) (not (eobp)))
+ ;; If in a completion, move to the end of it.
+ (when (get-text-property (point) 'mouse-face)
+ (goto-char (next-single-property-change (point) 'mouse-face nil end)))
+ ;; Move to start of next one.
+ (unless (get-text-property (point) 'mouse-face)
+ (goto-char (next-single-property-change (point) 'mouse-face nil end)))
+ (setq n (1- n)))
+ (while (and (< n 0) (not (bobp)))
+ (let ((prop (get-text-property (1- (point)) 'mouse-face)))
+ ;; If in a completion, move to the start of it.
+ (when (and prop (eq prop (get-text-property (point) 'mouse-face)))
+ (goto-char (previous-single-property-change
+ (point) 'mouse-face nil beg)))
+ ;; Move to end of the previous completion.
+ (unless (or (bobp) (get-text-property (1- (point)) 'mouse-face))
+ (goto-char (previous-single-property-change
+ (point) 'mouse-face nil beg)))
+ ;; Move to the start of that one.
+ (goto-char (previous-single-property-change
+ (point) 'mouse-face nil beg))
+ (setq n (1+ n))))))
+
+ (defun choose-completion (&optional event)
+ "Choose the completion at point.
+ If EVENT, use EVENT's position to determine the starting position."
+ (interactive (list last-nonmenu-event))
+ ;; In case this is run via the mouse, give temporary modes such as
+ ;; isearch a chance to turn off.
+ (run-hooks 'mouse-leave-buffer-hook)
+ (with-current-buffer (window-buffer (posn-window (event-start event)))
+ (let ((buffer completion-reference-buffer)
+ (base-size completion-base-size)
+ (base-position completion-base-position)
+ (insert-function completion-list-insert-choice-function)
+ (choice
+ (save-excursion
+ (goto-char (posn-point (event-start event)))
+ (let (beg end)
+ (cond
+ ((and (not (eobp)) (get-text-property (point) 'mouse-face))
+ (setq end (point) beg (1+ (point))))
+ ((and (not (bobp))
+ (get-text-property (1- (point)) 'mouse-face))
+ (setq end (1- (point)) beg (point)))
+ (t (error "No completion here")))
+ (setq beg (previous-single-property-change beg 'mouse-face))
+ (setq end (or (next-single-property-change end 'mouse-face)
+ (point-max)))
+ (buffer-substring-no-properties beg end)))))
+
+ (unless (buffer-live-p buffer)
+ (error "Destination buffer is dead"))
+ (quit-window nil (posn-window (event-start event)))
+
+ (with-current-buffer buffer
+ (choose-completion-string
+ choice buffer
+ (or base-position
+ (when base-size
+ ;; Someone's using old completion code that doesn't know
+ ;; about base-position yet.
+ (list (+ base-size (field-beginning))))
+ ;; If all else fails, just guess.
+ (list (choose-completion-guess-base-position choice)))
+ insert-function)))))
+
+ ;; Delete the longest partial match for STRING
+ ;; that can be found before POINT.
+ (defun choose-completion-guess-base-position (string)
+ (save-excursion
+ (let ((opoint (point))
+ len)
+ ;; Try moving back by the length of the string.
+ (goto-char (max (- (point) (length string))
+ (minibuffer-prompt-end)))
+ ;; See how far back we were actually able to move. That is the
+ ;; upper bound on how much we can match and delete.
+ (setq len (- opoint (point)))
+ (if completion-ignore-case
+ (setq string (downcase string)))
+ (while (and (> len 0)
+ (let ((tail (buffer-substring (point) opoint)))
+ (if completion-ignore-case
+ (setq tail (downcase tail)))
+ (not (string= tail (substring string 0 len)))))
+ (setq len (1- len))
+ (forward-char 1))
+ (point))))
+
+ (defun choose-completion-delete-max-match (string)
+ (declare (obsolete choose-completion-guess-base-position "23.2"))
+ (delete-region (choose-completion-guess-base-position string) (point)))
+
+ (defvar choose-completion-string-functions nil
+ "Functions that may override the normal insertion of a completion choice.
+ These functions are called in order with three arguments:
+ CHOICE - the string to insert in the buffer,
+ BUFFER - the buffer in which the choice should be inserted,
+ BASE-POSITION - where to insert the completion.
+
+ If a function in the list returns non-nil, that function is supposed
+ to have inserted the CHOICE in the BUFFER, and possibly exited
+ the minibuffer; no further functions will be called.
+
+ If all functions in the list return nil, that means to use
+ the default method of inserting the completion in BUFFER.")
+
+ (defun choose-completion-string (choice &optional
+ buffer base-position insert-function)
+ "Switch to BUFFER and insert the completion choice CHOICE.
+ BASE-POSITION says where to insert the completion.
+ INSERT-FUNCTION says how to insert the completion and falls
+ back on `completion-list-insert-choice-function' when nil."
+
+ ;; If BUFFER is the minibuffer, exit the minibuffer
+ ;; unless it is reading a file name and CHOICE is a directory,
+ ;; or completion-no-auto-exit is non-nil.
+
+ ;; Some older code may call us passing `base-size' instead of
+ ;; `base-position'. It's difficult to make any use of `base-size',
+ ;; so we just ignore it.
+ (unless (consp base-position)
+ (message "Obsolete `base-size' passed to choose-completion-string")
+ (setq base-position nil))
+
+ (let* ((buffer (or buffer completion-reference-buffer))
+ (mini-p (minibufferp buffer)))
+ ;; If BUFFER is a minibuffer, barf unless it's the currently
+ ;; active minibuffer.
+ (if (and mini-p
+ (not (and (active-minibuffer-window)
+ (equal buffer
+ (window-buffer (active-minibuffer-window))))))
+ (error "Minibuffer is not active for completion")
+ ;; Set buffer so buffer-local choose-completion-string-functions works.
+ (set-buffer buffer)
+ (unless (run-hook-with-args-until-success
+ 'choose-completion-string-functions
+ ;; The fourth arg used to be `mini-p' but was useless
+ ;; (since minibufferp can be used on the `buffer' arg)
+ ;; and indeed unused. The last used to be `base-size', so we
+ ;; keep it to try and avoid breaking old code.
+ choice buffer base-position nil)
+ ;; This remove-text-properties should be unnecessary since `choice'
+ ;; comes from buffer-substring-no-properties.
+ ;;(remove-text-properties 0 (length choice) '(mouse-face nil) choice)
+ ;; Insert the completion into the buffer where it was requested.
+ (funcall (or insert-function completion-list-insert-choice-function)
+ (or (car base-position) (point))
+ (or (cadr base-position) (point))
+ choice)
+ ;; Update point in the window that BUFFER is showing in.
+ (let ((window (get-buffer-window buffer t)))
+ (set-window-point window (point)))
+ ;; If completing for the minibuffer, exit it with this choice.
+ (and (not completion-no-auto-exit)
+ (minibufferp buffer)
+ minibuffer-completion-table
+ ;; If this is reading a file name, and the file name chosen
+ ;; is a directory, don't exit the minibuffer.
+ (let* ((result (buffer-substring (field-beginning) (point)))
+ (bounds
+ (completion-boundaries result minibuffer-completion-table
+ minibuffer-completion-predicate
+ "")))
+ (if (eq (car bounds) (length result))
+ ;; The completion chosen leads to a new set of completions
+ ;; (e.g. it's a directory): don't exit the minibuffer yet.
+ (let ((mini (active-minibuffer-window)))
+ (select-window mini)
+ (when minibuffer-auto-raise
+ (raise-frame (window-frame mini))))
+ (exit-minibuffer))))))))
+
+ (define-derived-mode completion-list-mode nil "Completion List"
+ "Major mode for buffers showing lists of possible completions.
+ Type \\<completion-list-mode-map>\\[choose-completion] in the completion list\
+ to select the completion near point.
+ Or click to select one with the mouse.
+
+ \\{completion-list-mode-map}"
+ (set (make-local-variable 'completion-base-size) nil))
+
+ (defun completion-list-mode-finish ()
+ "Finish setup of the completions buffer.
+ Called from `temp-buffer-show-hook'."
+ (when (eq major-mode 'completion-list-mode)
+ (setq buffer-read-only t)))
+
+ (add-hook 'temp-buffer-show-hook 'completion-list-mode-finish)
+
+
+ ;; Variables and faces used in `completion-setup-function'.
+
+ (defcustom completion-show-help t
+ "Non-nil means show help message in *Completions* buffer."
+ :type 'boolean
+ :version "22.1"
+ :group 'completion)
+
+ ;; This function goes in completion-setup-hook, so that it is called
+ ;; after the text of the completion list buffer is written.
+ (defun completion-setup-function ()
+ (let* ((mainbuf (current-buffer))
+ (base-dir
+ ;; FIXME: This is a bad hack. We try to set the default-directory
+ ;; in the *Completions* buffer so that the relative file names
+ ;; displayed there can be treated as valid file names, independently
+ ;; from the completion context. But this suffers from many problems:
+ ;; - It's not clear when the completions are file names. With some
+ ;; completion tables (e.g. bzr revision specs), the listed
+ ;; completions can mix file names and other things.
+ ;; - It doesn't pay attention to possible quoting.
+ ;; - With fancy completion styles, the code below will not always
+ ;; find the right base directory.
+ (if minibuffer-completing-file-name
+ (file-name-as-directory
+ (expand-file-name
+ (buffer-substring (minibuffer-prompt-end)
+ (- (point) (or completion-base-size 0))))))))
+ (with-current-buffer standard-output
+ (let ((base-size completion-base-size) ;Read before killing localvars.
+ (base-position completion-base-position)
+ (insert-fun completion-list-insert-choice-function))
+ (completion-list-mode)
+ (set (make-local-variable 'completion-base-size) base-size)
+ (set (make-local-variable 'completion-base-position) base-position)
+ (set (make-local-variable 'completion-list-insert-choice-function)
+ insert-fun))
+ (set (make-local-variable 'completion-reference-buffer) mainbuf)
+ (if base-dir (setq default-directory base-dir))
+ ;; Maybe insert help string.
+ (when completion-show-help
+ (goto-char (point-min))
+ (if (display-mouse-p)
+ (insert (substitute-command-keys
+ "Click on a completion to select it.\n")))
+ (insert (substitute-command-keys
+ "In this buffer, type \\[choose-completion] to \
+ select the completion near point.\n\n"))))))
+
+ (add-hook 'completion-setup-hook 'completion-setup-function)
+
+ (define-key minibuffer-local-completion-map [prior] 'switch-to-completions)
+ (define-key minibuffer-local-completion-map "\M-v" 'switch-to-completions)
+
+ (defun switch-to-completions ()
+ "Select the completion list window."
+ (interactive)
+ (let ((window (or (get-buffer-window "*Completions*" 0)
+ ;; Make sure we have a completions window.
+ (progn (minibuffer-completion-help)
+ (get-buffer-window "*Completions*" 0)))))
+ (when window
+ (select-window window)
+ ;; In the new buffer, go to the first completion.
+ ;; FIXME: Perhaps this should be done in `minibuffer-completion-help'.
+ (when (bobp)
+ (next-completion 1)))))
+ \f
+ ;;; Support keyboard commands to turn on various modifiers.
+
+ ;; These functions -- which are not commands -- each add one modifier
+ ;; to the following event.
+
+ (defun event-apply-alt-modifier (_ignore-prompt)
+ "\\<function-key-map>Add the Alt modifier to the following event.
+ For example, type \\[event-apply-alt-modifier] & to enter Alt-&."
+ (vector (event-apply-modifier (read-event) 'alt 22 "A-")))
+ (defun event-apply-super-modifier (_ignore-prompt)
+ "\\<function-key-map>Add the Super modifier to the following event.
+ For example, type \\[event-apply-super-modifier] & to enter Super-&."
+ (vector (event-apply-modifier (read-event) 'super 23 "s-")))
+ (defun event-apply-hyper-modifier (_ignore-prompt)
+ "\\<function-key-map>Add the Hyper modifier to the following event.
+ For example, type \\[event-apply-hyper-modifier] & to enter Hyper-&."
+ (vector (event-apply-modifier (read-event) 'hyper 24 "H-")))
+ (defun event-apply-shift-modifier (_ignore-prompt)
+ "\\<function-key-map>Add the Shift modifier to the following event.
+ For example, type \\[event-apply-shift-modifier] & to enter Shift-&."
+ (vector (event-apply-modifier (read-event) 'shift 25 "S-")))
+ (defun event-apply-control-modifier (_ignore-prompt)
+ "\\<function-key-map>Add the Ctrl modifier to the following event.
+ For example, type \\[event-apply-control-modifier] & to enter Ctrl-&."
+ (vector (event-apply-modifier (read-event) 'control 26 "C-")))
+ (defun event-apply-meta-modifier (_ignore-prompt)
+ "\\<function-key-map>Add the Meta modifier to the following event.
+ For example, type \\[event-apply-meta-modifier] & to enter Meta-&."
+ (vector (event-apply-modifier (read-event) 'meta 27 "M-")))
+
+ (defun event-apply-modifier (event symbol lshiftby prefix)
+ "Apply a modifier flag to event EVENT.
+ SYMBOL is the name of this modifier, as a symbol.
+ LSHIFTBY is the numeric value of this modifier, in keyboard events.
+ PREFIX is the string that represents this modifier in an event type symbol."
+ (if (numberp event)
+ (cond ((eq symbol 'control)
+ (if (and (<= (downcase event) ?z)
+ (>= (downcase event) ?a))
+ (- (downcase event) ?a -1)
+ (if (and (<= (downcase event) ?Z)
+ (>= (downcase event) ?A))
+ (- (downcase event) ?A -1)
+ (logior (lsh 1 lshiftby) event))))
+ ((eq symbol 'shift)
+ (if (and (<= (downcase event) ?z)
+ (>= (downcase event) ?a))
+ (upcase event)
+ (logior (lsh 1 lshiftby) event)))
+ (t
+ (logior (lsh 1 lshiftby) event)))
+ (if (memq symbol (event-modifiers event))
+ event
+ (let ((event-type (if (symbolp event) event (car event))))
+ (setq event-type (intern (concat prefix (symbol-name event-type))))
+ (if (symbolp event)
+ event-type
+ (cons event-type (cdr event)))))))
+
+ (define-key function-key-map [?\C-x ?@ ?h] 'event-apply-hyper-modifier)
+ (define-key function-key-map [?\C-x ?@ ?s] 'event-apply-super-modifier)
+ (define-key function-key-map [?\C-x ?@ ?m] 'event-apply-meta-modifier)
+ (define-key function-key-map [?\C-x ?@ ?a] 'event-apply-alt-modifier)
+ (define-key function-key-map [?\C-x ?@ ?S] 'event-apply-shift-modifier)
+ (define-key function-key-map [?\C-x ?@ ?c] 'event-apply-control-modifier)
+ \f
+ ;;;; Keypad support.
+
+ ;; Make the keypad keys act like ordinary typing keys. If people add
+ ;; bindings for the function key symbols, then those bindings will
+ ;; override these, so this shouldn't interfere with any existing
+ ;; bindings.
+
+ ;; Also tell read-char how to handle these keys.
+ (mapc
+ (lambda (keypad-normal)
+ (let ((keypad (nth 0 keypad-normal))
+ (normal (nth 1 keypad-normal)))
+ (put keypad 'ascii-character normal)
+ (define-key function-key-map (vector keypad) (vector normal))))
+ ;; See also kp-keys bound in bindings.el.
+ '((kp-space ?\s)
+ (kp-tab ?\t)
+ (kp-enter ?\r)
+ (kp-separator ?,)
+ (kp-equal ?=)
+ ;; Do the same for various keys that are represented as symbols under
+ ;; GUIs but naturally correspond to characters.
+ (backspace 127)
+ (delete 127)
+ (tab ?\t)
+ (linefeed ?\n)
+ (clear ?\C-l)
+ (return ?\C-m)
+ (escape ?\e)
+ ))
+ \f
+ ;;;;
+ ;;;; 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'.")
+
+ (defvar clone-indirect-buffer-hook nil
+ "Normal hook to run in the new buffer at the end of `clone-indirect-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))
+ (new-process
+ (if (memq (process-status process) '(open))
+ (let ((args (process-contact process t)))
+ (setq args (plist-put args :name newname))
+ (setq args (plist-put args :buffer
+ (if (process-buffer process)
+ (current-buffer))))
+ (apply 'make-network-process args))
+ (apply 'start-process newname
+ (if (process-buffer process) (current-buffer))
+ (process-command process)))))
+ (set-process-query-on-exit-flag
+ new-process (process-query-on-exit-flag process))
+ (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))
+ (set-process-plist new-process (copy-sequence (process-plist process)))
+ new-process)))
+
+ ;; things to maybe add (currently partly covered by `funcall mode'):
+ ;; - syntax-table
+ ;; - overlays
+ (defun clone-buffer (&optional newname display-flag)
+ "Create and return a twin copy of the current buffer.
+ Unlike an indirect buffer, the new buffer can be edited
+ independently of the old one (if it is not read-only).
+ NEWNAME is the name of the new buffer. It may be modified by
+ adding or incrementing <N> at the end as necessary to create a
+ unique buffer name. If nil, it defaults to the name of the
+ current buffer, with the proper suffix. If DISPLAY-FLAG is
+ non-nil, the new buffer is shown with `pop-to-buffer'. Trying to
+ clone a file-visiting buffer, or a buffer whose major mode symbol
+ has a non-nil `no-clone' property, results in an error.
+
+ Interactively, DISPLAY-FLAG is t and NEWNAME is the name of the
+ current buffer with appropriate suffix. However, if a prefix
+ argument is given, then the command prompts for NEWNAME in the
+ minibuffer.
+
+ This runs the normal hook `clone-buffer-hook' in the new buffer
+ after it has been set up properly in other respects."
+ (interactive
+ (progn
+ (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))
+ (list (if current-prefix-arg
+ (read-buffer "Name of new cloned buffer: " (current-buffer)))
+ 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.
+ (mapc (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
+ ;; Presumably the current buffer is shown in the selected frame, so
+ ;; we want to display the clone elsewhere.
+ (let ((same-window-regexps nil)
+ (same-window-buffer-names))
+ (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 NEWNAME
+ 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. Trying to clone a
+ buffer whose major mode symbol has a non-nil `no-clone-indirect'
+ property results in an error.
+
+ DISPLAY-FLAG non-nil means show the new buffer with `pop-to-buffer'.
+ This is always done when called interactively.
+
+ Optional third arg NORECORD non-nil means do not put this buffer at the
+ front of the list of recently selected ones."
+ (interactive
+ (progn
+ (if (get major-mode 'no-clone-indirect)
+ (error "Cannot indirectly clone a buffer in %s mode" mode-name))
+ (list (if current-prefix-arg
+ (read-buffer "Name of indirect buffer: " (current-buffer)))
+ t)))
+ (if (get major-mode 'no-clone-indirect)
+ (error "Cannot indirectly 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* ((name (generate-new-buffer-name newname))
+ (buffer (make-indirect-buffer (current-buffer) name t)))
+ (with-current-buffer buffer
+ (run-hooks 'clone-indirect-buffer-hook))
+ (when display-flag
+ (pop-to-buffer buffer norecord))
+ buffer))
+
+
+ (defun clone-indirect-buffer-other-window (newname display-flag &optional norecord)
+ "Like `clone-indirect-buffer' but display in another window."
+ (interactive
+ (progn
+ (if (get major-mode 'no-clone-indirect)
+ (error "Cannot indirectly clone a buffer in %s mode" mode-name))
+ (list (if current-prefix-arg
+ (read-buffer "Name of indirect buffer: " (current-buffer)))
+ t)))
+ (let ((pop-up-windows t))
+ (clone-indirect-buffer newname display-flag norecord)))
+
+ \f
+ ;;; Handling of Backspace and Delete keys.
+
+ (defcustom normal-erase-is-backspace 'maybe
+ "Set the default behavior of the Delete and Backspace keys.
+
+ If set to t, Delete key deletes forward and Backspace key deletes
+ backward.
+
+ If set to nil, both Delete and Backspace keys delete backward.
+
+ If set to 'maybe (which is the default), Emacs automatically
+ selects a behavior. On window systems, the behavior depends on
+ the keyboard used. If the keyboard has both a Backspace key and
+ a Delete key, and both are mapped to their usual meanings, the
+ option's default value is set to t, so that Backspace can be used
+ to delete backward, and Delete can be used to delete forward.
+
+ If not running under a window system, customizing this option
+ accomplishes a similar effect by mapping C-h, which is usually
+ generated by the Backspace key, to DEL, and by mapping DEL to C-d
+ via `keyboard-translate'. The former functionality of C-h is
+ available on the F1 key. You should probably not use this
+ setting if you don't have both Backspace, Delete and F1 keys.
+
+ Setting this variable with setq doesn't take effect. Programmatically,
+ call `normal-erase-is-backspace-mode' (which see) instead."
+ :type '(choice (const :tag "Off" nil)
+ (const :tag "Maybe" maybe)
+ (other :tag "On" t))
+ :group 'editing-basics
+ :version "21.1"
+ :set (lambda (symbol value)
+ ;; The fboundp is because of a problem with :set when
+ ;; dumping Emacs. It doesn't really matter.
+ (if (fboundp 'normal-erase-is-backspace-mode)
+ (normal-erase-is-backspace-mode (or value 0))
+ (set-default symbol value))))
+
+ (defun normal-erase-is-backspace-setup-frame (&optional frame)
+ "Set up `normal-erase-is-backspace-mode' on FRAME, if necessary."
+ (unless frame (setq frame (selected-frame)))
+ (with-selected-frame frame
+ (unless (terminal-parameter nil 'normal-erase-is-backspace)
+ (normal-erase-is-backspace-mode
+ (if (if (eq normal-erase-is-backspace 'maybe)
+ (and (not noninteractive)
+ (or (memq system-type '(ms-dos windows-nt))
+ (memq window-system '(w32 ns))
+ (and (memq window-system '(x))
+ (fboundp 'x-backspace-delete-keys-p)
+ (x-backspace-delete-keys-p))
+ ;; If the terminal Emacs is running on has erase char
+ ;; set to ^H, use the Backspace key for deleting
+ ;; backward, and the Delete key for deleting forward.
+ (and (null window-system)
+ (eq tty-erase-char ?\^H))))
+ normal-erase-is-backspace)
+ 1 0)))))
+
+ (define-minor-mode normal-erase-is-backspace-mode
+ "Toggle the Erase and Delete mode of the Backspace and Delete keys.
+ With a prefix argument ARG, enable this feature if ARG is
+ positive, and disable it otherwise. If called from Lisp, enable
+ the mode if ARG is omitted or nil.
+
+ On window systems, when this mode is on, Delete is mapped to C-d
+ and Backspace is mapped to DEL; when this mode is off, both
+ Delete and Backspace are mapped to DEL. (The remapping goes via
+ `local-function-key-map', so binding Delete or Backspace in the
+ global or local keymap will override that.)
+
+ In addition, on window systems, the bindings of C-Delete, M-Delete,
+ C-M-Delete, C-Backspace, M-Backspace, and C-M-Backspace are changed in
+ the global keymap in accordance with the functionality of Delete and
+ Backspace. For example, if Delete is remapped to C-d, which deletes
+ forward, C-Delete is bound to `kill-word', but if Delete is remapped
+ to DEL, which deletes backward, C-Delete is bound to
+ `backward-kill-word'.
+
+ If not running on a window system, a similar effect is accomplished by
+ remapping C-h (normally produced by the Backspace key) and DEL via
+ `keyboard-translate': if this mode is on, C-h is mapped to DEL and DEL
+ to C-d; if it's off, the keys are not remapped.
+
+ When not running on a window system, and this mode is turned on, the
+ former functionality of C-h is available on the F1 key. You should
+ probably not turn on this mode on a text-only terminal if you don't
+ have both Backspace, Delete and F1 keys.
+
+ See also `normal-erase-is-backspace'."
+ :variable ((eq (terminal-parameter nil 'normal-erase-is-backspace) 1)
+ . (lambda (v)
+ (setf (terminal-parameter nil 'normal-erase-is-backspace)
+ (if v 1 0))))
+ (let ((enabled (eq 1 (terminal-parameter
+ nil 'normal-erase-is-backspace))))
+
+ (cond ((or (memq window-system '(x w32 ns pc))
+ (memq system-type '(ms-dos windows-nt)))
+ (let ((bindings
+ `(([M-delete] [M-backspace])
+ ([C-M-delete] [C-M-backspace])
+ ([?\e C-delete] [?\e C-backspace]))))
+
+ (if enabled
+ (progn
+ (define-key local-function-key-map [delete] [deletechar])
+ (define-key local-function-key-map [kp-delete] [deletechar])
+ (define-key local-function-key-map [backspace] [?\C-?])
+ (dolist (b bindings)
+ ;; Not sure if input-decode-map is really right, but
+ ;; keyboard-translate-table (used below) only works
+ ;; for integer events, and key-translation-table is
+ ;; global (like the global-map, used earlier).
+ (define-key input-decode-map (car b) nil)
+ (define-key input-decode-map (cadr b) nil)))
+ (define-key local-function-key-map [delete] [?\C-?])
+ (define-key local-function-key-map [kp-delete] [?\C-?])
+ (define-key local-function-key-map [backspace] [?\C-?])
+ (dolist (b bindings)
+ (define-key input-decode-map (car b) (cadr b))
+ (define-key input-decode-map (cadr b) (car b))))))
+ (t
+ (if enabled
+ (progn
+ (keyboard-translate ?\C-h ?\C-?)
+ (keyboard-translate ?\C-? ?\C-d))
+ (keyboard-translate ?\C-h ?\C-h)
+ (keyboard-translate ?\C-? ?\C-?))))
+
+ (if (called-interactively-p 'interactive)
+ (message "Delete key deletes %s"
+ (if (eq 1 (terminal-parameter nil 'normal-erase-is-backspace))
+ "forward" "backward")))))
+ \f
+ (defvar vis-mode-saved-buffer-invisibility-spec nil
+ "Saved value of `buffer-invisibility-spec' when Visible mode is on.")
+
+ (define-minor-mode read-only-mode
+ "Change whether the current buffer is read-only.
+ With prefix argument ARG, make the buffer read-only if ARG is
+ positive, otherwise make it writable. If buffer is read-only
+ and `view-read-only' is non-nil, enter view mode.
+
+ Do not call this from a Lisp program unless you really intend to
+ do the same thing as the \\[read-only-mode] command, including
+ possibly enabling or disabling View mode. Also, note that this
+ command works by setting the variable `buffer-read-only', which
+ does not affect read-only regions caused by text properties. To
+ ignore read-only status in a Lisp program (whether due to text
+ properties or buffer state), bind `inhibit-read-only' temporarily
+ to a non-nil value."
+ :variable buffer-read-only
+ (cond
+ ((and (not buffer-read-only) view-mode)
+ (View-exit-and-edit)
+ (make-local-variable 'view-read-only)
+ (setq view-read-only t)) ; Must leave view mode.
+ ((and buffer-read-only view-read-only
+ ;; If view-mode is already active, `view-mode-enter' is a nop.
+ (not view-mode)
+ (not (eq (get major-mode 'mode-class) 'special)))
+ (view-mode-enter))))
+
+ (define-minor-mode visible-mode
+ "Toggle making all invisible text temporarily visible (Visible mode).
+ With a prefix argument ARG, enable Visible mode if ARG is
+ positive, and disable it otherwise. If called from Lisp, enable
+ the mode if ARG is omitted or nil.
+
+ This mode works by saving the value of `buffer-invisibility-spec'
+ and setting it to nil."
+ :lighter " Vis"
+ :group 'editing-basics
+ (when (local-variable-p 'vis-mode-saved-buffer-invisibility-spec)
+ (setq buffer-invisibility-spec vis-mode-saved-buffer-invisibility-spec)
+ (kill-local-variable 'vis-mode-saved-buffer-invisibility-spec))
+ (when visible-mode
+ (set (make-local-variable 'vis-mode-saved-buffer-invisibility-spec)
+ buffer-invisibility-spec)
+ (setq buffer-invisibility-spec nil)))
+ \f
+ (defvar messages-buffer-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map special-mode-map)
+ (define-key map "g" nil) ; nothing to revert
+ map))
+
+ (define-derived-mode messages-buffer-mode special-mode "Messages"
+ "Major mode used in the \"*Messages*\" buffer.")
+
+ (defun messages-buffer ()
+ "Return the \"*Messages*\" buffer.
+ If it does not exist, create and it switch it to `messages-buffer-mode'."
+ (or (get-buffer "*Messages*")
+ (with-current-buffer (get-buffer-create "*Messages*")
+ (messages-buffer-mode)
+ (current-buffer))))
+
+ \f
+ ;; Minibuffer prompt stuff.
+
+ ;;(defun minibuffer-prompt-modification (start end)
+ ;; (error "You cannot modify the prompt"))
+ ;;
+ ;;
+ ;;(defun minibuffer-prompt-insertion (start end)
+ ;; (let ((inhibit-modification-hooks t))
+ ;; (delete-region start end)
+ ;; ;; Discard undo information for the text insertion itself
+ ;; ;; and for the text deletion.above.
+ ;; (when (consp buffer-undo-list)
+ ;; (setq buffer-undo-list (cddr buffer-undo-list)))
+ ;; (message "You cannot modify the prompt")))
+ ;;
+ ;;
+ ;;(setq minibuffer-prompt-properties
+ ;; (list 'modification-hooks '(minibuffer-prompt-modification)
+ ;; 'insert-in-front-hooks '(minibuffer-prompt-insertion)))
+
+ \f
+ ;;;; Problematic external packages.
+
+ ;; rms says this should be done by specifying symbols that define
+ ;; versions together with bad values. This is therefore not as
+ ;; flexible as it could be. See the thread:
+ ;; http://lists.gnu.org/archive/html/emacs-devel/2007-08/msg00300.html
+ (defconst bad-packages-alist
+ ;; Not sure exactly which semantic versions have problems.
+ ;; Definitely 2.0pre3, probably all 2.0pre's before this.
+ '((semantic semantic-version "\\`2\\.0pre[1-3]\\'"
+ "The version of `semantic' loaded does not work in Emacs 22.
+ It can cause constant high CPU load.
+ Upgrade to at least Semantic 2.0pre4 (distributed with CEDET 1.0pre4).")
+ ;; CUA-mode does not work with GNU Emacs version 22.1 and newer.
+ ;; Except for version 1.2, all of the 1.x and 2.x version of cua-mode
+ ;; provided the `CUA-mode' feature. Since this is no longer true,
+ ;; we can warn the user if the `CUA-mode' feature is ever provided.
+ (CUA-mode t nil
+ "CUA-mode is now part of the standard GNU Emacs distribution,
+ so you can now enable CUA via the Options menu or by customizing `cua-mode'.
+
+ You have loaded an older version of CUA-mode which does not work
+ correctly with this version of Emacs. You should remove the old
+ version and use the one distributed with Emacs."))
+ "Alist of packages known to cause problems in this version of Emacs.
+ Each element has the form (PACKAGE SYMBOL REGEXP STRING).
+ PACKAGE is either a regular expression to match file names, or a
+ symbol (a feature name), like for `with-eval-after-load'.
+ SYMBOL is either the name of a string variable, or `t'. Upon
+ loading PACKAGE, if SYMBOL is t or matches REGEXP, display a
+ warning using STRING as the message.")
+
+ (defun bad-package-check (package)
+ "Run a check using the element from `bad-packages-alist' matching PACKAGE."
+ (condition-case nil
+ (let* ((list (assoc package bad-packages-alist))
+ (symbol (nth 1 list)))
+ (and list
+ (boundp symbol)
+ (or (eq symbol t)
+ (and (stringp (setq symbol (eval symbol)))
+ (string-match-p (nth 2 list) symbol)))
+ (display-warning package (nth 3 list) :warning)))
+ (error nil)))
+
+ (dolist (elem bad-packages-alist)
+ (let ((pkg (car elem)))
+ (with-eval-after-load pkg
+ (bad-package-check pkg))))
+
+ \f
+ ;;; Generic dispatcher commands
+
+ ;; Macro `define-alternatives' is used to create generic commands.
+ ;; Generic commands are these (like web, mail, news, encrypt, irc, etc.)
+ ;; that can have different alternative implementations where choosing
+ ;; among them is exclusively a matter of user preference.
+
+ ;; (define-alternatives COMMAND) creates a new interactive command
+ ;; M-x COMMAND and a customizable variable COMMAND-alternatives.
+ ;; Typically, the user will not need to customize this variable; packages
+ ;; wanting to add alternative implementations should use
+ ;;
+ ;; ;;;###autoload (push '("My impl name" . my-impl-symbol) COMMAND-alternatives
+
+ (defmacro define-alternatives (command &rest customizations)
+ "Define the new command `COMMAND'.
+
+ The argument `COMMAND' should be a symbol.
+
+ Running `M-x COMMAND RET' for the first time prompts for which
+ alternative to use and records the selected command as a custom
+ variable.
+
+ Running `C-u M-x COMMAND RET' prompts again for an alternative
+ and overwrites the previous choice.
+
+ The variable `COMMAND-alternatives' contains an alist with
+ alternative implementations of COMMAND. `define-alternatives'
+ does not have any effect until this variable is set.
+
+ CUSTOMIZATIONS, if non-nil, should be composed of alternating
+ `defcustom' keywords and values to add to the declaration of
+ `COMMAND-alternatives' (typically :group and :version)."
+ (let* ((command-name (symbol-name command))
+ (varalt-name (concat command-name "-alternatives"))
+ (varalt-sym (intern varalt-name))
+ (varimp-sym (intern (concat command-name "--implementation"))))
+ `(progn
+
+ (defcustom ,varalt-sym nil
+ ,(format "Alist of alternative implementations for the `%s' command.
+
+ Each entry must be a pair (ALTNAME . ALTFUN), where:
+ ALTNAME - The name shown at user to describe the alternative implementation.
+ ALTFUN - The function called to implement this alternative."
+ command-name)
+ :type '(alist :key-type string :value-type function)
+ ,@customizations)
+
+ (put ',varalt-sym 'definition-name ',command)
+ (defvar ,varimp-sym nil "Internal use only.")
+
+ (defun ,command (&optional arg)
+ ,(format "Run generic command `%s'.
+ If used for the first time, or with interactive ARG, ask the user which
+ implementation to use for `%s'. The variable `%s'
+ contains the list of implementations currently supported for this command."
+ command-name command-name varalt-name)
+ (interactive "P")
+ (when (or arg (null ,varimp-sym))
+ (let ((val (completing-read
+ ,(format "Select implementation for command `%s': "
+ command-name)
+ ,varalt-sym nil t)))
+ (unless (string-equal val "")
+ (when (null ,varimp-sym)
+ (message
+ "Use `C-u M-x %s RET' to select another implementation"
+ ,command-name)
+ (sit-for 3))
+ (customize-save-variable ',varimp-sym
+ (cdr (assoc-string val ,varalt-sym))))))
+ (if ,varimp-sym
+ (call-interactively ,varimp-sym)
+ (message ,(format "No implementation selected for command `%s'"
+ command-name)))))))
+
+ \f
+ ;; This is here because files in obsolete/ are not scanned for autoloads.
+
+ (defvar iswitchb-mode nil "\
+ Non-nil if Iswitchb mode is enabled.
+ See the command `iswitchb-mode' for a description of this minor mode.
+ Setting this variable directly does not take effect;
+ either customize it (see the info node `Easy Customization')
+ or call the function `iswitchb-mode'.")
+
+ (custom-autoload 'iswitchb-mode "iswitchb" nil)
+
+ (autoload 'iswitchb-mode "iswitchb" "\
+ Toggle Iswitchb mode.
+ With a prefix argument ARG, enable Iswitchb mode if ARG is
+ positive, and disable it otherwise. If called from Lisp, enable
+ the mode if ARG is omitted or nil.
+
+ Iswitchb mode is a global minor mode that enables switching
+ between buffers using substrings. See `iswitchb' for details.
+
+ \(fn &optional ARG)" t nil)
+
+ (make-obsolete 'iswitchb-mode
+ "use `icomplete-mode' or `ido-mode' instead." "24.4")
+ \f
+
+ (provide 'simple)
+
+ ;;; simple.el ends here
--- /dev/null
+ ;;; subr.el --- basic lisp subroutines for Emacs -*- coding: utf-8; lexical-binding:t -*-
+
+ ;; Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2015 Free Software
+ ;; Foundation, Inc.
+
+ ;; Maintainer: emacs-devel@gnu.org
+ ;; Keywords: internal
+ ;; Package: emacs
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+
+ ;;; Code:
+
+ ;; Beware: while this file has tag `utf-8', before it's compiled, it gets
+ ;; loaded as "raw-text", so non-ASCII chars won't work right during bootstrap.
+
+ (defmacro declare-function (_fn _file &optional _arglist _fileonly)
+ "Tell the byte-compiler that function FN is defined, in FILE.
+ Optional ARGLIST is the argument list used by the function.
+ The FILE argument is not used by the byte-compiler, but by the
+ `check-declare' package, which checks that FILE contains a
+ definition for FN. ARGLIST is used by both the byte-compiler
+ and `check-declare' to check for consistency.
+
+ FILE can be either a Lisp file (in which case the \".el\"
+ extension is optional), or a C file. C files are expanded
+ relative to the Emacs \"src/\" directory. Lisp files are
+ searched for using `locate-library', and if that fails they are
+ expanded relative to the location of the file containing the
+ declaration. A FILE with an \"ext:\" prefix is an external file.
+ `check-declare' will check such files if they are found, and skip
+ them without error if they are not.
+
+ FILEONLY non-nil means that `check-declare' will only check that
+ FILE exists, not that it defines FN. This is intended for
+ function-definitions that `check-declare' does not recognize, e.g.
+ `defstruct'.
+
+ To specify a value for FILEONLY without passing an argument list,
+ set ARGLIST to t. This is necessary because nil means an
+ empty argument list, rather than an unspecified one.
+
+ Note that for the purposes of `check-declare', this statement
+ must be the first non-whitespace on a line.
+
+ For more information, see Info node `(elisp)Declaring Functions'."
+ ;; Does nothing - byte-compile-declare-function does the work.
+ nil)
+
+ \f
+ ;;;; Basic Lisp macros.
+
+ (defalias 'not 'null)
+
+ (defmacro noreturn (form)
+ "Evaluate FORM, expecting it not to return.
+ If FORM does return, signal an error."
+ (declare (debug t))
+ `(prog1 ,form
+ (error "Form marked with `noreturn' did return")))
+
+ (defmacro 1value (form)
+ "Evaluate FORM, expecting a constant return value.
+ This is the global do-nothing version. There is also `testcover-1value'
+ that complains if FORM ever does return differing values."
+ (declare (debug t))
+ form)
+
+ (defmacro def-edebug-spec (symbol spec)
+ "Set the `edebug-form-spec' property of SYMBOL according to SPEC.
+ Both SYMBOL and SPEC are unevaluated. The SPEC can be:
+ 0 (instrument no arguments); t (instrument all arguments);
+ a symbol (naming a function with an Edebug specification); or a list.
+ The elements of the list describe the argument types; see
+ Info node `(elisp)Specification List' for details."
+ `(put (quote ,symbol) 'edebug-form-spec (quote ,spec)))
+
+ (defmacro lambda (&rest cdr)
+ "Return a lambda expression.
+ A call of the form (lambda ARGS DOCSTRING INTERACTIVE BODY) is
+ self-quoting; the result of evaluating the lambda expression is the
+ expression itself. The lambda expression may then be treated as a
+ function, i.e., stored as the function value of a symbol, passed to
+ `funcall' or `mapcar', etc.
+
+ ARGS should take the same form as an argument list for a `defun'.
+ DOCSTRING is an optional documentation string.
+ If present, it should describe how to call the function.
+ But documentation strings are usually not useful in nameless functions.
+ INTERACTIVE should be a call to the function `interactive', which see.
+ It may also be omitted.
+ BODY should be a list of Lisp expressions.
+
+ \(fn ARGS [DOCSTRING] [INTERACTIVE] BODY)"
+ (declare (doc-string 2) (indent defun)
+ (debug (&define lambda-list
+ [&optional stringp]
+ [&optional ("interactive" interactive)]
+ def-body)))
+ ;; Note that this definition should not use backquotes; subr.el should not
+ ;; depend on backquote.el.
+ (list 'function (cons 'lambda cdr)))
+
+ (defmacro setq-local (var val)
+ "Set variable VAR to value VAL in current buffer."
+ ;; Can't use backquote here, it's too early in the bootstrap.
+ (list 'set (list 'make-local-variable (list 'quote var)) val))
+
+ (defmacro defvar-local (var val &optional docstring)
+ "Define VAR as a buffer-local variable with default value VAL.
+ Like `defvar' but additionally marks the variable as being automatically
+ buffer-local wherever it is set."
+ (declare (debug defvar) (doc-string 3))
+ ;; Can't use backquote here, it's too early in the bootstrap.
+ (list 'progn (list 'defvar var val docstring)
+ (list 'make-variable-buffer-local (list 'quote var))))
+
+ (defun apply-partially (fun &rest args)
+ "Return a function that is a partial application of FUN to ARGS.
+ ARGS is a list of the first N arguments to pass to FUN.
+ The result is a new function which does the same as FUN, except that
+ the first N arguments are fixed at the values with which this function
+ was called."
+ `(closure (t) (&rest args)
+ (apply ',fun ,@(mapcar (lambda (arg) `',arg) args) args)))
+
+ (defmacro push (newelt place)
+ "Add NEWELT to the list stored in the generalized variable PLACE.
+ This is morally equivalent to (setf PLACE (cons NEWELT PLACE)),
+ except that PLACE is only evaluated once (after NEWELT)."
+ (declare (debug (form gv-place)))
+ (if (symbolp place)
+ ;; Important special case, to avoid triggering GV too early in
+ ;; the bootstrap.
+ (list 'setq place
+ (list 'cons newelt place))
+ (require 'macroexp)
+ (macroexp-let2 macroexp-copyable-p v newelt
+ (gv-letplace (getter setter) place
+ (funcall setter `(cons ,v ,getter))))))
+
+ (defmacro pop (place)
+ "Return the first element of PLACE's value, and remove it from the list.
+ PLACE must be a generalized variable whose value is a list.
+ If the value is nil, `pop' returns nil but does not actually
+ change the list."
+ (declare (debug (gv-place)))
+ ;; We use `car-safe' here instead of `car' because the behavior is the same
+ ;; (if it's not a cons cell, the `cdr' would have signaled an error already),
+ ;; but `car-safe' is total, so the byte-compiler can safely remove it if the
+ ;; result is not used.
+ `(car-safe
+ ,(if (symbolp place)
+ ;; So we can use `pop' in the bootstrap before `gv' can be used.
+ (list 'prog1 place (list 'setq place (list 'cdr place)))
+ (gv-letplace (getter setter) place
+ `(prog1 ,getter ,(funcall setter `(cdr ,getter)))))))
+
+ (defmacro when (cond &rest body)
+ "If COND yields non-nil, do BODY, else return nil.
+ When COND yields non-nil, eval BODY forms sequentially and return
+ value of last one, or nil if there are none.
+
+ \(fn COND BODY...)"
+ (declare (indent 1) (debug t))
+ (list 'if cond (cons 'progn body)))
+
+ (defmacro unless (cond &rest body)
+ "If COND yields nil, do BODY, else return nil.
+ When COND yields nil, eval BODY forms sequentially and return
+ value of last one, or nil if there are none.
+
+ \(fn COND BODY...)"
+ (declare (indent 1) (debug t))
+ (cons 'if (cons cond (cons nil body))))
+
+ (defmacro dolist (spec &rest body)
+ "Loop over a list.
+ Evaluate BODY with VAR bound to each car from LIST, in turn.
+ Then evaluate RESULT to get return value, default nil.
+
+ \(fn (VAR LIST [RESULT]) BODY...)"
+ (declare (indent 1) (debug ((symbolp form &optional form) body)))
+ ;; It would be cleaner to create an uninterned symbol,
+ ;; but that uses a lot more space when many functions in many files
+ ;; use dolist.
+ ;; FIXME: This cost disappears in byte-compiled lexical-binding files.
+ (let ((temp '--dolist-tail--))
+ ;; This is not a reliable test, but it does not matter because both
+ ;; semantics are acceptable, tho one is slightly faster with dynamic
+ ;; scoping and the other is slightly faster (and has cleaner semantics)
+ ;; with lexical scoping.
+ (if lexical-binding
+ `(let ((,temp ,(nth 1 spec)))
+ (while ,temp
+ (let ((,(car spec) (car ,temp)))
+ ,@body
+ (setq ,temp (cdr ,temp))))
+ ,@(cdr (cdr spec)))
+ `(let ((,temp ,(nth 1 spec))
+ ,(car spec))
+ (while ,temp
+ (setq ,(car spec) (car ,temp))
+ ,@body
+ (setq ,temp (cdr ,temp)))
+ ,@(if (cdr (cdr spec))
+ `((setq ,(car spec) nil) ,@(cdr (cdr spec))))))))
+
+ (defmacro dotimes (spec &rest body)
+ "Loop a certain number of times.
+ Evaluate BODY with VAR bound to successive integers running from 0,
+ inclusive, to COUNT, exclusive. Then evaluate RESULT to get
+ the return value (nil if RESULT is omitted).
+
+ \(fn (VAR COUNT [RESULT]) BODY...)"
+ (declare (indent 1) (debug dolist))
+ ;; It would be cleaner to create an uninterned symbol,
+ ;; but that uses a lot more space when many functions in many files
+ ;; use dotimes.
+ ;; FIXME: This cost disappears in byte-compiled lexical-binding files.
+ (let ((temp '--dotimes-limit--)
+ (start 0)
+ (end (nth 1 spec)))
+ ;; This is not a reliable test, but it does not matter because both
+ ;; semantics are acceptable, tho one is slightly faster with dynamic
+ ;; scoping and the other has cleaner semantics.
+ (if lexical-binding
+ (let ((counter '--dotimes-counter--))
+ `(let ((,temp ,end)
+ (,counter ,start))
+ (while (< ,counter ,temp)
+ (let ((,(car spec) ,counter))
+ ,@body)
+ (setq ,counter (1+ ,counter)))
+ ,@(if (cddr spec)
+ ;; FIXME: This let often leads to "unused var" warnings.
+ `((let ((,(car spec) ,counter)) ,@(cddr spec))))))
+ `(let ((,temp ,end)
+ (,(car spec) ,start))
+ (while (< ,(car spec) ,temp)
+ ,@body
+ (setq ,(car spec) (1+ ,(car spec))))
+ ,@(cdr (cdr spec))))))
+
+ (defmacro declare (&rest _specs)
+ "Do not evaluate any arguments, and return nil.
+ If a `declare' form appears as the first form in the body of a
+ `defun' or `defmacro' form, SPECS specifies various additional
+ information about the function or macro; these go into effect
+ during the evaluation of the `defun' or `defmacro' form.
+
+ The possible values of SPECS are specified by
+ `defun-declarations-alist' and `macro-declarations-alist'."
+ ;; FIXME: edebug spec should pay attention to defun-declarations-alist.
+ nil)
+
+ (defmacro ignore-errors (&rest body)
+ "Execute BODY; if an error occurs, return nil.
+ Otherwise, return result of last form in BODY.
+ See also `with-demoted-errors' that does something similar
+ without silencing all errors."
+ (declare (debug t) (indent 0))
+ `(condition-case nil (progn ,@body) (error nil)))
+ \f
+ ;;;; Basic Lisp functions.
+
+ (defun ignore (&rest _ignore)
+ "Do nothing and return nil.
+ This function accepts any number of arguments, but ignores them."
+ (interactive)
+ nil)
+
+ ;; Signal a compile-error if the first arg is missing.
+ (defun error (&rest args)
+ "Signal an error, making error message by passing all args to `format'.
+ In Emacs, the convention is that error messages start with a capital
+ letter but *do not* end with a period. Please follow this convention
+ for the sake of consistency."
+ (declare (advertised-calling-convention (string &rest args) "23.1"))
+ (signal 'error (list (apply 'format args))))
+
+ (defun user-error (format &rest args)
+ "Signal a pilot error, making error message by passing all args to `format'.
+ In Emacs, the convention is that error messages start with a capital
+ letter but *do not* end with a period. Please follow this convention
+ for the sake of consistency.
+ This is just like `error' except that `user-error's are expected to be the
+ result of an incorrect manipulation on the part of the user, rather than the
+ result of an actual problem."
+ (signal 'user-error (list (apply #'format format args))))
+
+ (defun define-error (name message &optional parent)
+ "Define NAME as a new error signal.
+ MESSAGE is a string that will be output to the echo area if such an error
+ is signaled without being caught by a `condition-case'.
+ PARENT is either a signal or a list of signals from which it inherits.
+ Defaults to `error'."
+ (unless parent (setq parent 'error))
+ (let ((conditions
+ (if (consp parent)
+ (apply #'nconc
+ (mapcar (lambda (parent)
+ (cons parent
+ (or (get parent 'error-conditions)
+ (error "Unknown signal `%s'" parent))))
+ parent))
+ (cons parent (get parent 'error-conditions)))))
+ (put name 'error-conditions
+ (delete-dups (copy-sequence (cons name conditions))))
+ (when message (put name 'error-message message))))
+
+ ;; We put this here instead of in frame.el so that it's defined even on
+ ;; systems where frame.el isn't loaded.
+ (defun frame-configuration-p (object)
+ "Return non-nil if OBJECT seems to be a frame configuration.
+ Any list whose car is `frame-configuration' is assumed to be a frame
+ configuration."
+ (and (consp object)
+ (eq (car object) 'frame-configuration)))
+ \f
+ ;;;; List functions.
+
+ (defsubst caar (x)
+ "Return the car of the car of X."
+ (car (car x)))
+
+ (defsubst cadr (x)
+ "Return the car of the cdr of X."
+ (car (cdr x)))
+
+ (defsubst cdar (x)
+ "Return the cdr of the car of X."
+ (cdr (car x)))
+
+ (defsubst cddr (x)
+ "Return the cdr of the cdr of X."
+ (cdr (cdr x)))
+
+ (defun last (list &optional n)
+ "Return the last link of LIST. Its car is the last element.
+ If LIST is nil, return nil.
+ If N is non-nil, return the Nth-to-last link of LIST.
+ If N is bigger than the length of LIST, return LIST."
+ (if n
+ (and (>= n 0)
+ (let ((m (safe-length list)))
+ (if (< n m) (nthcdr (- m n) list) list)))
+ (and list
+ (nthcdr (1- (safe-length list)) list))))
+
+ (defun butlast (list &optional n)
+ "Return a copy of LIST with the last N elements removed.
+ If N is omitted or nil, the last element is removed from the
+ copy."
+ (if (and n (<= n 0)) list
+ (nbutlast (copy-sequence list) n)))
+
+ (defun nbutlast (list &optional n)
+ "Modifies LIST to remove the last N elements.
+ If N is omitted or nil, remove the last element."
+ (let ((m (length list)))
+ (or n (setq n 1))
+ (and (< n m)
+ (progn
+ (if (> n 0) (setcdr (nthcdr (- (1- m) n) list) nil))
+ list))))
+
+ (defun delete-dups (list)
+ "Destructively remove `equal' duplicates from LIST.
+ Store the result in LIST and return it. LIST must be a proper list.
+ Of several `equal' occurrences of an element in LIST, the first
+ one is kept."
+ (let ((tail list))
+ (while tail
+ (setcdr tail (delete (car tail) (cdr tail)))
+ (setq tail (cdr tail))))
+ list)
+
+ ;; See http://lists.gnu.org/archive/html/emacs-devel/2013-05/msg00204.html
+ (defun delete-consecutive-dups (list &optional circular)
+ "Destructively remove `equal' consecutive duplicates from LIST.
+ First and last elements are considered consecutive if CIRCULAR is
+ non-nil."
+ (let ((tail list) last)
+ (while (consp tail)
+ (if (equal (car tail) (cadr tail))
+ (setcdr tail (cddr tail))
+ (setq last (car tail)
+ tail (cdr tail))))
+ (if (and circular
+ (cdr list)
+ (equal last (car list)))
+ (nbutlast list)
+ list)))
+
+ (defun number-sequence (from &optional to inc)
+ "Return a sequence of numbers from FROM to TO (both inclusive) as a list.
+ INC is the increment used between numbers in the sequence and defaults to 1.
+ So, the Nth element of the list is (+ FROM (* N INC)) where N counts from
+ zero. TO is only included if there is an N for which TO = FROM + N * INC.
+ If TO is nil or numerically equal to FROM, return (FROM).
+ If INC is positive and TO is less than FROM, or INC is negative
+ and TO is larger than FROM, return nil.
+ If INC is zero and TO is neither nil nor numerically equal to
+ FROM, signal an error.
+
+ This function is primarily designed for integer arguments.
+ Nevertheless, FROM, TO and INC can be integer or float. However,
+ floating point arithmetic is inexact. For instance, depending on
+ the machine, it may quite well happen that
+ \(number-sequence 0.4 0.6 0.2) returns the one element list (0.4),
+ whereas (number-sequence 0.4 0.8 0.2) returns a list with three
+ elements. Thus, if some of the arguments are floats and one wants
+ to make sure that TO is included, one may have to explicitly write
+ TO as (+ FROM (* N INC)) or use a variable whose value was
+ computed with this exact expression. Alternatively, you can,
+ of course, also replace TO with a slightly larger value
+ \(or a slightly more negative value if INC is negative)."
+ (if (or (not to) (= from to))
+ (list from)
+ (or inc (setq inc 1))
+ (when (zerop inc) (error "The increment can not be zero"))
+ (let (seq (n 0) (next from))
+ (if (> inc 0)
+ (while (<= next to)
+ (setq seq (cons next seq)
+ n (1+ n)
+ next (+ from (* n inc))))
+ (while (>= next to)
+ (setq seq (cons next seq)
+ n (1+ n)
+ next (+ from (* n inc)))))
+ (nreverse seq))))
+
+ (defun copy-tree (tree &optional vecp)
+ "Make a copy of TREE.
+ If TREE is a cons cell, this recursively copies both its car and its cdr.
+ Contrast to `copy-sequence', which copies only along the cdrs. With second
+ argument VECP, this copies vectors as well as conses."
+ (if (consp tree)
+ (let (result)
+ (while (consp tree)
+ (let ((newcar (car tree)))
+ (if (or (consp (car tree)) (and vecp (vectorp (car tree))))
+ (setq newcar (copy-tree (car tree) vecp)))
+ (push newcar result))
+ (setq tree (cdr tree)))
+ (nconc (nreverse result) tree))
+ (if (and vecp (vectorp tree))
+ (let ((i (length (setq tree (copy-sequence tree)))))
+ (while (>= (setq i (1- i)) 0)
+ (aset tree i (copy-tree (aref tree i) vecp)))
+ tree)
+ tree)))
+ \f
+ ;;;; Various list-search functions.
+
+ (defun assoc-default (key alist &optional test default)
+ "Find object KEY in a pseudo-alist ALIST.
+ ALIST is a list of conses or objects. Each element
+ (or the element's car, if it is a cons) is compared with KEY by
+ calling TEST, with two arguments: (i) the element or its car,
+ and (ii) KEY.
+ If that is non-nil, the element matches; then `assoc-default'
+ returns the element's cdr, if it is a cons, or DEFAULT if the
+ element is not a cons.
+
+ If no element matches, the value is nil.
+ If TEST is omitted or nil, `equal' is used."
+ (let (found (tail alist) value)
+ (while (and tail (not found))
+ (let ((elt (car tail)))
+ (when (funcall (or test 'equal) (if (consp elt) (car elt) elt) key)
+ (setq found t value (if (consp elt) (cdr elt) default))))
+ (setq tail (cdr tail)))
+ value))
+
+ (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."
+ (declare (obsolete assoc-string "22.1"))
+ (assoc-string key alist t))
+
+ (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."
+ (declare (obsolete assoc-string "22.1"))
+ (assoc-string key alist nil))
+
+ (defun member-ignore-case (elt list)
+ "Like `member', but ignore differences in case and text representation.
+ ELT must be a string. Upper-case and lower-case letters are treated as equal.
+ Unibyte strings are converted to multibyte for comparison.
+ Non-strings in LIST are ignored."
+ (while (and list
+ (not (and (stringp (car list))
+ (eq t (compare-strings elt 0 nil (car list) 0 nil t)))))
+ (setq list (cdr list)))
+ list)
+
+ (defun assq-delete-all (key alist)
+ "Delete from ALIST all elements whose car is `eq' to KEY.
+ Return the modified alist.
+ Elements of ALIST that are not conses are ignored."
+ (while (and (consp (car alist))
+ (eq (car (car alist)) key))
+ (setq alist (cdr alist)))
+ (let ((tail alist) tail-cdr)
+ (while (setq tail-cdr (cdr tail))
+ (if (and (consp (car tail-cdr))
+ (eq (car (car tail-cdr)) key))
+ (setcdr tail (cdr tail-cdr))
+ (setq tail tail-cdr))))
+ alist)
+
+ (defun rassq-delete-all (value alist)
+ "Delete from ALIST all elements whose cdr is `eq' to VALUE.
+ Return the modified alist.
+ Elements of ALIST that are not conses are ignored."
+ (while (and (consp (car alist))
+ (eq (cdr (car alist)) value))
+ (setq alist (cdr alist)))
+ (let ((tail alist) tail-cdr)
+ (while (setq tail-cdr (cdr tail))
+ (if (and (consp (car tail-cdr))
+ (eq (cdr (car tail-cdr)) value))
+ (setcdr tail (cdr tail-cdr))
+ (setq tail tail-cdr))))
+ alist)
+
+ (defun remove (elt seq)
+ "Return a copy of SEQ with all occurrences of ELT removed.
+ SEQ must be a list, vector, or string. The comparison is done with `equal'."
+ (if (nlistp seq)
+ ;; If SEQ isn't a list, there's no need to copy SEQ because
+ ;; `delete' will return a new object.
+ (delete elt seq)
+ (delete elt (copy-sequence seq))))
+
+ (defun remq (elt list)
+ "Return LIST with all occurrences of ELT removed.
+ The comparison is done with `eq'. Contrary to `delq', this does not use
+ side-effects, and the argument LIST is not modified."
+ (while (and (eq elt (car list)) (setq list (cdr list))))
+ (if (memq elt list)
+ (delq elt (copy-sequence list))
+ list))
+ \f
+ ;;;; Keymap support.
+
+ (defun kbd (keys)
+ "Convert KEYS to the internal Emacs key representation.
+ KEYS should be a string constant in the format used for
+ saving keyboard macros (see `edmacro-mode')."
+ ;; Don't use a defalias, since the `pure' property is only true for
+ ;; the calling convention of `kbd'.
+ (read-kbd-macro keys))
+ (put 'kbd 'pure t)
+
+ (defun undefined ()
+ "Beep to tell the user this binding is undefined."
+ (interactive)
+ (ding)
+ (message "%s is undefined" (key-description (this-single-command-keys)))
+ (setq defining-kbd-macro nil)
+ (force-mode-line-update)
+ ;; If this is a down-mouse event, don't reset prefix-arg;
+ ;; pass it to the command run by the up event.
+ (setq prefix-arg
+ (when (memq 'down (event-modifiers last-command-event))
+ current-prefix-arg)))
+
+ ;; Prevent the \{...} documentation construct
+ ;; from mentioning keys that run this command.
+ (put 'undefined 'suppress-keymap t)
+
+ (defun suppress-keymap (map &optional nodigits)
+ "Make MAP override all normally self-inserting keys to be undefined.
+ Normally, as an exception, digits and minus-sign are set to make prefix args,
+ but optional second arg NODIGITS non-nil treats them like other chars."
+ (define-key map [remap self-insert-command] 'undefined)
+ (or nodigits
+ (let (loop)
+ (define-key map "-" 'negative-argument)
+ ;; Make plain numbers do numeric args.
+ (setq loop ?0)
+ (while (<= loop ?9)
+ (define-key map (char-to-string loop) 'digit-argument)
+ (setq loop (1+ loop))))))
+
+ (defun make-composed-keymap (maps &optional parent)
+ "Construct a new keymap composed of MAPS and inheriting from PARENT.
+ When looking up a key in the returned map, the key is looked in each
+ keymap of MAPS in turn until a binding is found.
+ If no binding is found in MAPS, the lookup continues in PARENT, if non-nil.
+ As always with keymap inheritance, a nil binding in MAPS overrides
+ any corresponding binding in PARENT, but it does not override corresponding
+ bindings in other keymaps of MAPS.
+ MAPS can be a list of keymaps or a single keymap.
+ PARENT if non-nil should be a keymap."
+ `(keymap
+ ,@(if (keymapp maps) (list maps) maps)
+ ,@parent))
+
+ (defun define-key-after (keymap key definition &optional after)
+ "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding.
+ This is like `define-key' except that the binding for KEY is placed
+ just after the binding for the event AFTER, instead of at the beginning
+ of the map. Note that AFTER must be an event type (like KEY), NOT a command
+ \(like DEFINITION).
+
+ If AFTER is t or omitted, the new binding goes at the end of the keymap.
+ AFTER should be a single event type--a symbol or a character, not a sequence.
+
+ Bindings are always added before any inherited map.
+
+ The order of bindings in a keymap only matters when it is used as
+ a menu, so this function is not useful for non-menu keymaps."
+ (unless after (setq after t))
+ (or (keymapp keymap)
+ (signal 'wrong-type-argument (list 'keymapp keymap)))
+ (setq key
+ (if (<= (length key) 1) (aref key 0)
+ (setq keymap (lookup-key keymap
+ (apply 'vector
+ (butlast (mapcar 'identity key)))))
+ (aref key (1- (length key)))))
+ (let ((tail keymap) done inserted)
+ (while (and (not done) tail)
+ ;; Delete any earlier bindings for the same key.
+ (if (eq (car-safe (car (cdr tail))) key)
+ (setcdr tail (cdr (cdr tail))))
+ ;; If we hit an included map, go down that one.
+ (if (keymapp (car tail)) (setq tail (car tail)))
+ ;; When we reach AFTER's binding, insert the new binding after.
+ ;; If we reach an inherited keymap, insert just before that.
+ ;; If we reach the end of this keymap, insert at the end.
+ (if (or (and (eq (car-safe (car tail)) after)
+ (not (eq after t)))
+ (eq (car (cdr tail)) 'keymap)
+ (null (cdr tail)))
+ (progn
+ ;; Stop the scan only if we find a parent keymap.
+ ;; Keep going past the inserted element
+ ;; so we can delete any duplications that come later.
+ (if (eq (car (cdr tail)) 'keymap)
+ (setq done t))
+ ;; Don't insert more than once.
+ (or inserted
+ (setcdr tail (cons (cons key definition) (cdr tail))))
+ (setq inserted t)))
+ (setq tail (cdr tail)))))
+
+ (defun map-keymap-sorted (function keymap)
+ "Implement `map-keymap' with sorting.
+ Don't call this function; it is for internal use only."
+ (let (list)
+ (map-keymap (lambda (a b) (push (cons a b) list))
+ keymap)
+ (setq list (sort list
+ (lambda (a b)
+ (setq a (car a) b (car b))
+ (if (integerp a)
+ (if (integerp b) (< a b)
+ t)
+ (if (integerp b) t
+ ;; string< also accepts symbols.
+ (string< a b))))))
+ (dolist (p list)
+ (funcall function (car p) (cdr p)))))
+
+ (defun keymap--menu-item-binding (val)
+ "Return the binding part of a menu-item."
+ (cond
+ ((not (consp val)) val) ;Not a menu-item.
+ ((eq 'menu-item (car val))
+ (let* ((binding (nth 2 val))
+ (plist (nthcdr 3 val))
+ (filter (plist-get plist :filter)))
+ (if filter (funcall filter binding)
+ binding)))
+ ((and (consp (cdr val)) (stringp (cadr val)))
+ (cddr val))
+ ((stringp (car val))
+ (cdr val))
+ (t val))) ;Not a menu-item either.
+
+ (defun keymap--menu-item-with-binding (item binding)
+ "Build a menu-item like ITEM but with its binding changed to BINDING."
+ (cond
+ ((not (consp item)) binding) ;Not a menu-item.
+ ((eq 'menu-item (car item))
+ (setq item (copy-sequence item))
+ (let ((tail (nthcdr 2 item)))
+ (setcar tail binding)
+ ;; Remove any potential filter.
+ (if (plist-get (cdr tail) :filter)
+ (setcdr tail (plist-put (cdr tail) :filter nil))))
+ item)
+ ((and (consp (cdr item)) (stringp (cadr item)))
+ (cons (car item) (cons (cadr item) binding)))
+ (t (cons (car item) binding))))
+
+ (defun keymap--merge-bindings (val1 val2)
+ "Merge bindings VAL1 and VAL2."
+ (let ((map1 (keymap--menu-item-binding val1))
+ (map2 (keymap--menu-item-binding val2)))
+ (if (not (and (keymapp map1) (keymapp map2)))
+ ;; There's nothing to merge: val1 takes precedence.
+ val1
+ (let ((map (list 'keymap map1 map2))
+ (item (if (keymapp val1) (if (keymapp val2) nil val2) val1)))
+ (keymap--menu-item-with-binding item map)))))
+
+ (defun keymap-canonicalize (map)
+ "Return a simpler equivalent keymap.
+ This resolves inheritance and redefinitions. The returned keymap
+ should behave identically to a copy of KEYMAP w.r.t `lookup-key'
+ and use in active keymaps and menus.
+ Subkeymaps may be modified but are not canonicalized."
+ ;; FIXME: Problem with the difference between a nil binding
+ ;; that hides a binding in an inherited map and a nil binding that's ignored
+ ;; to let some further binding visible. Currently a nil binding hides all.
+ ;; FIXME: we may want to carefully (re)order elements in case they're
+ ;; menu-entries.
+ (let ((bindings ())
+ (ranges ())
+ (prompt (keymap-prompt map)))
+ (while (keymapp map)
+ (setq map (map-keymap ;; -internal
+ (lambda (key item)
+ (if (consp key)
+ ;; Treat char-ranges specially.
+ (push (cons key item) ranges)
+ (push (cons key item) bindings)))
+ map)))
+ ;; Create the new map.
+ (setq map (funcall (if ranges 'make-keymap 'make-sparse-keymap) prompt))
+ (dolist (binding ranges)
+ ;; Treat char-ranges specially. FIXME: need to merge as well.
+ (define-key map (vector (car binding)) (cdr binding)))
+ ;; Process the bindings starting from the end.
+ (dolist (binding (prog1 bindings (setq bindings ())))
+ (let* ((key (car binding))
+ (oldbind (assq key bindings)))
+ (push (if (not oldbind)
+ ;; The normal case: no duplicate bindings.
+ binding
+ ;; This is the second binding for this key.
+ (setq bindings (delq oldbind bindings))
+ (cons key (keymap--merge-bindings (cdr binding)
+ (cdr oldbind))))
+ bindings)))
+ (nconc map bindings)))
+
+ (put 'keyboard-translate-table 'char-table-extra-slots 0)
+
+ (defun keyboard-translate (from to)
+ "Translate character FROM to TO on the current terminal.
+ This function creates a `keyboard-translate-table' if necessary
+ and then modifies one entry in it."
+ (or (char-table-p keyboard-translate-table)
+ (setq keyboard-translate-table
+ (make-char-table 'keyboard-translate-table nil)))
+ (aset keyboard-translate-table from to))
+ \f
+ ;;;; Key binding commands.
+
+ (defun global-set-key (key command)
+ "Give KEY a global binding as COMMAND.
+ COMMAND is the command definition to use; usually it is
+ a symbol naming an interactively-callable function.
+ KEY is a key sequence; noninteractively, it is a string or vector
+ of characters or event types, and non-ASCII characters with codes
+ above 127 (such as ISO Latin-1) can be included if you use a vector.
+
+ Note that if KEY has a local binding in the current buffer,
+ that local binding will continue to shadow any global binding
+ that you make with this function."
+ (interactive "KSet key globally: \nCSet key %s to command: ")
+ (or (vectorp key) (stringp key)
+ (signal 'wrong-type-argument (list 'arrayp key)))
+ (define-key (current-global-map) key command))
+
+ (defun local-set-key (key command)
+ "Give KEY a local binding as COMMAND.
+ COMMAND is the command definition to use; usually it is
+ a symbol naming an interactively-callable function.
+ KEY is a key sequence; noninteractively, it is a string or vector
+ of characters or event types, and non-ASCII characters with codes
+ above 127 (such as ISO Latin-1) can be included if you use a vector.
+
+ The binding goes in the current buffer's local map, which in most
+ cases is shared with all other buffers in the same major mode."
+ (interactive "KSet key locally: \nCSet key %s locally to command: ")
+ (let ((map (current-local-map)))
+ (or map
+ (use-local-map (setq map (make-sparse-keymap))))
+ (or (vectorp key) (stringp key)
+ (signal 'wrong-type-argument (list 'arrayp key)))
+ (define-key map key command)))
+
+ (defun global-unset-key (key)
+ "Remove global binding of KEY.
+ KEY is a string or vector representing a sequence of keystrokes."
+ (interactive "kUnset key globally: ")
+ (global-set-key key nil))
+
+ (defun local-unset-key (key)
+ "Remove local binding of KEY.
+ KEY is a string or vector representing a sequence of keystrokes."
+ (interactive "kUnset key locally: ")
+ (if (current-local-map)
+ (local-set-key key nil))
+ nil)
+ \f
+ ;;;; substitute-key-definition and its subroutines.
+
+ (defvar key-substitution-in-progress nil
+ "Used internally by `substitute-key-definition'.")
+
+ (defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix)
+ "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
+ In other words, OLDDEF is replaced with NEWDEF where ever it appears.
+ Alternatively, if optional fourth argument OLDMAP is specified, we redefine
+ in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP.
+
+ If you don't specify OLDMAP, you can usually get the same results
+ in a cleaner way with command remapping, like this:
+ (define-key KEYMAP [remap OLDDEF] NEWDEF)
+ \n(fn OLDDEF NEWDEF KEYMAP &optional OLDMAP)"
+ ;; Don't document PREFIX in the doc string because we don't want to
+ ;; advertise it. It's meant for recursive calls only. Here's its
+ ;; meaning
+
+ ;; If optional argument PREFIX is specified, it should be a key
+ ;; prefix, a string. Redefined bindings will then be bound to the
+ ;; original key, with PREFIX added at the front.
+ (or prefix (setq prefix ""))
+ (let* ((scan (or oldmap keymap))
+ (prefix1 (vconcat prefix [nil]))
+ (key-substitution-in-progress
+ (cons scan key-substitution-in-progress)))
+ ;; Scan OLDMAP, finding each char or event-symbol that
+ ;; has any definition, and act on it with hack-key.
+ (map-keymap
+ (lambda (char defn)
+ (aset prefix1 (length prefix) char)
+ (substitute-key-definition-key defn olddef newdef prefix1 keymap))
+ scan)))
+
+ (defun substitute-key-definition-key (defn olddef newdef prefix keymap)
+ (let (inner-def skipped menu-item)
+ ;; Find the actual command name within the binding.
+ (if (eq (car-safe defn) 'menu-item)
+ (setq menu-item defn defn (nth 2 defn))
+ ;; Skip past menu-prompt.
+ (while (stringp (car-safe defn))
+ (push (pop defn) skipped))
+ ;; Skip past cached key-equivalence data for menu items.
+ (if (consp (car-safe defn))
+ (setq defn (cdr defn))))
+ (if (or (eq defn olddef)
+ ;; Compare with equal if definition is a key sequence.
+ ;; That is useful for operating on function-key-map.
+ (and (or (stringp defn) (vectorp defn))
+ (equal defn olddef)))
+ (define-key keymap prefix
+ (if menu-item
+ (let ((copy (copy-sequence menu-item)))
+ (setcar (nthcdr 2 copy) newdef)
+ copy)
+ (nconc (nreverse skipped) newdef)))
+ ;; Look past a symbol that names a keymap.
+ (setq inner-def
+ (or (indirect-function defn t) defn))
+ ;; For nested keymaps, we use `inner-def' rather than `defn' so as to
+ ;; avoid autoloading a keymap. This is mostly done to preserve the
+ ;; original non-autoloading behavior of pre-map-keymap times.
+ (if (and (keymapp inner-def)
+ ;; Avoid recursively scanning
+ ;; where KEYMAP does not have a submap.
+ (let ((elt (lookup-key keymap prefix)))
+ (or (null elt) (natnump elt) (keymapp elt)))
+ ;; Avoid recursively rescanning keymap being scanned.
+ (not (memq inner-def key-substitution-in-progress)))
+ ;; If this one isn't being scanned already, scan it now.
+ (substitute-key-definition olddef newdef keymap inner-def prefix)))))
+
+ \f
+ ;;;; The global keymap tree.
+
+ ;; global-map, esc-map, and ctl-x-map have their values set up in
+ ;; keymap.c; we just give them docstrings here.
+
+ (defvar global-map nil
+ "Default global keymap mapping Emacs keyboard input into commands.
+ The value is a keymap which is usually (but not necessarily) Emacs's
+ global map.")
+
+ (defvar esc-map nil
+ "Default keymap for ESC (meta) commands.
+ The normal global definition of the character ESC indirects to this keymap.")
+
+ (defvar ctl-x-map nil
+ "Default keymap for C-x commands.
+ The normal global definition of the character C-x indirects to this keymap.")
+
+ (defvar ctl-x-4-map (make-sparse-keymap)
+ "Keymap for subcommands of C-x 4.")
+ (defalias 'ctl-x-4-prefix ctl-x-4-map)
+ (define-key ctl-x-map "4" 'ctl-x-4-prefix)
+
+ (defvar ctl-x-5-map (make-sparse-keymap)
+ "Keymap for frame commands.")
+ (defalias 'ctl-x-5-prefix ctl-x-5-map)
+ (define-key ctl-x-map "5" 'ctl-x-5-prefix)
+
+ \f
+ ;;;; Event manipulation functions.
+
+ (defconst listify-key-sequence-1 (logior 128 ?\M-\C-@))
+
+ (defun listify-key-sequence (key)
+ "Convert a key sequence to a list of events."
+ (if (vectorp key)
+ (append key nil)
+ (mapcar (function (lambda (c)
+ (if (> c 127)
+ (logxor c listify-key-sequence-1)
+ c)))
+ key)))
+
+ (defun eventp (obj)
+ "True if the argument is an event object."
+ (when obj
+ (or (integerp obj)
+ (and (symbolp obj) obj (not (keywordp obj)))
+ (and (consp obj) (symbolp (car obj))))))
+
+ (defun event-modifiers (event)
+ "Return a list of symbols representing the modifier keys in event EVENT.
+ The elements of the list may include `meta', `control',
+ `shift', `hyper', `super', `alt', `click', `double', `triple', `drag',
+ and `down'.
+ EVENT may be an event or an event type. If EVENT is a symbol
+ that has never been used in an event that has been read as input
+ in the current Emacs session, then this function may fail to include
+ the `click' modifier."
+ (let ((type event))
+ (if (listp type)
+ (setq type (car type)))
+ (if (symbolp type)
+ ;; Don't read event-symbol-elements directly since we're not
+ ;; sure the symbol has already been parsed.
+ (cdr (internal-event-symbol-parse-modifiers type))
+ (let ((list nil)
+ (char (logand type (lognot (logior ?\M-\^@ ?\C-\^@ ?\S-\^@
+ ?\H-\^@ ?\s-\^@ ?\A-\^@)))))
+ (if (not (zerop (logand type ?\M-\^@)))
+ (push 'meta list))
+ (if (or (not (zerop (logand type ?\C-\^@)))
+ (< char 32))
+ (push 'control list))
+ (if (or (not (zerop (logand type ?\S-\^@)))
+ (/= char (downcase char)))
+ (push 'shift list))
+ (or (zerop (logand type ?\H-\^@))
+ (push 'hyper list))
+ (or (zerop (logand type ?\s-\^@))
+ (push 'super list))
+ (or (zerop (logand type ?\A-\^@))
+ (push 'alt list))
+ list))))
+
+ (defun event-basic-type (event)
+ "Return the basic type of the given event (all modifiers removed).
+ The value is a printing character (not upper case) or a symbol.
+ EVENT may be an event or an event type. If EVENT is a symbol
+ that has never been used in an event that has been read as input
+ in the current Emacs session, then this function may return nil."
+ (if (consp event)
+ (setq event (car event)))
+ (if (symbolp event)
+ (car (get event 'event-symbol-elements))
+ (let* ((base (logand event (1- ?\A-\^@)))
+ (uncontrolled (if (< base 32) (logior base 64) base)))
+ ;; There are some numbers that are invalid characters and
+ ;; cause `downcase' to get an error.
+ (condition-case ()
+ (downcase uncontrolled)
+ (error uncontrolled)))))
+
+ (defsubst mouse-movement-p (object)
+ "Return non-nil if OBJECT is a mouse movement event."
+ (eq (car-safe object) 'mouse-movement))
+
+ (defun mouse-event-p (object)
+ "Return non-nil if OBJECT is a mouse click event."
+ ;; is this really correct? maybe remove mouse-movement?
+ (memq (event-basic-type object) '(mouse-1 mouse-2 mouse-3 mouse-movement)))
+
+ (defun event-start (event)
+ "Return the starting position of EVENT.
+ EVENT should be a mouse click, drag, or key press event. If
+ EVENT is nil, the value of `posn-at-point' is used instead.
+
+ The following accessor functions are used to access the elements
+ of the position:
+
+ `posn-window': The window the event is in.
+ `posn-area': A symbol identifying the area the event occurred in,
+ or nil if the event occurred in the text area.
+ `posn-point': The buffer position of the event.
+ `posn-x-y': The pixel-based coordinates of the event.
+ `posn-col-row': The estimated column and row corresponding to the
+ position of the event.
+ `posn-actual-col-row': The actual column and row corresponding to the
+ position of the event.
+ `posn-string': The string object of the event, which is either
+ nil or (STRING . POSITION)'.
+ `posn-image': The image object of the event, if any.
+ `posn-object': The image or string object of the event, if any.
+ `posn-timestamp': The time the event occurred, in milliseconds.
+
+ For more information, see Info node `(elisp)Click Events'."
+ (if (consp event) (nth 1 event)
+ (or (posn-at-point)
+ (list (selected-window) (point) '(0 . 0) 0))))
+
+ (defun event-end (event)
+ "Return the ending position of EVENT.
+ EVENT should be a click, drag, or key press event.
+
+ See `event-start' for a description of the value returned."
+ (if (consp event) (nth (if (consp (nth 2 event)) 2 1) event)
+ (or (posn-at-point)
+ (list (selected-window) (point) '(0 . 0) 0))))
+
+ (defsubst event-click-count (event)
+ "Return the multi-click count of EVENT, a click or drag event.
+ The return value is a positive integer."
+ (if (and (consp event) (integerp (nth 2 event))) (nth 2 event) 1))
+ \f
+ ;;;; Extracting fields of the positions in an event.
+
+ (defun posnp (obj)
+ "Return non-nil if OBJ appears to be a valid `posn' object specifying a window.
+ If OBJ is a valid `posn' object, but specifies a frame rather
+ than a window, return nil."
+ ;; FIXME: Correct the behavior of this function so that all valid
+ ;; `posn' objects are recognized, after updating other code that
+ ;; depends on its present behavior.
+ (and (windowp (car-safe obj))
+ (atom (car-safe (setq obj (cdr obj)))) ;AREA-OR-POS.
+ (integerp (car-safe (car-safe (setq obj (cdr obj))))) ;XOFFSET.
+ (integerp (car-safe (cdr obj))))) ;TIMESTAMP.
+
+ (defsubst posn-window (position)
+ "Return the window in POSITION.
+ POSITION should be a list of the form returned by the `event-start'
+ and `event-end' functions."
+ (nth 0 position))
+
+ (defsubst posn-area (position)
+ "Return the window area recorded in POSITION, or nil for the text area.
+ POSITION should be a list of the form returned by the `event-start'
+ and `event-end' functions."
+ (let ((area (if (consp (nth 1 position))
+ (car (nth 1 position))
+ (nth 1 position))))
+ (and (symbolp area) area)))
+
+ (defun posn-point (position)
+ "Return the buffer location in POSITION.
+ POSITION should be a list of the form returned by the `event-start'
+ and `event-end' functions.
+ Returns nil if POSITION does not correspond to any buffer location (e.g.
+ a click on a scroll bar)."
+ (or (nth 5 position)
+ (let ((pt (nth 1 position)))
+ (or (car-safe pt)
+ ;; Apparently this can also be `vertical-scroll-bar' (bug#13979).
+ (if (integerp pt) pt)))))
+
+ (defun posn-set-point (position)
+ "Move point to POSITION.
+ Select the corresponding window as well."
+ (if (not (windowp (posn-window position)))
+ (error "Position not in text area of window"))
+ (select-window (posn-window position))
+ (if (numberp (posn-point position))
+ (goto-char (posn-point position))))
+
+ (defsubst posn-x-y (position)
+ "Return the x and y coordinates in POSITION.
+ The return value has the form (X . Y), where X and Y are given in
+ pixels. POSITION should be a list of the form returned by
+ `event-start' and `event-end'."
+ (nth 2 position))
+
+ (declare-function scroll-bar-scale "scroll-bar" (num-denom whole))
+
+ (defun posn-col-row (position)
+ "Return the nominal column and row in POSITION, measured in characters.
+ The column and row values are approximations calculated from the x
+ and y coordinates in POSITION and the frame's default character width
+ and default line height, including spacing.
+ For a scroll-bar event, the result column is 0, and the row
+ corresponds to the vertical position of the click in the scroll bar.
+ POSITION should be a list of the form returned by the `event-start'
+ and `event-end' functions."
+ (let* ((pair (posn-x-y position))
+ (frame-or-window (posn-window position))
+ (frame (if (framep frame-or-window)
+ frame-or-window
+ (window-frame frame-or-window)))
+ (window (when (windowp frame-or-window) frame-or-window))
+ (area (posn-area position)))
+ (cond
+ ((null frame-or-window)
+ '(0 . 0))
+ ((eq area 'vertical-scroll-bar)
+ (cons 0 (scroll-bar-scale pair (1- (window-height window)))))
+ ((eq area 'horizontal-scroll-bar)
+ (cons (scroll-bar-scale pair (window-width window)) 0))
+ (t
+ ;; FIXME: This should take line-spacing properties on
+ ;; newlines into account.
+ (let* ((spacing (when (display-graphic-p frame)
+ (or (with-current-buffer
+ (window-buffer (frame-selected-window frame))
+ line-spacing)
+ (frame-parameter frame 'line-spacing)))))
+ (cond ((floatp spacing)
+ (setq spacing (truncate (* spacing
+ (frame-char-height frame)))))
+ ((null spacing)
+ (setq spacing 0)))
+ (cons (/ (car pair) (frame-char-width frame))
+ (/ (cdr pair) (+ (frame-char-height frame) spacing))))))))
+
+ (defun posn-actual-col-row (position)
+ "Return the window row number in POSITION and character number in that row.
+
+ Return nil if POSITION does not contain the actual position; in that case
+ \`posn-col-row' can be used to get approximate values.
+ POSITION should be a list of the form returned by the `event-start'
+ and `event-end' functions.
+
+ This function does not account for the width on display, like the
+ number of visual columns taken by a TAB or image. If you need
+ the coordinates of POSITION in character units, you should use
+ \`posn-col-row', not this function."
+ (nth 6 position))
+
+ (defsubst posn-timestamp (position)
+ "Return the timestamp of POSITION.
+ POSITION should be a list of the form returned by the `event-start'
+ and `event-end' functions."
+ (nth 3 position))
+
+ (defun posn-string (position)
+ "Return the string object of POSITION.
+ Value is a cons (STRING . STRING-POS), or nil if not a string.
+ POSITION should be a list of the form returned by the `event-start'
+ and `event-end' functions."
+ (let ((x (nth 4 position)))
+ ;; Apparently this can also be `handle' or `below-handle' (bug#13979).
+ (when (consp x) x)))
+
+ (defsubst posn-image (position)
+ "Return the image object of POSITION.
+ Value is a list (image ...), or nil if not an image.
+ POSITION should be a list of the form returned by the `event-start'
+ and `event-end' functions."
+ (nth 7 position))
+
+ (defsubst posn-object (position)
+ "Return the object (image or string) of POSITION.
+ Value is a list (image ...) for an image object, a cons cell
+ \(STRING . STRING-POS) for a string object, and nil for a buffer position.
+ POSITION should be a list of the form returned by the `event-start'
+ and `event-end' functions."
+ (or (posn-image position) (posn-string position)))
+
+ (defsubst posn-object-x-y (position)
+ "Return the x and y coordinates relative to the object of POSITION.
+ The return value has the form (DX . DY), where DX and DY are
+ given in pixels. POSITION should be a list of the form returned
+ by `event-start' and `event-end'."
+ (nth 8 position))
+
+ (defsubst posn-object-width-height (position)
+ "Return the pixel width and height of the object of POSITION.
+ The return value has the form (WIDTH . HEIGHT). POSITION should
+ be a list of the form returned by `event-start' and `event-end'."
+ (nth 9 position))
+
+ \f
+ ;;;; Obsolescent names for functions.
+
+ (define-obsolete-function-alias 'window-dot 'window-point "22.1")
+ (define-obsolete-function-alias 'set-window-dot 'set-window-point "22.1")
+ (define-obsolete-function-alias 'read-input 'read-string "22.1")
+ (define-obsolete-function-alias 'show-buffer 'set-window-buffer "22.1")
+ (define-obsolete-function-alias 'eval-current-buffer 'eval-buffer "22.1")
+ (define-obsolete-function-alias 'string-to-int 'string-to-number "22.1")
+
+ (make-obsolete 'forward-point "use (+ (point) N) instead." "23.1")
+ (make-obsolete 'buffer-has-markers-at nil "24.3")
+
+ (defun insert-string (&rest args)
+ "Mocklisp-compatibility insert function.
+ Like the function `insert' except that any argument that is a number
+ is converted into a string by expressing it in decimal."
+ (declare (obsolete insert "22.1"))
+ (dolist (el args)
+ (insert (if (integerp el) (number-to-string el) el))))
+
+ (defun makehash (&optional test)
+ (declare (obsolete make-hash-table "22.1"))
+ (make-hash-table :test (or test 'eql)))
+
+ (defun log10 (x)
+ "Return (log X 10), the log base 10 of X."
+ (declare (obsolete log "24.4"))
+ (log x 10))
+
+ ;; These are used by VM and some old programs
+ (defalias 'focus-frame 'ignore "")
+ (make-obsolete 'focus-frame "it does nothing." "22.1")
+ (defalias 'unfocus-frame 'ignore "")
+ (make-obsolete 'unfocus-frame "it does nothing." "22.1")
+ (make-obsolete 'make-variable-frame-local
+ "explicitly check for a frame-parameter instead." "22.2")
+ (set-advertised-calling-convention
+ 'all-completions '(string collection &optional predicate) "23.1")
+ (set-advertised-calling-convention 'unintern '(name obarray) "23.3")
+ (set-advertised-calling-convention 'redirect-frame-focus '(frame focus-frame) "24.3")
+ (set-advertised-calling-convention 'decode-char '(ch charset) "21.4")
+ (set-advertised-calling-convention 'encode-char '(ch charset) "21.4")
+ \f
+ ;;;; Obsolescence declarations for variables, and aliases.
+
+ ;; Special "default-FOO" variables which contain the default value of
+ ;; the "FOO" variable are nasty. Their implementation is brittle, and
+ ;; slows down several unrelated variable operations; furthermore, they
+ ;; can lead to really odd behavior if you decide to make them
+ ;; buffer-local.
+
+ ;; Not used at all in Emacs, last time I checked:
+ (make-obsolete-variable 'default-mode-line-format 'mode-line-format "23.2")
+ (make-obsolete-variable 'default-header-line-format 'header-line-format "23.2")
+ (make-obsolete-variable 'default-line-spacing 'line-spacing "23.2")
+ (make-obsolete-variable 'default-abbrev-mode 'abbrev-mode "23.2")
+ (make-obsolete-variable 'default-ctl-arrow 'ctl-arrow "23.2")
+ (make-obsolete-variable 'default-truncate-lines 'truncate-lines "23.2")
+ (make-obsolete-variable 'default-left-margin 'left-margin "23.2")
+ (make-obsolete-variable 'default-tab-width 'tab-width "23.2")
+ (make-obsolete-variable 'default-case-fold-search 'case-fold-search "23.2")
+ (make-obsolete-variable 'default-left-margin-width 'left-margin-width "23.2")
+ (make-obsolete-variable 'default-right-margin-width 'right-margin-width "23.2")
+ (make-obsolete-variable 'default-left-fringe-width 'left-fringe-width "23.2")
+ (make-obsolete-variable 'default-right-fringe-width 'right-fringe-width "23.2")
+ (make-obsolete-variable 'default-fringes-outside-margins 'fringes-outside-margins "23.2")
+ (make-obsolete-variable 'default-scroll-bar-width 'scroll-bar-width "23.2")
+ (make-obsolete-variable 'default-vertical-scroll-bar 'vertical-scroll-bar "23.2")
+ (make-obsolete-variable 'default-indicate-empty-lines 'indicate-empty-lines "23.2")
+ (make-obsolete-variable 'default-indicate-buffer-boundaries 'indicate-buffer-boundaries "23.2")
+ (make-obsolete-variable 'default-fringe-indicator-alist 'fringe-indicator-alist "23.2")
+ (make-obsolete-variable 'default-fringe-cursor-alist 'fringe-cursor-alist "23.2")
+ (make-obsolete-variable 'default-scroll-up-aggressively 'scroll-up-aggressively "23.2")
+ (make-obsolete-variable 'default-scroll-down-aggressively 'scroll-down-aggressively "23.2")
+ (make-obsolete-variable 'default-fill-column 'fill-column "23.2")
+ (make-obsolete-variable 'default-cursor-type 'cursor-type "23.2")
+ (make-obsolete-variable 'default-cursor-in-non-selected-windows 'cursor-in-non-selected-windows "23.2")
+ (make-obsolete-variable 'default-buffer-file-coding-system 'buffer-file-coding-system "23.2")
+ (make-obsolete-variable 'default-major-mode 'major-mode "23.2")
+ (make-obsolete-variable 'default-enable-multibyte-characters
+ "use enable-multibyte-characters or set-buffer-multibyte instead" "23.2")
+
+ (make-obsolete-variable 'define-key-rebound-commands nil "23.2")
+ (make-obsolete-variable 'redisplay-end-trigger-functions 'jit-lock-register "23.1")
+ (make-obsolete-variable 'deferred-action-list 'post-command-hook "24.1")
+ (make-obsolete-variable 'deferred-action-function 'post-command-hook "24.1")
+ (make-obsolete-variable 'redisplay-dont-pause nil "24.5")
+ (make-obsolete 'window-redisplay-end-trigger nil "23.1")
+ (make-obsolete 'set-window-redisplay-end-trigger nil "23.1")
+
+ (make-obsolete 'process-filter-multibyte-p nil "23.1")
+ (make-obsolete 'set-process-filter-multibyte nil "23.1")
+
+ ;; Lisp manual only updated in 22.1.
+ (define-obsolete-variable-alias 'executing-macro 'executing-kbd-macro
+ "before 19.34")
+
+ (define-obsolete-variable-alias 'x-lost-selection-hooks
+ 'x-lost-selection-functions "22.1")
+ (define-obsolete-variable-alias 'x-sent-selection-hooks
+ 'x-sent-selection-functions "22.1")
+
+ ;; This was introduced in 21.4 for pre-unicode unification. That
+ ;; usage was rendered obsolete in 23.1 which uses Unicode internally.
+ ;; Other uses are possible, so this variable is not _really_ obsolete,
+ ;; but Stefan insists to mark it so.
+ (make-obsolete-variable 'translation-table-for-input nil "23.1")
+
+ (defvaralias 'messages-buffer-max-lines 'message-log-max)
+ \f
+ ;;;; Alternate names for functions - these are not being phased out.
+
+ (defalias 'send-string 'process-send-string)
+ (defalias 'send-region 'process-send-region)
+ (defalias 'string= 'string-equal)
+ (defalias 'string< 'string-lessp)
+ (defalias 'move-marker 'set-marker)
+ (defalias 'rplaca 'setcar)
+ (defalias 'rplacd 'setcdr)
+ (defalias 'beep 'ding) ;preserve lingual purity
+ (defalias 'indent-to-column 'indent-to)
+ (defalias 'backward-delete-char 'delete-backward-char)
+ (defalias 'search-forward-regexp (symbol-function 're-search-forward))
+ (defalias 'search-backward-regexp (symbol-function 're-search-backward))
+ (defalias 'int-to-string 'number-to-string)
+ (defalias 'store-match-data 'set-match-data)
+ (defalias 'chmod 'set-file-modes)
+ (defalias 'mkdir 'make-directory)
+ ;; These are the XEmacs names:
+ (defalias 'point-at-eol 'line-end-position)
+ (defalias 'point-at-bol 'line-beginning-position)
+
+ (defalias 'user-original-login-name 'user-login-name)
+
+ \f
+ ;;;; Hook manipulation functions.
+
+ (defun add-hook (hook function &optional append local)
+ "Add to the value of HOOK the function FUNCTION.
+ FUNCTION is not added if already present.
+ FUNCTION is added (if necessary) at the beginning of the hook list
+ unless the optional argument APPEND is non-nil, in which case
+ FUNCTION is added at the end.
+
+ The optional fourth argument, LOCAL, if non-nil, says to modify
+ the hook's buffer-local value rather than its global value.
+ This makes the hook buffer-local, and it makes t a member of the
+ buffer-local value. That acts as a flag to run the hook
+ functions of the global value as well as in the local value.
+
+ HOOK should be a symbol, and FUNCTION may be any valid function. If
+ HOOK is void, it is first set to nil. If HOOK's value is a single
+ function, it is changed to a list of functions."
+ (or (boundp hook) (set hook nil))
+ (or (default-boundp hook) (set-default hook nil))
+ (if local (unless (local-variable-if-set-p hook)
+ (set (make-local-variable hook) (list t)))
+ ;; Detect the case where make-local-variable was used on a hook
+ ;; and do what we used to do.
+ (unless (and (consp (symbol-value hook)) (memq t (symbol-value hook)))
+ (setq local t)))
+ (let ((hook-value (if local (symbol-value hook) (default-value hook))))
+ ;; If the hook value is a single function, turn it into a list.
+ (when (or (not (listp hook-value)) (functionp hook-value))
+ (setq hook-value (list hook-value)))
+ ;; Do the actual addition if necessary
+ (unless (member function hook-value)
+ (when (stringp function)
+ (setq function (purecopy function)))
+ (setq hook-value
+ (if append
+ (append hook-value (list function))
+ (cons function hook-value))))
+ ;; Set the actual variable
+ (if local
+ (progn
+ ;; If HOOK isn't a permanent local,
+ ;; but FUNCTION wants to survive a change of modes,
+ ;; mark HOOK as partially permanent.
+ (and (symbolp function)
+ (get function 'permanent-local-hook)
+ (not (get hook 'permanent-local))
+ (put hook 'permanent-local 'permanent-local-hook))
+ (set hook hook-value))
+ (set-default hook hook-value))))
+
+ (defun remove-hook (hook function &optional local)
+ "Remove from the value of HOOK the function FUNCTION.
+ HOOK should be a symbol, and FUNCTION may be any valid function. If
+ FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the
+ list of hooks to run in HOOK, then nothing is done. See `add-hook'.
+
+ The optional third argument, LOCAL, if non-nil, says to modify
+ the hook's buffer-local value rather than its default value."
+ (or (boundp hook) (set hook nil))
+ (or (default-boundp hook) (set-default hook nil))
+ ;; Do nothing if LOCAL is t but this hook has no local binding.
+ (unless (and local (not (local-variable-p hook)))
+ ;; Detect the case where make-local-variable was used on a hook
+ ;; and do what we used to do.
+ (when (and (local-variable-p hook)
+ (not (and (consp (symbol-value hook))
+ (memq t (symbol-value hook)))))
+ (setq local t))
+ (let ((hook-value (if local (symbol-value hook) (default-value hook))))
+ ;; Remove the function, for both the list and the non-list cases.
+ (if (or (not (listp hook-value)) (eq (car hook-value) 'lambda))
+ (if (equal hook-value function) (setq hook-value nil))
+ (setq hook-value (delete function (copy-sequence hook-value))))
+ ;; If the function is on the global hook, we need to shadow it locally
+ ;;(when (and local (member function (default-value hook))
+ ;; (not (member (cons 'not function) hook-value)))
+ ;; (push (cons 'not function) hook-value))
+ ;; Set the actual variable
+ (if (not local)
+ (set-default hook hook-value)
+ (if (equal hook-value '(t))
+ (kill-local-variable hook)
+ (set hook hook-value))))))
+
+ (defmacro letrec (binders &rest body)
+ "Bind variables according to BINDERS then eval BODY.
+ The value of the last form in BODY is returned.
+ Each element of BINDERS is a list (SYMBOL VALUEFORM) which binds
+ SYMBOL to the value of VALUEFORM.
+ All symbols are bound before the VALUEFORMs are evalled."
+ ;; Only useful in lexical-binding mode.
+ ;; As a special-form, we could implement it more efficiently (and cleanly,
+ ;; making the vars actually unbound during evaluation of the binders).
+ (declare (debug let) (indent 1))
+ `(let ,(mapcar #'car binders)
+ ,@(mapcar (lambda (binder) `(setq ,@binder)) binders)
+ ,@body))
+
+ (defmacro with-wrapper-hook (hook args &rest body)
+ "Run BODY, using wrapper functions from HOOK with additional ARGS.
+ HOOK is an abnormal hook. Each hook function in HOOK \"wraps\"
+ around the preceding ones, like a set of nested `around' advices.
+
+ Each hook function should accept an argument list consisting of a
+ function FUN, followed by the additional arguments in ARGS.
+
+ The first hook function in HOOK is passed a FUN that, if it is called
+ with arguments ARGS, performs BODY (i.e., the default operation).
+ The FUN passed to each successive hook function is defined based
+ on the preceding hook functions; if called with arguments ARGS,
+ it does what the `with-wrapper-hook' call would do if the
+ preceding hook functions were the only ones present in HOOK.
+
+ Each hook function may call its FUN argument as many times as it wishes,
+ including never. In that case, such a hook function acts to replace
+ the default definition altogether, and any preceding hook functions.
+ Of course, a subsequent hook function may do the same thing.
+
+ Each hook function definition is used to construct the FUN passed
+ to the next hook function, if any. The last (or \"outermost\")
+ FUN is then called once."
+ (declare (indent 2) (debug (form sexp body))
+ (obsolete "use a <foo>-function variable modified by `add-function'."
+ "24.4"))
+ ;; We need those two gensyms because CL's lexical scoping is not available
+ ;; for function arguments :-(
+ (let ((funs (make-symbol "funs"))
+ (global (make-symbol "global"))
+ (argssym (make-symbol "args"))
+ (runrestofhook (make-symbol "runrestofhook")))
+ ;; Since the hook is a wrapper, the loop has to be done via
+ ;; recursion: a given hook function will call its parameter in order to
+ ;; continue looping.
+ `(letrec ((,runrestofhook
+ (lambda (,funs ,global ,argssym)
+ ;; `funs' holds the functions left on the hook and `global'
+ ;; holds the functions left on the global part of the hook
+ ;; (in case the hook is local).
+ (if (consp ,funs)
+ (if (eq t (car ,funs))
+ (funcall ,runrestofhook
+ (append ,global (cdr ,funs)) nil ,argssym)
+ (apply (car ,funs)
+ (apply-partially
+ (lambda (,funs ,global &rest ,argssym)
+ (funcall ,runrestofhook ,funs ,global ,argssym))
+ (cdr ,funs) ,global)
+ ,argssym))
+ ;; Once there are no more functions on the hook, run
+ ;; the original body.
+ (apply (lambda ,args ,@body) ,argssym)))))
+ (funcall ,runrestofhook ,hook
+ ;; The global part of the hook, if any.
+ ,(if (symbolp hook)
+ `(if (local-variable-p ',hook)
+ (default-value ',hook)))
+ (list ,@args)))))
+
+ (defun add-to-list (list-var element &optional append compare-fn)
+ "Add ELEMENT to the value of LIST-VAR if it isn't there yet.
+ The test for presence of ELEMENT is done with `equal', or with
+ COMPARE-FN if that's non-nil.
+ If ELEMENT is added, it is added at the beginning of the list,
+ unless the optional argument APPEND is non-nil, in which case
+ ELEMENT is added at the end.
+
+ The return value is the new value of LIST-VAR.
+
+ This is handy to add some elements to configuration variables,
+ but please do not abuse it in Elisp code, where you are usually
+ better off using `push' or `cl-pushnew'.
+
+ If you want to use `add-to-list' on a variable that is not
+ defined until a certain package is loaded, you should put the
+ call to `add-to-list' into a hook function that will be run only
+ after loading the package. `eval-after-load' provides one way to
+ do this. In some cases other hooks, such as major mode hooks,
+ can do the job."
+ (declare
+ (compiler-macro
+ (lambda (exp)
+ ;; FIXME: Something like this could be used for `set' as well.
+ (if (or (not (eq 'quote (car-safe list-var)))
+ (special-variable-p (cadr list-var))
+ (not (macroexp-const-p append)))
+ exp
+ (let* ((sym (cadr list-var))
+ (append (eval append))
+ (msg (format "`add-to-list' can't use lexical var `%s'; use `push' or `cl-pushnew'"
+ sym))
+ ;; Big ugly hack so we only output a warning during
+ ;; byte-compilation, and so we can use
+ ;; byte-compile-not-lexical-var-p to silence the warning
+ ;; when a defvar has been seen but not yet executed.
+ (warnfun (lambda ()
+ ;; FIXME: We should also emit a warning for let-bound
+ ;; variables with dynamic binding.
+ (when (assq sym byte-compile--lexical-environment)
+ (byte-compile-log-warning msg t :error))))
+ (code
+ (macroexp-let2 macroexp-copyable-p x element
+ `(if ,(if compare-fn
+ (progn
+ (require 'cl-lib)
+ `(cl-member ,x ,sym :test ,compare-fn))
+ ;; For bootstrapping reasons, don't rely on
+ ;; cl--compiler-macro-member for the base case.
+ `(member ,x ,sym))
+ ,sym
+ ,(if append
+ `(setq ,sym (append ,sym (list ,x)))
+ `(push ,x ,sym))))))
+ (if (not (macroexp--compiling-p))
+ code
+ `(progn
+ (macroexp--funcall-if-compiled ',warnfun)
+ ,code)))))))
+ (if (cond
+ ((null compare-fn)
+ (member element (symbol-value list-var)))
+ ((eq compare-fn 'eq)
+ (memq element (symbol-value list-var)))
+ ((eq compare-fn 'eql)
+ (memql element (symbol-value list-var)))
+ (t
+ (let ((lst (symbol-value list-var)))
+ (while (and lst
+ (not (funcall compare-fn element (car lst))))
+ (setq lst (cdr lst)))
+ lst)))
+ (symbol-value list-var)
+ (set list-var
+ (if append
+ (append (symbol-value list-var) (list element))
+ (cons element (symbol-value list-var))))))
+
+
+ (defun add-to-ordered-list (list-var element &optional order)
+ "Add ELEMENT to the value of LIST-VAR if it isn't there yet.
+ The test for presence of ELEMENT is done with `eq'.
+
+ The resulting list is reordered so that the elements are in the
+ order given by each element's numeric list order. Elements
+ without a numeric list order are placed at the end of the list.
+
+ If the third optional argument ORDER is a number (integer or
+ float), set the element's list order to the given value. If
+ ORDER is nil or omitted, do not change the numeric order of
+ ELEMENT. If ORDER has any other value, remove the numeric order
+ of ELEMENT if it has one.
+
+ The list order for each element is stored in LIST-VAR's
+ `list-order' property.
+
+ The return value is the new value of LIST-VAR."
+ (let ((ordering (get list-var 'list-order)))
+ (unless ordering
+ (put list-var 'list-order
+ (setq ordering (make-hash-table :weakness 'key :test 'eq))))
+ (when order
+ (puthash element (and (numberp order) order) ordering))
+ (unless (memq element (symbol-value list-var))
+ (set list-var (cons element (symbol-value list-var))))
+ (set list-var (sort (symbol-value list-var)
+ (lambda (a b)
+ (let ((oa (gethash a ordering))
+ (ob (gethash b ordering)))
+ (if (and oa ob)
+ (< oa ob)
+ oa)))))))
+
+ (defun add-to-history (history-var newelt &optional maxelt keep-all)
+ "Add NEWELT to the history list stored in the variable HISTORY-VAR.
+ Return the new history list.
+ If MAXELT is non-nil, it specifies the maximum length of the history.
+ Otherwise, the maximum history length is the value of the `history-length'
+ property on symbol HISTORY-VAR, if set, or the value of the `history-length'
+ variable.
+ Remove duplicates of NEWELT if `history-delete-duplicates' is non-nil.
+ If optional fourth arg KEEP-ALL is non-nil, add NEWELT to history even
+ if it is empty or a duplicate."
+ (unless maxelt
+ (setq maxelt (or (get history-var 'history-length)
+ history-length)))
+ (let ((history (symbol-value history-var))
+ tail)
+ (when (and (listp history)
+ (or keep-all
+ (not (stringp newelt))
+ (> (length newelt) 0))
+ (or keep-all
+ (not (equal (car history) newelt))))
+ (if history-delete-duplicates
+ (setq history (delete newelt history)))
+ (setq history (cons newelt history))
+ (when (integerp maxelt)
+ (if (= 0 maxelt)
+ (setq history nil)
+ (setq tail (nthcdr (1- maxelt) history))
+ (when (consp tail)
+ (setcdr tail nil)))))
+ (set history-var history)))
+
+ \f
+ ;;;; Mode hooks.
+
+ (defvar delay-mode-hooks nil
+ "If non-nil, `run-mode-hooks' should delay running the hooks.")
+ (defvar delayed-mode-hooks nil
+ "List of delayed mode hooks waiting to be run.")
+ (make-variable-buffer-local 'delayed-mode-hooks)
+ (put 'delay-mode-hooks 'permanent-local t)
+
+ (defvar change-major-mode-after-body-hook nil
+ "Normal hook run in major mode functions, before the mode hooks.")
+
+ (defvar after-change-major-mode-hook nil
+ "Normal hook run at the very end of major mode functions.")
+
+ (defun run-mode-hooks (&rest hooks)
+ "Run mode hooks `delayed-mode-hooks' and HOOKS, or delay HOOKS.
+ If the variable `delay-mode-hooks' is non-nil, does not run any hooks,
+ just adds the HOOKS to the list `delayed-mode-hooks'.
+ Otherwise, runs hooks in the sequence: `change-major-mode-after-body-hook',
+ `delayed-mode-hooks' (in reverse order), HOOKS, and finally
+ `after-change-major-mode-hook'. Major mode functions should use
+ this instead of `run-hooks' when running their FOO-mode-hook."
+ (if delay-mode-hooks
+ ;; Delaying case.
+ (dolist (hook hooks)
+ (push hook delayed-mode-hooks))
+ ;; Normal case, just run the hook as before plus any delayed hooks.
+ (setq hooks (nconc (nreverse delayed-mode-hooks) hooks))
+ (setq delayed-mode-hooks nil)
+ (apply 'run-hooks (cons 'change-major-mode-after-body-hook hooks))
+ (run-hooks 'after-change-major-mode-hook)))
+
+ (defmacro delay-mode-hooks (&rest body)
+ "Execute BODY, but delay any `run-mode-hooks'.
+ These hooks will be executed by the first following call to
+ `run-mode-hooks' that occurs outside any `delayed-mode-hooks' form.
+ Only affects hooks run in the current buffer."
+ (declare (debug t) (indent 0))
+ `(progn
+ (make-local-variable 'delay-mode-hooks)
+ (let ((delay-mode-hooks t))
+ ,@body)))
+
+ ;; PUBLIC: find if the current mode derives from another.
+
+ (defun derived-mode-p (&rest modes)
+ "Non-nil if the current major mode is derived from one of MODES.
+ Uses the `derived-mode-parent' property of the symbol to trace backwards."
+ (let ((parent major-mode))
+ (while (and (not (memq parent modes))
+ (setq parent (get parent 'derived-mode-parent))))
+ parent))
+ \f
+ ;;;; Minor modes.
+
+ ;; If a minor mode is not defined with define-minor-mode,
+ ;; add it here explicitly.
+ ;; isearch-mode is deliberately excluded, since you should
+ ;; not call it yourself.
+ (defvar minor-mode-list '(auto-save-mode auto-fill-mode abbrev-mode
+ overwrite-mode view-mode
+ hs-minor-mode)
+ "List of all minor mode functions.")
+
+ (defun add-minor-mode (toggle name &optional keymap after toggle-fun)
+ "Register a new minor mode.
+
+ This is an XEmacs-compatibility function. Use `define-minor-mode' instead.
+
+ TOGGLE is a symbol which is the name of a buffer-local variable that
+ is toggled on or off to say whether the minor mode is active or not.
+
+ NAME specifies what will appear in the mode line when the minor mode
+ is active. NAME should be either a string starting with a space, or a
+ symbol whose value is such a string.
+
+ Optional KEYMAP is the keymap for the minor mode that will be added
+ to `minor-mode-map-alist'.
+
+ Optional AFTER specifies that TOGGLE should be added after AFTER
+ in `minor-mode-alist'.
+
+ Optional TOGGLE-FUN is an interactive function to toggle the mode.
+ It defaults to (and should by convention be) TOGGLE.
+
+ If TOGGLE has a non-nil `:included' property, an entry for the mode is
+ included in the mode-line minor mode menu.
+ If TOGGLE has a `:menu-tag', that is used for the menu item's label."
+ (unless (memq toggle minor-mode-list)
+ (push toggle minor-mode-list))
+
+ (unless toggle-fun (setq toggle-fun toggle))
+ (unless (eq toggle-fun toggle)
+ (put toggle :minor-mode-function toggle-fun))
+ ;; Add the name to the minor-mode-alist.
+ (when name
+ (let ((existing (assq toggle minor-mode-alist)))
+ (if existing
+ (setcdr existing (list name))
+ (let ((tail minor-mode-alist) found)
+ (while (and tail (not found))
+ (if (eq after (caar tail))
+ (setq found tail)
+ (setq tail (cdr tail))))
+ (if found
+ (let ((rest (cdr found)))
+ (setcdr found nil)
+ (nconc found (list (list toggle name)) rest))
+ (push (list toggle name) minor-mode-alist))))))
+ ;; Add the toggle to the minor-modes menu if requested.
+ (when (get toggle :included)
+ (define-key mode-line-mode-menu
+ (vector toggle)
+ (list 'menu-item
+ (concat
+ (or (get toggle :menu-tag)
+ (if (stringp name) name (symbol-name toggle)))
+ (let ((mode-name (if (symbolp name) (symbol-value name))))
+ (if (and (stringp mode-name) (string-match "[^ ]+" mode-name))
+ (concat " (" (match-string 0 mode-name) ")"))))
+ toggle-fun
+ :button (cons :toggle toggle))))
+
+ ;; Add the map to the minor-mode-map-alist.
+ (when keymap
+ (let ((existing (assq toggle minor-mode-map-alist)))
+ (if existing
+ (setcdr existing keymap)
+ (let ((tail minor-mode-map-alist) found)
+ (while (and tail (not found))
+ (if (eq after (caar tail))
+ (setq found tail)
+ (setq tail (cdr tail))))
+ (if found
+ (let ((rest (cdr found)))
+ (setcdr found nil)
+ (nconc found (list (cons toggle keymap)) rest))
+ (push (cons toggle keymap) minor-mode-map-alist)))))))
+ \f
+ ;;;; Load history
+
+ (defsubst autoloadp (object)
+ "Non-nil if OBJECT is an autoload."
+ (eq 'autoload (car-safe object)))
+
+ ;; (defun autoload-type (object)
+ ;; "Returns the type of OBJECT or `function' or `command' if the type is nil.
+ ;; OBJECT should be an autoload object."
+ ;; (when (autoloadp object)
+ ;; (let ((type (nth 3 object)))
+ ;; (cond ((null type) (if (nth 2 object) 'command 'function))
+ ;; ((eq 'keymap t) 'macro)
+ ;; (type)))))
+
+ ;; (defalias 'autoload-file #'cadr
+ ;; "Return the name of the file from which AUTOLOAD will be loaded.
+ ;; \n\(fn AUTOLOAD)")
+
+ (defun symbol-file (symbol &optional type)
+ "Return the name of the file that defined SYMBOL.
+ The value is normally an absolute file name. It can also be nil,
+ if the definition is not associated with any file. If SYMBOL
+ specifies an autoloaded function, the value can be a relative
+ file name without extension.
+
+ If TYPE is nil, then any kind of definition is acceptable. If
+ TYPE is `defun', `defvar', or `defface', that specifies function
+ definition, variable definition, or face definition only."
+ (if (and (or (null type) (eq type 'defun))
+ (symbolp symbol)
+ (autoloadp (symbol-function symbol)))
+ (nth 1 (symbol-function symbol))
+ (let ((files load-history)
+ file)
+ (while files
+ (if (if type
+ (if (eq type 'defvar)
+ ;; Variables are present just as their names.
+ (member symbol (cdr (car files)))
+ ;; Other types are represented as (TYPE . NAME).
+ (member (cons type symbol) (cdr (car files))))
+ ;; We accept all types, so look for variable def
+ ;; and then for any other kind.
+ (or (member symbol (cdr (car files)))
+ (rassq symbol (cdr (car files)))))
+ (setq file (car (car files)) files nil))
+ (setq files (cdr files)))
+ file)))
+
+ (defun locate-library (library &optional nosuffix path interactive-call)
+ "Show the precise file name of Emacs library LIBRARY.
+ LIBRARY should be a relative file name of the library, a string.
+ It can omit the suffix (a.k.a. file-name extension) if NOSUFFIX is
+ nil (which is the default, see below).
+ This command searches the directories in `load-path' like `\\[load-library]'
+ to find the file that `\\[load-library] RET LIBRARY RET' would load.
+ Optional second arg NOSUFFIX non-nil means don't add suffixes `load-suffixes'
+ to the specified name LIBRARY.
+
+ If the optional third arg PATH is specified, that list of directories
+ is used instead of `load-path'.
+
+ When called from a program, the file name is normally returned as a
+ string. When run interactively, the argument INTERACTIVE-CALL is t,
+ and the file name is displayed in the echo area."
+ (interactive (list (completing-read "Locate library: "
+ (apply-partially
+ 'locate-file-completion-table
+ load-path (get-load-suffixes)))
+ nil nil
+ t))
+ (let ((file (locate-file library
+ (or path load-path)
+ (append (unless nosuffix (get-load-suffixes))
+ load-file-rep-suffixes))))
+ (if interactive-call
+ (if file
+ (message "Library is file %s" (abbreviate-file-name file))
+ (message "No library %s in search path" library)))
+ file))
+
+ \f
+ ;;;; Process stuff.
+
+ (defun process-lines (program &rest args)
+ "Execute PROGRAM with ARGS, returning its output as a list of lines.
+ Signal an error if the program returns with a non-zero exit status."
+ (with-temp-buffer
+ (let ((status (apply 'call-process program nil (current-buffer) nil args)))
+ (unless (eq status 0)
+ (error "%s exited with status %s" program status))
+ (goto-char (point-min))
+ (let (lines)
+ (while (not (eobp))
+ (setq lines (cons (buffer-substring-no-properties
+ (line-beginning-position)
+ (line-end-position))
+ lines))
+ (forward-line 1))
+ (nreverse lines)))))
+
+ (defun process-live-p (process)
+ "Returns non-nil if PROCESS is alive.
+ A process is considered alive if its status is `run', `open',
+ `listen', `connect' or `stop'. Value is nil if PROCESS is not a
+ process."
+ (and (processp process)
+ (memq (process-status process)
+ '(run open listen connect stop))))
+
+ ;; compatibility
+
+ (make-obsolete
+ 'process-kill-without-query
+ "use `process-query-on-exit-flag' or `set-process-query-on-exit-flag'."
+ "22.1")
+ (defun process-kill-without-query (process &optional _flag)
+ "Say no query needed if PROCESS is running when Emacs is exited.
+ Optional second argument if non-nil says to require a query.
+ Value is t if a query was formerly required."
+ (let ((old (process-query-on-exit-flag process)))
+ (set-process-query-on-exit-flag process nil)
+ old))
+
+ (defun process-kill-buffer-query-function ()
+ "Ask before killing a buffer that has a running process."
+ (let ((process (get-buffer-process (current-buffer))))
+ (or (not process)
+ (not (memq (process-status process) '(run stop open listen)))
+ (not (process-query-on-exit-flag process))
+ (yes-or-no-p
+ (format "Buffer %S has a running process; kill it? "
+ (buffer-name (current-buffer)))))))
+
+ (add-hook 'kill-buffer-query-functions 'process-kill-buffer-query-function)
+
+ ;; process plist management
+
+ (defun process-get (process propname)
+ "Return the value of PROCESS' PROPNAME property.
+ This is the last value stored with `(process-put PROCESS PROPNAME VALUE)'."
+ (plist-get (process-plist process) propname))
+
+ (defun process-put (process propname value)
+ "Change PROCESS' PROPNAME property to VALUE.
+ It can be retrieved with `(process-get PROCESS PROPNAME)'."
+ (set-process-plist process
+ (plist-put (process-plist process) propname value)))
+
+ \f
+ ;;;; Input and display facilities.
+
+ (defconst read-key-empty-map (make-sparse-keymap))
+
+ (defvar read-key-delay 0.01) ;Fast enough for 100Hz repeat rate, hopefully.
+
+ (defun read-key (&optional prompt)
+ "Read a key from the keyboard.
+ Contrary to `read-event' this will not return a raw event but instead will
+ obey the input decoding and translations usually done by `read-key-sequence'.
+ So escape sequences and keyboard encoding are taken into account.
+ When there's an ambiguity because the key looks like the prefix of
+ some sort of escape sequence, the ambiguity is resolved via `read-key-delay'."
+ ;; This overriding-terminal-local-map binding also happens to
+ ;; disable quail's input methods, so although read-key-sequence
+ ;; always inherits the input method, in practice read-key does not
+ ;; inherit the input method (at least not if it's based on quail).
+ (let ((overriding-terminal-local-map nil)
+ (overriding-local-map read-key-empty-map)
+ (echo-keystrokes 0)
+ (old-global-map (current-global-map))
+ (timer (run-with-idle-timer
+ ;; Wait long enough that Emacs has the time to receive and
+ ;; process all the raw events associated with the single-key.
+ ;; But don't wait too long, or the user may find the delay
+ ;; annoying (or keep hitting more keys which may then get
+ ;; lost or misinterpreted).
+ ;; This is only relevant for keys which Emacs perceives as
+ ;; "prefixes", such as C-x (because of the C-x 8 map in
+ ;; key-translate-table and the C-x @ map in function-key-map)
+ ;; or ESC (because of terminal escape sequences in
+ ;; input-decode-map).
+ read-key-delay t
+ (lambda ()
+ (let ((keys (this-command-keys-vector)))
+ (unless (zerop (length keys))
+ ;; `keys' is non-empty, so the user has hit at least
+ ;; one key; there's no point waiting any longer, even
+ ;; though read-key-sequence thinks we should wait
+ ;; for more input to decide how to interpret the
+ ;; current input.
+ (throw 'read-key keys)))))))
+ (unwind-protect
+ (progn
+ (use-global-map
+ (let ((map (make-sparse-keymap)))
+ ;; Don't hide the menu-bar and tool-bar entries.
+ (define-key map [menu-bar] (lookup-key global-map [menu-bar]))
+ (define-key map [tool-bar]
+ ;; This hack avoids evaluating the :filter (Bug#9922).
+ (or (cdr (assq 'tool-bar global-map))
+ (lookup-key global-map [tool-bar])))
+ map))
+ (aref (catch 'read-key (read-key-sequence-vector prompt nil t)) 0))
+ (cancel-timer timer)
+ (use-global-map old-global-map))))
+
+ (defvar read-passwd-map
+ ;; BEWARE: `defconst' would purecopy it, breaking the sharing with
+ ;; minibuffer-local-map along the way!
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map minibuffer-local-map)
+ (define-key map "\C-u" #'delete-minibuffer-contents) ;bug#12570
+ map)
+ "Keymap used while reading passwords.")
+
+ (defun read-passwd (prompt &optional confirm default)
+ "Read a password, prompting with PROMPT, and return it.
+ If optional CONFIRM is non-nil, read the password twice to make sure.
+ Optional DEFAULT is a default password to use instead of empty input.
+
+ This function echoes `.' for each character that the user types.
+ Note that in batch mode, the input is not hidden!
+
+ Once the caller uses the password, it can erase the password
+ by doing (clear-string STRING)."
+ (if confirm
+ (let (success)
+ (while (not success)
+ (let ((first (read-passwd prompt nil default))
+ (second (read-passwd "Confirm password: " nil default)))
+ (if (equal first second)
+ (progn
+ (and (arrayp second) (clear-string second))
+ (setq success first))
+ (and (arrayp first) (clear-string first))
+ (and (arrayp second) (clear-string second))
+ (message "Password not repeated accurately; please start over")
+ (sit-for 1))))
+ success)
+ (let ((hide-chars-fun
+ (lambda (beg end _len)
+ (clear-this-command-keys)
+ (setq beg (min end (max (minibuffer-prompt-end)
+ beg)))
+ (dotimes (i (- end beg))
+ (put-text-property (+ i beg) (+ 1 i beg)
+ 'display (string ?.)))))
+ minibuf)
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (setq minibuf (current-buffer))
+ ;; Turn off electricity.
+ (setq-local post-self-insert-hook nil)
+ (setq-local buffer-undo-list t)
+ (setq-local select-active-regions nil)
+ (use-local-map read-passwd-map)
+ (setq-local inhibit-modification-hooks nil) ;bug#15501.
+ (setq-local show-paren-mode nil) ;bug#16091.
+ (add-hook 'after-change-functions hide-chars-fun nil 'local))
+ (unwind-protect
+ (let ((enable-recursive-minibuffers t))
+ (read-string
+ (if noninteractive
+ (format "%s[INPUT WILL NOT BE HIDDEN!] " prompt) ; bug#17839
+ prompt)
+ nil t default)) ; t = "no history"
+ (when (buffer-live-p minibuf)
+ (with-current-buffer minibuf
+ ;; Not sure why but it seems that there might be cases where the
+ ;; minibuffer is not always properly reset later on, so undo
+ ;; whatever we've done here (bug#11392).
+ (remove-hook 'after-change-functions hide-chars-fun 'local)
+ (kill-local-variable 'post-self-insert-hook)
+ ;; And of course, don't keep the sensitive data around.
+ (erase-buffer))))))))
+
+ (defun read-number (prompt &optional default)
+ "Read a numeric value in the minibuffer, prompting with PROMPT.
+ DEFAULT specifies a default value to return if the user just types RET.
+ The value of DEFAULT is inserted into PROMPT.
+ This function is used by the `interactive' code letter `n'."
+ (let ((n nil)
+ (default1 (if (consp default) (car default) default)))
+ (when default1
+ (setq prompt
+ (if (string-match "\\(\\):[ \t]*\\'" prompt)
+ (replace-match (format " (default %s)" default1) t t prompt 1)
+ (replace-regexp-in-string "[ \t]*\\'"
+ (format " (default %s) " default1)
+ prompt t t))))
+ (while
+ (progn
+ (let ((str (read-from-minibuffer
+ prompt nil nil nil nil
+ (when default
+ (if (consp default)
+ (mapcar 'number-to-string (delq nil default))
+ (number-to-string default))))))
+ (condition-case nil
+ (setq n (cond
+ ((zerop (length str)) default1)
+ ((stringp str) (read str))))
+ (error nil)))
+ (unless (numberp n)
+ (message "Please enter a number.")
+ (sit-for 1)
+ t)))
+ n))
+
+ (defun read-char-choice (prompt chars &optional inhibit-keyboard-quit)
+ "Read and return one of CHARS, prompting for PROMPT.
+ Any input that is not one of CHARS is ignored.
+
+ If optional argument INHIBIT-KEYBOARD-QUIT is non-nil, ignore
+ keyboard-quit events while waiting for a valid input."
+ (unless (consp chars)
+ (error "Called `read-char-choice' without valid char choices"))
+ (let (char done show-help (helpbuf " *Char Help*"))
+ (let ((cursor-in-echo-area t)
+ (executing-kbd-macro executing-kbd-macro)
+ (esc-flag nil))
+ (save-window-excursion ; in case we call help-form-show
+ (while (not done)
+ (unless (get-text-property 0 'face prompt)
+ (setq prompt (propertize prompt 'face 'minibuffer-prompt)))
+ (setq char (let ((inhibit-quit inhibit-keyboard-quit))
+ (read-key prompt)))
+ (and show-help (buffer-live-p (get-buffer helpbuf))
+ (kill-buffer helpbuf))
+ (cond
+ ((not (numberp char)))
+ ;; If caller has set help-form, that's enough.
+ ;; They don't explicitly have to add help-char to chars.
+ ((and help-form
+ (eq char help-char)
+ (setq show-help t)
+ (help-form-show)))
+ ((memq char chars)
+ (setq done t))
+ ((and executing-kbd-macro (= char -1))
+ ;; read-event returns -1 if we are in a kbd macro and
+ ;; there are no more events in the macro. Attempt to
+ ;; get an event interactively.
+ (setq executing-kbd-macro nil))
+ ((not inhibit-keyboard-quit)
+ (cond
+ ((and (null esc-flag) (eq char ?\e))
+ (setq esc-flag t))
+ ((memq char '(?\C-g ?\e))
+ (keyboard-quit))))))))
+ ;; Display the question with the answer. But without cursor-in-echo-area.
+ (message "%s%s" prompt (char-to-string char))
+ char))
+
+ (defun sit-for (seconds &optional nodisp obsolete)
+ "Redisplay, then wait for SECONDS seconds. Stop when input is available.
+ SECONDS may be a floating-point value.
+ \(On operating systems that do not support waiting for fractions of a
+ second, floating-point values are rounded down to the nearest integer.)
+
+ If optional arg NODISP is t, don't redisplay, just wait for input.
+ Redisplay does not happen if input is available before it starts.
+
+ Value is t if waited the full time with no input arriving, and nil otherwise.
+
+ An obsolete, but still supported form is
+ \(sit-for SECONDS &optional MILLISECONDS NODISP)
+ where the optional arg MILLISECONDS specifies an additional wait period,
+ in milliseconds; this was useful when Emacs was built without
+ floating point support."
+ (declare (advertised-calling-convention (seconds &optional nodisp) "22.1"))
+ ;; This used to be implemented in C until the following discussion:
+ ;; http://lists.gnu.org/archive/html/emacs-devel/2006-07/msg00401.html
+ ;; Then it was moved here using an implementation based on an idle timer,
+ ;; which was then replaced by the use of read-event.
+ (if (numberp nodisp)
+ (setq seconds (+ seconds (* 1e-3 nodisp))
+ nodisp obsolete)
+ (if obsolete (setq nodisp obsolete)))
+ (cond
+ (noninteractive
+ (sleep-for seconds)
+ t)
+ ((input-pending-p t)
+ nil)
+ ((<= seconds 0)
+ (or nodisp (redisplay)))
+ (t
+ (or nodisp (redisplay))
+ ;; FIXME: we should not read-event here at all, because it's much too
+ ;; difficult to reliably "undo" a read-event by pushing it onto
+ ;; unread-command-events.
+ ;; For bug#14782, we need read-event to do the keyboard-coding-system
+ ;; decoding (hence non-nil as second arg under POSIX ttys).
+ ;; For bug#15614, we need read-event not to inherit-input-method.
+ ;; So we temporarily suspend input-method-function.
+ (let ((read (let ((input-method-function nil))
+ (read-event nil t seconds))))
+ (or (null read)
+ (progn
+ ;; If last command was a prefix arg, e.g. C-u, push this event onto
+ ;; unread-command-events as (t . EVENT) so it will be added to
+ ;; this-command-keys by read-key-sequence.
+ (if (eq overriding-terminal-local-map universal-argument-map)
+ (setq read (cons t read)))
+ (push read unread-command-events)
+ nil))))))
+
+ ;; Behind display-popup-menus-p test.
+ (declare-function x-popup-dialog "menu.c" (position contents &optional header))
+
+ (defun y-or-n-p (prompt)
+ "Ask user a \"y or n\" question. Return t if answer is \"y\".
+ PROMPT is the string to display to ask the question. It should
+ end in a space; `y-or-n-p' adds \"(y or n) \" to it.
+
+ No confirmation of the answer is requested; a single character is
+ enough. SPC also means yes, and DEL means no.
+
+ To be precise, this function translates user input into responses
+ by consulting the bindings in `query-replace-map'; see the
+ documentation of that variable for more information. In this
+ case, the useful bindings are `act', `skip', `recenter',
+ `scroll-up', `scroll-down', and `quit'.
+ An `act' response means yes, and a `skip' response means no.
+ A `quit' response means to invoke `keyboard-quit'.
+ If the user enters `recenter', `scroll-up', or `scroll-down'
+ responses, perform the requested window recentering or scrolling
+ and ask again.
+
+ Under a windowing system a dialog box will be used if `last-nonmenu-event'
+ is nil and `use-dialog-box' is non-nil."
+ ;; ¡Beware! when I tried to edebug this code, Emacs got into a weird state
+ ;; where all the keys were unbound (i.e. it somehow got triggered
+ ;; within read-key, apparently). I had to kill it.
+ (let ((answer 'recenter)
+ (padded (lambda (prompt &optional dialog)
+ (let ((l (length prompt)))
+ (concat prompt
+ (if (or (zerop l) (eq ?\s (aref prompt (1- l))))
+ "" " ")
+ (if dialog "" "(y or n) "))))))
+ (cond
+ (noninteractive
+ (setq prompt (funcall padded prompt))
+ (let ((temp-prompt prompt))
+ (while (not (memq answer '(act skip)))
+ (let ((str (read-string temp-prompt)))
+ (cond ((member str '("y" "Y")) (setq answer 'act))
+ ((member str '("n" "N")) (setq answer 'skip))
+ (t (setq temp-prompt (concat "Please answer y or n. "
+ prompt))))))))
+ ((and (display-popup-menus-p)
+ (listp last-nonmenu-event)
+ use-dialog-box)
+ (setq prompt (funcall padded prompt t)
+ answer (x-popup-dialog t `(,prompt ("Yes" . act) ("No" . skip)))))
+ (t
+ (setq prompt (funcall padded prompt))
+ (while
+ (let* ((scroll-actions '(recenter scroll-up scroll-down
+ scroll-other-window scroll-other-window-down))
+ (key
+ (let ((cursor-in-echo-area t))
+ (when minibuffer-auto-raise
+ (raise-frame (window-frame (minibuffer-window))))
+ (read-key (propertize (if (memq answer scroll-actions)
+ prompt
+ (concat "Please answer y or n. "
+ prompt))
+ 'face 'minibuffer-prompt)))))
+ (setq answer (lookup-key query-replace-map (vector key) t))
+ (cond
+ ((memq answer '(skip act)) nil)
+ ((eq answer 'recenter)
+ (recenter) t)
+ ((eq answer 'scroll-up)
+ (ignore-errors (scroll-up-command)) t)
+ ((eq answer 'scroll-down)
+ (ignore-errors (scroll-down-command)) t)
+ ((eq answer 'scroll-other-window)
+ (ignore-errors (scroll-other-window)) t)
+ ((eq answer 'scroll-other-window-down)
+ (ignore-errors (scroll-other-window-down)) t)
+ ((or (memq answer '(exit-prefix quit)) (eq key ?\e))
+ (signal 'quit nil) t)
+ (t t)))
+ (ding)
+ (discard-input))))
+ (let ((ret (eq answer 'act)))
+ (unless noninteractive
+ (message "%s%c" prompt (if ret ?y ?n)))
+ ret)))
+
+ \f
+ ;;; Atomic change groups.
+
+ (defmacro atomic-change-group (&rest body)
+ "Perform BODY as an atomic change group.
+ This means that if BODY exits abnormally,
+ all of its changes to the current buffer are undone.
+ This works regardless of whether undo is enabled in the buffer.
+
+ This mechanism is transparent to ordinary use of undo;
+ if undo is enabled in the buffer and BODY succeeds, the
+ user can undo the change normally."
+ (declare (indent 0) (debug t))
+ (let ((handle (make-symbol "--change-group-handle--"))
+ (success (make-symbol "--change-group-success--")))
+ `(let ((,handle (prepare-change-group))
+ ;; Don't truncate any undo data in the middle of this.
+ (undo-outer-limit nil)
+ (undo-limit most-positive-fixnum)
+ (undo-strong-limit most-positive-fixnum)
+ (,success nil))
+ (unwind-protect
+ (progn
+ ;; This is inside the unwind-protect because
+ ;; it enables undo if that was disabled; we need
+ ;; to make sure that it gets disabled again.
+ (activate-change-group ,handle)
+ ,@body
+ (setq ,success t))
+ ;; Either of these functions will disable undo
+ ;; if it was disabled before.
+ (if ,success
+ (accept-change-group ,handle)
+ (cancel-change-group ,handle))))))
+
+ (defun prepare-change-group (&optional buffer)
+ "Return a handle for the current buffer's state, for a change group.
+ If you specify BUFFER, make a handle for BUFFER's state instead.
+
+ Pass the handle to `activate-change-group' afterward to initiate
+ the actual changes of the change group.
+
+ To finish the change group, call either `accept-change-group' or
+ `cancel-change-group' passing the same handle as argument. Call
+ `accept-change-group' to accept the changes in the group as final;
+ call `cancel-change-group' to undo them all. You should use
+ `unwind-protect' to make sure the group is always finished. The call
+ to `activate-change-group' should be inside the `unwind-protect'.
+ Once you finish the group, don't use the handle again--don't try to
+ finish the same group twice. For a simple example of correct use, see
+ the source code of `atomic-change-group'.
+
+ The handle records only the specified buffer. To make a multibuffer
+ change group, call this function once for each buffer you want to
+ cover, then use `nconc' to combine the returned values, like this:
+
+ (nconc (prepare-change-group buffer-1)
+ (prepare-change-group buffer-2))
+
+ You can then activate that multibuffer change group with a single
+ call to `activate-change-group' and finish it with a single call
+ to `accept-change-group' or `cancel-change-group'."
+
+ (if buffer
+ (list (cons buffer (with-current-buffer buffer buffer-undo-list)))
+ (list (cons (current-buffer) buffer-undo-list))))
+
+ (defun activate-change-group (handle)
+ "Activate a change group made with `prepare-change-group' (which see)."
+ (dolist (elt handle)
+ (with-current-buffer (car elt)
+ (if (eq buffer-undo-list t)
+ (setq buffer-undo-list nil)))))
+
+ (defun accept-change-group (handle)
+ "Finish a change group made with `prepare-change-group' (which see).
+ This finishes the change group by accepting its changes as final."
+ (dolist (elt handle)
+ (with-current-buffer (car elt)
+ (if (eq (cdr elt) t)
+ (setq buffer-undo-list t)))))
+
+ (defun cancel-change-group (handle)
+ "Finish a change group made with `prepare-change-group' (which see).
+ This finishes the change group by reverting all of its changes."
+ (dolist (elt handle)
+ (with-current-buffer (car elt)
+ (setq elt (cdr elt))
+ (save-restriction
+ ;; Widen buffer temporarily so if the buffer was narrowed within
+ ;; the body of `atomic-change-group' all changes can be undone.
+ (widen)
+ (let ((old-car
+ (if (consp elt) (car elt)))
+ (old-cdr
+ (if (consp elt) (cdr elt))))
+ ;; Temporarily truncate the undo log at ELT.
+ (when (consp elt)
+ (setcar elt nil) (setcdr elt nil))
+ (unless (eq last-command 'undo) (undo-start))
+ ;; Make sure there's no confusion.
+ (when (and (consp elt) (not (eq elt (last pending-undo-list))))
+ (error "Undoing to some unrelated state"))
+ ;; Undo it all.
+ (save-excursion
+ (while (listp pending-undo-list) (undo-more 1)))
+ ;; Reset the modified cons cell ELT to its original content.
+ (when (consp elt)
+ (setcar elt old-car)
+ (setcdr elt old-cdr))
+ ;; Revert the undo info to what it was when we grabbed the state.
+ (setq buffer-undo-list elt))))))
+ \f
+ ;;;; Display-related functions.
+
+ ;; For compatibility.
+ (define-obsolete-function-alias 'redraw-modeline
+ 'force-mode-line-update "24.3")
+
+ (defun momentary-string-display (string pos &optional exit-char message)
+ "Momentarily display STRING in the buffer at POS.
+ Display remains until next event is input.
+ If POS is a marker, only its position is used; its buffer is ignored.
+ Optional third arg EXIT-CHAR can be a character, event or event
+ description list. EXIT-CHAR defaults to SPC. If the input is
+ EXIT-CHAR it is swallowed; otherwise it is then available as
+ input (as a command if nothing else).
+ Display MESSAGE (optional fourth arg) in the echo area.
+ If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
+ (or exit-char (setq exit-char ?\s))
+ (let ((ol (make-overlay pos pos))
+ (str (copy-sequence string)))
+ (unwind-protect
+ (progn
+ (save-excursion
+ (overlay-put ol 'after-string str)
+ (goto-char pos)
+ ;; To avoid trouble with out-of-bounds position
+ (setq pos (point))
+ ;; If the string end is off screen, recenter now.
+ (if (<= (window-end nil t) pos)
+ (recenter (/ (window-height) 2))))
+ (message (or message "Type %s to continue editing.")
+ (single-key-description exit-char))
+ (let ((event (read-key)))
+ ;; `exit-char' can be an event, or an event description list.
+ (or (eq event exit-char)
+ (eq event (event-convert-list exit-char))
+ (setq unread-command-events
+ (append (this-single-command-raw-keys))))))
+ (delete-overlay ol))))
+
+ \f
+ ;;;; Overlay operations
+
+ (defun copy-overlay (o)
+ "Return a copy of overlay O."
+ (let ((o1 (if (overlay-buffer o)
+ (make-overlay (overlay-start o) (overlay-end o)
+ ;; FIXME: there's no easy way to find the
+ ;; insertion-type of the two markers.
+ (overlay-buffer o))
+ (let ((o1 (make-overlay (point-min) (point-min))))
+ (delete-overlay o1)
+ o1)))
+ (props (overlay-properties o)))
+ (while props
+ (overlay-put o1 (pop props) (pop props)))
+ o1))
+
+ (defun remove-overlays (&optional beg end name val)
+ "Clear BEG and END of overlays whose property NAME has value VAL.
+ Overlays might be moved and/or split.
+ BEG and END default respectively to the beginning and end of buffer."
+ ;; This speeds up the loops over overlays.
+ (unless beg (setq beg (point-min)))
+ (unless end (setq end (point-max)))
+ (overlay-recenter end)
+ (if (< end beg)
+ (setq beg (prog1 end (setq end beg))))
+ (save-excursion
+ (dolist (o (overlays-in beg end))
+ (when (eq (overlay-get o name) val)
+ ;; Either push this overlay outside beg...end
+ ;; or split it to exclude beg...end
+ ;; or delete it entirely (if it is contained in beg...end).
+ (if (< (overlay-start o) beg)
+ (if (> (overlay-end o) end)
+ (progn
+ (move-overlay (copy-overlay o)
+ (overlay-start o) beg)
+ (move-overlay o end (overlay-end o)))
+ (move-overlay o (overlay-start o) beg))
+ (if (> (overlay-end o) end)
+ (move-overlay o end (overlay-end o))
+ (delete-overlay o)))))))
+ \f
+ ;;;; Miscellanea.
+
+ (defvar suspend-hook nil
+ "Normal hook run by `suspend-emacs', before suspending.")
+
+ (defvar suspend-resume-hook nil
+ "Normal hook run by `suspend-emacs', after Emacs is continued.")
+
+ (defvar temp-buffer-show-hook nil
+ "Normal hook run by `with-output-to-temp-buffer' after displaying the buffer.
+ When the hook runs, the temporary buffer is current, and the window it
+ was displayed in is selected.")
+
+ (defvar temp-buffer-setup-hook nil
+ "Normal hook run by `with-output-to-temp-buffer' at the start.
+ When the hook runs, the temporary buffer is current.
+ This hook is normally set up with a function to put the buffer in Help
+ mode.")
+
+ (defconst user-emacs-directory
+ (if (eq system-type 'ms-dos)
+ ;; MS-DOS cannot have initial dot.
+ "~/_emacs.d/"
+ "~/.emacs.d/")
+ "Directory beneath which additional per-user Emacs-specific files are placed.
+ Various programs in Emacs store information in this directory.
+ Note that this should end with a directory separator.
+ See also `locate-user-emacs-file'.")
+ \f
+ ;;;; Misc. useful functions.
+
+ (defsubst buffer-narrowed-p ()
+ "Return non-nil if the current buffer is narrowed."
+ (/= (- (point-max) (point-min)) (buffer-size)))
+
+ (defun find-tag-default-bounds ()
+ "Determine the boundaries of the default tag, based on text at point.
+ Return a cons cell with the beginning and end of the found tag.
+ If there is no plausible default, return nil."
+ (let (from to bound)
+ (when (or (progn
+ ;; Look at text around `point'.
+ (save-excursion
+ (skip-syntax-backward "w_") (setq from (point)))
+ (save-excursion
+ (skip-syntax-forward "w_") (setq to (point)))
+ (> to from))
+ ;; Look between `line-beginning-position' and `point'.
+ (save-excursion
+ (and (setq bound (line-beginning-position))
+ (skip-syntax-backward "^w_" bound)
+ (> (setq to (point)) bound)
+ (skip-syntax-backward "w_")
+ (setq from (point))))
+ ;; Look between `point' and `line-end-position'.
+ (save-excursion
+ (and (setq bound (line-end-position))
+ (skip-syntax-forward "^w_" bound)
+ (< (setq from (point)) bound)
+ (skip-syntax-forward "w_")
+ (setq to (point)))))
+ (cons from to))))
+
+ (defun find-tag-default ()
+ "Determine default tag to search for, based on text at point.
+ If there is no plausible default, return nil."
+ (let ((bounds (find-tag-default-bounds)))
+ (when bounds
+ (buffer-substring-no-properties (car bounds) (cdr bounds)))))
+
+ (defun find-tag-default-as-regexp ()
+ "Return regexp that matches the default tag at point.
+ If there is no tag at point, return nil.
+
+ When in a major mode that does not provide its own
+ `find-tag-default-function', return a regexp that matches the
+ symbol at point exactly."
+ (let ((tag (funcall (or find-tag-default-function
+ (get major-mode 'find-tag-default-function)
+ 'find-tag-default))))
+ (if tag (regexp-quote tag))))
+
+ (defun find-tag-default-as-symbol-regexp ()
+ "Return regexp that matches the default tag at point as symbol.
+ If there is no tag at point, return nil.
+
+ When in a major mode that does not provide its own
+ `find-tag-default-function', return a regexp that matches the
+ symbol at point exactly."
+ (let ((tag-regexp (find-tag-default-as-regexp)))
+ (if (and tag-regexp
+ (eq (or find-tag-default-function
+ (get major-mode 'find-tag-default-function)
+ 'find-tag-default)
+ 'find-tag-default))
+ (format "\\_<%s\\_>" tag-regexp)
+ tag-regexp)))
+
+ (defun play-sound (sound)
+ "SOUND is a list of the form `(sound KEYWORD VALUE...)'.
+ The following keywords are recognized:
+
+ :file FILE - read sound data from FILE. If FILE isn't an
+ absolute file name, it is searched in `data-directory'.
+
+ :data DATA - read sound data from string DATA.
+
+ Exactly one of :file or :data must be present.
+
+ :volume VOL - set volume to VOL. VOL must an integer in the
+ range 0..100 or a float in the range 0..1.0. If not specified,
+ don't change the volume setting of the sound device.
+
+ :device DEVICE - play sound on DEVICE. If not specified,
+ a system-dependent default device name is used.
+
+ Note: :data and :device are currently not supported on Windows."
+ (if (fboundp 'play-sound-internal)
+ (play-sound-internal sound)
+ (error "This Emacs binary lacks sound support")))
+
+ (declare-function w32-shell-dos-semantics "w32-fns" nil)
+
+ (defun shell-quote-argument (argument)
+ "Quote ARGUMENT for passing as argument to an inferior shell."
+ (cond
+ ((eq system-type 'ms-dos)
+ ;; Quote using double quotes, but escape any existing quotes in
+ ;; the argument with backslashes.
+ (let ((result "")
+ (start 0)
+ end)
+ (if (or (null (string-match "[^\"]" argument))
+ (< (match-end 0) (length argument)))
+ (while (string-match "[\"]" argument start)
+ (setq end (match-beginning 0)
+ result (concat result (substring argument start end)
+ "\\" (substring argument end (1+ end)))
+ start (1+ end))))
+ (concat "\"" result (substring argument start) "\"")))
+
+ ((and (eq system-type 'windows-nt) (w32-shell-dos-semantics))
+
+ ;; First, quote argument so that CommandLineToArgvW will
+ ;; understand it. See
+ ;; http://msdn.microsoft.com/en-us/library/17w5ykft%28v=vs.85%29.aspx
+ ;; After we perform that level of quoting, escape shell
+ ;; metacharacters so that cmd won't mangle our argument. If the
+ ;; argument contains no double quote characters, we can just
+ ;; surround it with double quotes. Otherwise, we need to prefix
+ ;; each shell metacharacter with a caret.
+
+ (setq argument
+ ;; escape backslashes at end of string
+ (replace-regexp-in-string
+ "\\(\\\\*\\)$"
+ "\\1\\1"
+ ;; escape backslashes and quotes in string body
+ (replace-regexp-in-string
+ "\\(\\\\*\\)\""
+ "\\1\\1\\\\\""
+ argument)))
+
+ (if (string-match "[%!\"]" argument)
+ (concat
+ "^\""
+ (replace-regexp-in-string
+ "\\([%!()\"<>&|^]\\)"
+ "^\\1"
+ argument)
+ "^\"")
+ (concat "\"" argument "\"")))
+
+ (t
+ (if (equal argument "")
+ "''"
+ ;; Quote everything except POSIX filename characters.
+ ;; This should be safe enough even for really weird shells.
+ (replace-regexp-in-string
+ "\n" "'\n'"
+ (replace-regexp-in-string "[^-0-9a-zA-Z_./\n]" "\\\\\\&" argument))))
+ ))
+
+ (defun string-or-null-p (object)
+ "Return t if OBJECT is a string or nil.
+ Otherwise, return nil."
+ (or (stringp object) (null object)))
+
+ (defun booleanp (object)
+ "Return t if OBJECT is one of the two canonical boolean values: t or nil.
+ Otherwise, return nil."
+ (and (memq object '(nil t)) t))
+
+ (defun special-form-p (object)
+ "Non-nil if and only if OBJECT is a special form."
+ (if (and (symbolp object) (fboundp object))
+ (setq object (indirect-function object t)))
+ (and (subrp object) (eq (cdr (subr-arity object)) 'unevalled)))
+
+ (defun macrop (object)
+ "Non-nil if and only if OBJECT is a macro."
+ (let ((def (indirect-function object t)))
+ (when (consp def)
+ (or (eq 'macro (car def))
+ (and (autoloadp def) (memq (nth 4 def) '(macro t)))))))
+
+ (defun field-at-pos (pos)
+ "Return the field at position POS, taking stickiness etc into account."
+ (let ((raw-field (get-char-property (field-beginning pos) 'field)))
+ (if (eq raw-field 'boundary)
+ (get-char-property (1- (field-end pos)) 'field)
+ raw-field)))
+
+ (defun sha1 (object &optional start end binary)
+ "Return the SHA1 (Secure Hash Algorithm) of an OBJECT.
+ OBJECT is either a string or a buffer. Optional arguments START and
+ END are character positions specifying which portion of OBJECT for
+ computing the hash. If BINARY is non-nil, return a string in binary
+ form."
+ (secure-hash 'sha1 object start end binary))
+
+ (defalias 'function-put #'put
+ ;; This is only really used in Emacs>24.4, but we add it to 24.4 already, so
+ ;; as to ease the pain when people use future autoload files that contain
+ ;; function-put.
+ "Set function F's property PROP to VALUE.
+ The namespace for PROP is shared with symbols.
+ So far, F can only be a symbol, not a lambda expression.")
+
+ (defun function-get (f prop &optional autoload)
+ "Return the value of property PROP of function F.
+ If AUTOLOAD is non-nil and F is autoloaded, try to autoload it
+ in the hope that it will set PROP. If AUTOLOAD is `macro', only do it
+ if it's an autoloaded macro."
+ (let ((val nil))
+ (while (and (symbolp f)
+ (null (setq val (get f prop)))
+ (fboundp f))
+ (let ((fundef (symbol-function f)))
+ (if (and autoload (autoloadp fundef)
+ (not (equal fundef
+ (autoload-do-load fundef f
+ (if (eq autoload 'macro)
+ 'macro)))))
+ nil ;Re-try `get' on the same `f'.
+ (setq f fundef))))
+ val))
+ \f
+ ;;;; Support for yanking and text properties.
+ ;; Why here in subr.el rather than in simple.el? --Stef
+
+ (defvar yank-handled-properties)
+ (defvar yank-excluded-properties)
+
+ (defun remove-yank-excluded-properties (start end)
+ "Process text properties between START and END, inserted for a `yank'.
+ Perform the handling specified by `yank-handled-properties', then
+ remove properties specified by `yank-excluded-properties'."
+ (let ((inhibit-read-only t))
+ (dolist (handler yank-handled-properties)
+ (let ((prop (car handler))
+ (fun (cdr handler))
+ (run-start start))
+ (while (< run-start end)
+ (let ((value (get-text-property run-start prop))
+ (run-end (next-single-property-change
+ run-start prop nil end)))
+ (funcall fun value run-start run-end)
+ (setq run-start run-end)))))
+ (if (eq yank-excluded-properties t)
+ (set-text-properties start end nil)
+ (remove-list-of-text-properties start end yank-excluded-properties))))
+
+ (defvar yank-undo-function)
+
+ (defun insert-for-yank (string)
+ "Call `insert-for-yank-1' repetitively for each `yank-handler' segment.
+
+ See `insert-for-yank-1' for more details."
+ (let (to)
+ (while (setq to (next-single-property-change 0 'yank-handler string))
+ (insert-for-yank-1 (substring string 0 to))
+ (setq string (substring string to))))
+ (insert-for-yank-1 string))
+
+ (defun insert-for-yank-1 (string)
+ "Insert STRING at point for the `yank' command.
+ This function is like `insert', except it honors the variables
+ `yank-handled-properties' and `yank-excluded-properties', and the
+ `yank-handler' text property.
+
+ Properties listed in `yank-handled-properties' are processed,
+ then those listed in `yank-excluded-properties' are discarded.
+
+ If STRING has a non-nil `yank-handler' property on its first
+ character, the normal insert behavior is altered. The value of
+ the `yank-handler' property must be a list of one to four
+ elements, of the form (FUNCTION PARAM NOEXCLUDE UNDO).
+ FUNCTION, if non-nil, should be a function of one argument, an
+ object to insert; it is called instead of `insert'.
+ PARAM, if present and non-nil, replaces STRING as the argument to
+ FUNCTION or `insert'; e.g. if FUNCTION is `yank-rectangle', PARAM
+ may be a list of strings to insert as a rectangle.
+ If NOEXCLUDE is present and non-nil, the normal removal of
+ `yank-excluded-properties' is not performed; instead FUNCTION is
+ responsible for the removal. This may be necessary if FUNCTION
+ adjusts point before or after inserting the object.
+ UNDO, if present and non-nil, should be a function to be called
+ by `yank-pop' to undo the insertion of the current object. It is
+ given two arguments, the start and end of the region. FUNCTION
+ may set `yank-undo-function' to override UNDO."
+ (let* ((handler (and (stringp string)
+ (get-text-property 0 'yank-handler string)))
+ (param (or (nth 1 handler) string))
+ (opoint (point))
+ (inhibit-read-only inhibit-read-only)
+ end)
+
+ (setq yank-undo-function t)
+ (if (nth 0 handler) ; FUNCTION
+ (funcall (car handler) param)
+ (insert param))
+ (setq end (point))
+
+ ;; Prevent read-only properties from interfering with the
+ ;; following text property changes.
+ (setq inhibit-read-only t)
+
+ (unless (nth 2 handler) ; NOEXCLUDE
+ (remove-yank-excluded-properties opoint end))
+
+ ;; If last inserted char has properties, mark them as rear-nonsticky.
+ (if (and (> end opoint)
+ (text-properties-at (1- end)))
+ (put-text-property (1- end) end 'rear-nonsticky t))
+
+ (if (eq yank-undo-function t) ; not set by FUNCTION
+ (setq yank-undo-function (nth 3 handler))) ; UNDO
+ (if (nth 4 handler) ; COMMAND
+ (setq this-command (nth 4 handler)))))
+
+ (defun insert-buffer-substring-no-properties (buffer &optional start end)
+ "Insert before point a substring of BUFFER, without text properties.
+ BUFFER may be a buffer or a buffer name.
+ Arguments START and END are character positions specifying the substring.
+ They default to the values of (point-min) and (point-max) in BUFFER."
+ (let ((opoint (point)))
+ (insert-buffer-substring buffer start end)
+ (let ((inhibit-read-only t))
+ (set-text-properties opoint (point) nil))))
+
+ (defun insert-buffer-substring-as-yank (buffer &optional start end)
+ "Insert before point a part of BUFFER, stripping some text properties.
+ BUFFER may be a buffer or a buffer name.
+ Arguments START and END are character positions specifying the substring.
+ They default to the values of (point-min) and (point-max) in BUFFER.
+ Before insertion, process text properties according to
+ `yank-handled-properties' and `yank-excluded-properties'."
+ ;; Since the buffer text should not normally have yank-handler properties,
+ ;; there is no need to handle them here.
+ (let ((opoint (point)))
+ (insert-buffer-substring buffer start end)
+ (remove-yank-excluded-properties opoint (point))))
+
+ (defun yank-handle-font-lock-face-property (face start end)
+ "If `font-lock-defaults' is nil, apply FACE as a `face' property.
+ START and END denote the start and end of the text to act on.
+ Do nothing if FACE is nil."
+ (and face
+ (null font-lock-defaults)
+ (put-text-property start end 'face face)))
+
+ ;; This removes `mouse-face' properties in *Help* buffer buttons:
+ ;; http://lists.gnu.org/archive/html/emacs-devel/2002-04/msg00648.html
+ (defun yank-handle-category-property (category start end)
+ "Apply property category CATEGORY's properties between START and END."
+ (when category
+ (let ((start2 start))
+ (while (< start2 end)
+ (let ((end2 (next-property-change start2 nil end))
+ (original (text-properties-at start2)))
+ (set-text-properties start2 end2 (symbol-plist category))
+ (add-text-properties start2 end2 original)
+ (setq start2 end2))))))
+
+ \f
+ ;;;; Synchronous shell commands.
+
+ (defun start-process-shell-command (name buffer &rest args)
+ "Start a program in a subprocess. Return the process object for it.
+ NAME is name for process. It is modified if necessary to make it unique.
+ BUFFER is the buffer (or buffer name) to associate with the process.
+ Process output goes at end of that buffer, unless you specify
+ an output stream or filter function to handle the output.
+ BUFFER may be also nil, meaning that this process is not associated
+ with any buffer
+ COMMAND is the shell command to run.
+
+ An old calling convention accepted any number of arguments after COMMAND,
+ which were just concatenated to COMMAND. This is still supported but strongly
+ discouraged."
+ (declare (advertised-calling-convention (name buffer command) "23.1"))
+ ;; We used to use `exec' to replace the shell with the command,
+ ;; but that failed to handle (...) and semicolon, etc.
+ (start-process name buffer shell-file-name shell-command-switch
+ (mapconcat 'identity args " ")))
+
+ (defun start-file-process-shell-command (name buffer &rest args)
+ "Start a program in a subprocess. Return the process object for it.
+ Similar to `start-process-shell-command', but calls `start-file-process'."
+ (declare (advertised-calling-convention (name buffer command) "23.1"))
+ (start-file-process
+ name buffer
+ (if (file-remote-p default-directory) "/bin/sh" shell-file-name)
+ (if (file-remote-p default-directory) "-c" shell-command-switch)
+ (mapconcat 'identity args " ")))
+
+ (defun call-process-shell-command (command &optional infile buffer display
+ &rest args)
+ "Execute the shell command COMMAND synchronously in separate process.
+ The remaining arguments are optional.
+ The program's input comes from file INFILE (nil means `/dev/null').
+ Insert output in BUFFER before point; t means current buffer;
+ nil for BUFFER means discard it; 0 means discard and don't wait.
+ BUFFER can also have the form (REAL-BUFFER STDERR-FILE); in that case,
+ REAL-BUFFER says what to do with standard output, as above,
+ while STDERR-FILE says what to do with standard error in the child.
+ STDERR-FILE may be nil (discard standard error output),
+ t (mix it with ordinary output), or a file name string.
+
+ Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.
+ Wildcards and redirection are handled as usual in the shell.
+
+ If BUFFER is 0, `call-process-shell-command' returns immediately with value nil.
+ Otherwise it waits for COMMAND to terminate and returns a numeric exit
+ status or a signal description string.
+ If you quit, the process is killed with SIGINT, or SIGKILL if you quit again.
+
+ An old calling convention accepted any number of arguments after DISPLAY,
+ which were just concatenated to COMMAND. This is still supported but strongly
+ discouraged."
+ (declare (advertised-calling-convention
+ (command &optional infile buffer display) "24.5"))
+ ;; We used to use `exec' to replace the shell with the command,
+ ;; but that failed to handle (...) and semicolon, etc.
+ (call-process shell-file-name
+ infile buffer display
+ shell-command-switch
+ (mapconcat 'identity (cons command args) " ")))
+
+ (defun process-file-shell-command (command &optional infile buffer display
+ &rest args)
+ "Process files synchronously in a separate process.
+ Similar to `call-process-shell-command', but calls `process-file'."
+ (declare (advertised-calling-convention
+ (command &optional infile buffer display) "24.5"))
+ (process-file
+ (if (file-remote-p default-directory) "/bin/sh" shell-file-name)
+ infile buffer display
+ (if (file-remote-p default-directory) "-c" shell-command-switch)
+ (mapconcat 'identity (cons command args) " ")))
+ \f
+ ;;;; Lisp macros to do various things temporarily.
+
+ (defmacro with-current-buffer (buffer-or-name &rest body)
+ "Execute the forms in BODY with BUFFER-OR-NAME temporarily current.
+ BUFFER-OR-NAME must be a buffer or the name of an existing buffer.
+ The value returned is the value of the last form in BODY. See
+ also `with-temp-buffer'."
+ (declare (indent 1) (debug t))
+ `(save-current-buffer
+ (set-buffer ,buffer-or-name)
+ ,@body))
+
+ (defun internal--before-with-selected-window (window)
+ (let ((other-frame (window-frame window)))
+ (list window (selected-window)
+ ;; Selecting a window on another frame also changes that
+ ;; frame's frame-selected-window. We must save&restore it.
+ (unless (eq (selected-frame) other-frame)
+ (frame-selected-window other-frame))
+ ;; Also remember the top-frame if on ttys.
+ (unless (eq (selected-frame) other-frame)
+ (tty-top-frame other-frame)))))
+
+ (defun internal--after-with-selected-window (state)
+ ;; First reset frame-selected-window.
+ (when (window-live-p (nth 2 state))
+ ;; We don't use set-frame-selected-window because it does not
+ ;; pass the `norecord' argument to Fselect_window.
+ (select-window (nth 2 state) 'norecord)
+ (and (frame-live-p (nth 3 state))
+ (not (eq (tty-top-frame) (nth 3 state)))
+ (select-frame (nth 3 state) 'norecord)))
+ ;; Then reset the actual selected-window.
+ (when (window-live-p (nth 1 state))
+ (select-window (nth 1 state) 'norecord)))
+
+ (defmacro with-selected-window (window &rest body)
+ "Execute the forms in BODY with WINDOW as the selected window.
+ The value returned is the value of the last form in BODY.
+
+ This macro saves and restores the selected window, as well as the
+ selected window of each frame. It does not change the order of
+ recently selected windows. If the previously selected window of
+ some frame is no longer live at the end of BODY, that frame's
+ selected window is left alone. If the selected window is no
+ longer live, then whatever window is selected at the end of BODY
+ remains selected.
+
+ This macro uses `save-current-buffer' to save and restore the
+ current buffer, since otherwise its normal operation could
+ potentially make a different buffer current. It does not alter
+ the buffer list ordering."
+ (declare (indent 1) (debug t))
+ `(let ((save-selected-window--state
+ (internal--before-with-selected-window ,window)))
+ (save-current-buffer
+ (unwind-protect
+ (progn (select-window (car save-selected-window--state) 'norecord)
+ ,@body)
+ (internal--after-with-selected-window save-selected-window--state)))))
+
+ (defmacro with-selected-frame (frame &rest body)
+ "Execute the forms in BODY with FRAME as the selected frame.
+ The value returned is the value of the last form in BODY.
+
+ This macro saves and restores the selected frame, and changes the
+ order of neither the recently selected windows nor the buffers in
+ the buffer list."
+ (declare (indent 1) (debug t))
+ (let ((old-frame (make-symbol "old-frame"))
+ (old-buffer (make-symbol "old-buffer")))
+ `(let ((,old-frame (selected-frame))
+ (,old-buffer (current-buffer)))
+ (unwind-protect
+ (progn (select-frame ,frame 'norecord)
+ ,@body)
+ (when (frame-live-p ,old-frame)
+ (select-frame ,old-frame 'norecord))
+ (when (buffer-live-p ,old-buffer)
+ (set-buffer ,old-buffer))))))
+
+ (defmacro save-window-excursion (&rest body)
+ "Execute BODY, then restore previous window configuration.
+ This macro saves the window configuration on the selected frame,
+ executes BODY, then calls `set-window-configuration' to restore
+ the saved window configuration. The return value is the last
+ form in BODY. The window configuration is also restored if BODY
+ exits nonlocally.
+
+ BEWARE: Most uses of this macro introduce bugs.
+ E.g. it should not be used to try and prevent some code from opening
+ a new window, since that window may sometimes appear in another frame,
+ in which case `save-window-excursion' cannot help."
+ (declare (indent 0) (debug t))
+ (let ((c (make-symbol "wconfig")))
+ `(let ((,c (current-window-configuration)))
+ (unwind-protect (progn ,@body)
+ (set-window-configuration ,c)))))
+
+ (defun internal-temp-output-buffer-show (buffer)
+ "Internal function for `with-output-to-temp-buffer'."
+ (with-current-buffer buffer
+ (set-buffer-modified-p nil)
+ (goto-char (point-min)))
+
+ (if temp-buffer-show-function
+ (funcall temp-buffer-show-function buffer)
+ (with-current-buffer buffer
+ (let* ((window
+ (let ((window-combination-limit
+ ;; When `window-combination-limit' equals
+ ;; `temp-buffer' or `temp-buffer-resize' and
+ ;; `temp-buffer-resize-mode' is enabled in this
+ ;; buffer bind it to t so resizing steals space
+ ;; preferably from the window that was split.
+ (if (or (eq window-combination-limit 'temp-buffer)
+ (and (eq window-combination-limit
+ 'temp-buffer-resize)
+ temp-buffer-resize-mode))
+ t
+ window-combination-limit)))
+ (display-buffer buffer)))
+ (frame (and window (window-frame window))))
+ (when window
+ (unless (eq frame (selected-frame))
+ (make-frame-visible frame))
+ (setq minibuffer-scroll-window window)
+ (set-window-hscroll window 0)
+ ;; Don't try this with NOFORCE non-nil!
+ (set-window-start window (point-min) t)
+ ;; This should not be necessary.
+ (set-window-point window (point-min))
+ ;; Run `temp-buffer-show-hook', with the chosen window selected.
+ (with-selected-window window
+ (run-hooks 'temp-buffer-show-hook))))))
+ ;; Return nil.
+ nil)
+
+ ;; Doc is very similar to with-temp-buffer-window.
+ (defmacro with-output-to-temp-buffer (bufname &rest body)
+ "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
+
+ This construct makes buffer BUFNAME empty before running BODY.
+ It does not make the buffer current for BODY.
+ Instead it binds `standard-output' to that buffer, so that output
+ generated with `prin1' and similar functions in BODY goes into
+ the buffer.
+
+ At the end of BODY, this marks buffer BUFNAME unmodified and displays
+ it in a window, but does not select it. The normal way to do this is
+ by calling `display-buffer', then running `temp-buffer-show-hook'.
+ However, if `temp-buffer-show-function' is non-nil, it calls that
+ function instead (and does not run `temp-buffer-show-hook'). The
+ function gets one argument, the buffer to display.
+
+ The return value of `with-output-to-temp-buffer' is the value of the
+ last form in BODY. If BODY does not finish normally, the buffer
+ BUFNAME is not displayed.
+
+ This runs the hook `temp-buffer-setup-hook' before BODY,
+ with the buffer BUFNAME temporarily current. It runs the hook
+ `temp-buffer-show-hook' after displaying buffer BUFNAME, with that
+ buffer temporarily current, and the window that was used to display it
+ temporarily selected. But it doesn't run `temp-buffer-show-hook'
+ if it uses `temp-buffer-show-function'.
+
+ By default, the setup hook puts the buffer into Help mode before running BODY.
+ If BODY does not change the major mode, the show hook makes the buffer
+ read-only, and scans it for function and variable names to make them into
+ clickable cross-references.
+
+ See the related form `with-temp-buffer-window'."
+ (declare (debug t))
+ (let ((old-dir (make-symbol "old-dir"))
+ (buf (make-symbol "buf")))
+ `(let* ((,old-dir default-directory)
+ (,buf
+ (with-current-buffer (get-buffer-create ,bufname)
+ (prog1 (current-buffer)
+ (kill-all-local-variables)
+ ;; FIXME: delete_all_overlays
+ (setq default-directory ,old-dir)
+ (setq buffer-read-only nil)
+ (setq buffer-file-name nil)
+ (setq buffer-undo-list t)
+ (let ((inhibit-read-only t)
+ (inhibit-modification-hooks t))
+ (erase-buffer)
+ (run-hooks 'temp-buffer-setup-hook)))))
+ (standard-output ,buf))
+ (prog1 (progn ,@body)
+ (internal-temp-output-buffer-show ,buf)))))
+
+ (defmacro with-temp-file (file &rest body)
+ "Create a new buffer, evaluate BODY there, and write the buffer to FILE.
+ The value returned is the value of the last form in BODY.
+ See also `with-temp-buffer'."
+ (declare (indent 1) (debug t))
+ (let ((temp-file (make-symbol "temp-file"))
+ (temp-buffer (make-symbol "temp-buffer")))
+ `(let ((,temp-file ,file)
+ (,temp-buffer
+ (get-buffer-create (generate-new-buffer-name " *temp file*"))))
+ (unwind-protect
+ (prog1
+ (with-current-buffer ,temp-buffer
+ ,@body)
+ (with-current-buffer ,temp-buffer
+ (write-region nil nil ,temp-file nil 0)))
+ (and (buffer-name ,temp-buffer)
+ (kill-buffer ,temp-buffer))))))
+
+ (defmacro with-temp-message (message &rest body)
+ "Display MESSAGE temporarily if non-nil while BODY is evaluated.
+ The original message is restored to the echo area after BODY has finished.
+ The value returned is the value of the last form in BODY.
+ MESSAGE is written to the message log buffer if `message-log-max' is non-nil.
+ If MESSAGE is nil, the echo area and message log buffer are unchanged.
+ Use a MESSAGE of \"\" to temporarily clear the echo area."
+ (declare (debug t) (indent 1))
+ (let ((current-message (make-symbol "current-message"))
+ (temp-message (make-symbol "with-temp-message")))
+ `(let ((,temp-message ,message)
+ (,current-message))
+ (unwind-protect
+ (progn
+ (when ,temp-message
+ (setq ,current-message (current-message))
+ (message "%s" ,temp-message))
+ ,@body)
+ (and ,temp-message
+ (if ,current-message
+ (message "%s" ,current-message)
+ (message nil)))))))
+
+ (defmacro with-temp-buffer (&rest body)
+ "Create a temporary buffer, and evaluate BODY there like `progn'.
+ See also `with-temp-file' and `with-output-to-string'."
+ (declare (indent 0) (debug t))
+ (let ((temp-buffer (make-symbol "temp-buffer")))
+ `(let ((,temp-buffer (generate-new-buffer " *temp*")))
+ ;; FIXME: kill-buffer can change current-buffer in some odd cases.
+ (with-current-buffer ,temp-buffer
+ (unwind-protect
+ (progn ,@body)
+ (and (buffer-name ,temp-buffer)
+ (kill-buffer ,temp-buffer)))))))
+
+ (defmacro with-silent-modifications (&rest body)
+ "Execute BODY, pretending it does not modify the buffer.
+ If BODY performs real modifications to the buffer's text, other
+ than cosmetic ones, undo data may become corrupted.
+
+ This macro will run BODY normally, but doesn't count its buffer
+ modifications as being buffer modifications. This affects things
+ like `buffer-modified-p', checking whether the file is locked by
+ someone else, running buffer modification hooks, and other things
+ of that nature.
+
+ Typically used around modifications of text-properties which do
+ not really affect the buffer's content."
+ (declare (debug t) (indent 0))
+ (let ((modified (make-symbol "modified")))
+ `(let* ((,modified (buffer-modified-p))
+ (buffer-undo-list t)
+ (inhibit-read-only t)
+ (inhibit-modification-hooks t)
+ deactivate-mark
+ ;; Avoid setting and removing file locks and checking
+ ;; buffer's uptodate-ness w.r.t the underlying file.
+ buffer-file-name
+ buffer-file-truename)
+ (unwind-protect
+ (progn
+ ,@body)
+ (unless ,modified
+ (restore-buffer-modified-p nil))))))
+
+ (defmacro with-output-to-string (&rest body)
+ "Execute BODY, return the text it sent to `standard-output', as a string."
+ (declare (indent 0) (debug t))
+ `(let ((standard-output
+ (get-buffer-create (generate-new-buffer-name " *string-output*"))))
+ (unwind-protect
+ (progn
+ (let ((standard-output standard-output))
+ ,@body)
+ (with-current-buffer standard-output
+ (buffer-string)))
+ (kill-buffer standard-output))))
+
+ (defmacro with-local-quit (&rest body)
+ "Execute BODY, allowing quits to terminate BODY but not escape further.
+ When a quit terminates BODY, `with-local-quit' returns nil but
+ requests another quit. That quit will be processed as soon as quitting
+ is allowed once again. (Immediately, if `inhibit-quit' is nil.)"
+ (declare (debug t) (indent 0))
+ `(condition-case nil
+ (let ((inhibit-quit nil))
+ ,@body)
+ (quit (setq quit-flag t)
+ ;; This call is to give a chance to handle quit-flag
+ ;; in case inhibit-quit is nil.
+ ;; Without this, it will not be handled until the next function
+ ;; call, and that might allow it to exit thru a condition-case
+ ;; that intends to handle the quit signal next time.
+ (eval '(ignore nil)))))
+
+ (defmacro while-no-input (&rest body)
+ "Execute BODY only as long as there's no pending input.
+ If input arrives, that ends the execution of BODY,
+ and `while-no-input' returns t. Quitting makes it return nil.
+ If BODY finishes, `while-no-input' returns whatever value BODY produced."
+ (declare (debug t) (indent 0))
+ (let ((catch-sym (make-symbol "input")))
+ `(with-local-quit
+ (catch ',catch-sym
+ (let ((throw-on-input ',catch-sym))
+ (or (input-pending-p)
+ (progn ,@body)))))))
+
+ (defmacro condition-case-unless-debug (var bodyform &rest handlers)
+ "Like `condition-case' except that it does not prevent debugging.
+ More specifically if `debug-on-error' is set then the debugger will be invoked
+ even if this catches the signal."
+ (declare (debug condition-case) (indent 2))
+ `(condition-case ,var
+ ,bodyform
+ ,@(mapcar (lambda (handler)
+ `((debug ,@(if (listp (car handler)) (car handler)
+ (list (car handler))))
+ ,@(cdr handler)))
+ handlers)))
+
+ (define-obsolete-function-alias 'condition-case-no-debug
+ 'condition-case-unless-debug "24.1")
+
+ (defmacro with-demoted-errors (format &rest body)
+ "Run BODY and demote any errors to simple messages.
+ FORMAT is a string passed to `message' to format any error message.
+ It should contain a single %-sequence; e.g., \"Error: %S\".
+
+ If `debug-on-error' is non-nil, run BODY without catching its errors.
+ This is to be used around code which is not expected to signal an error
+ but which should be robust in the unexpected case that an error is signaled.
+
+ For backward compatibility, if FORMAT is not a constant string, it
+ is assumed to be part of BODY, in which case the message format
+ used is \"Error: %S\"."
+ (declare (debug t) (indent 1))
+ (let ((err (make-symbol "err"))
+ (format (if (and (stringp format) body) format
+ (prog1 "Error: %S"
+ (if format (push format body))))))
+ `(condition-case-unless-debug ,err
+ ,(macroexp-progn body)
+ (error (message ,format ,err) nil))))
+
+ (defmacro combine-after-change-calls (&rest body)
+ "Execute BODY, but don't call the after-change functions till the end.
+ If BODY makes changes in the buffer, they are recorded
+ and the functions on `after-change-functions' are called several times
+ when BODY is finished.
+ The return value is the value of the last form in BODY.
+
+ If `before-change-functions' is non-nil, then calls to the after-change
+ functions can't be deferred, so in that case this macro has no effect.
+
+ Do not alter `after-change-functions' or `before-change-functions'
+ in BODY."
+ (declare (indent 0) (debug t))
+ `(unwind-protect
+ (let ((combine-after-change-calls t))
+ . ,body)
+ (combine-after-change-execute)))
+
+ (defmacro with-case-table (table &rest body)
+ "Execute the forms in BODY with TABLE as the current case table.
+ The value returned is the value of the last form in BODY."
+ (declare (indent 1) (debug t))
+ (let ((old-case-table (make-symbol "table"))
+ (old-buffer (make-symbol "buffer")))
+ `(let ((,old-case-table (current-case-table))
+ (,old-buffer (current-buffer)))
+ (unwind-protect
+ (progn (set-case-table ,table)
+ ,@body)
+ (with-current-buffer ,old-buffer
+ (set-case-table ,old-case-table))))))
+ \f
+ ;;; Matching and match data.
+
+ (defvar save-match-data-internal)
+
+ ;; We use save-match-data-internal as the local variable because
+ ;; that works ok in practice (people should not use that variable elsewhere).
+ ;; We used to use an uninterned symbol; the compiler handles that properly
+ ;; now, but it generates slower code.
+ (defmacro save-match-data (&rest body)
+ "Execute the BODY forms, restoring the global value of the match data.
+ The value returned is the value of the last form in BODY."
+ ;; It is better not to use backquote here,
+ ;; because that makes a bootstrapping problem
+ ;; if you need to recompile all the Lisp files using interpreted code.
+ (declare (indent 0) (debug t))
+ (list 'let
+ '((save-match-data-internal (match-data)))
+ (list 'unwind-protect
+ (cons 'progn body)
+ ;; It is safe to free (evaporate) markers immediately here,
+ ;; as Lisp programs should not copy from save-match-data-internal.
+ '(set-match-data save-match-data-internal 'evaporate))))
+
+ (defun match-string (num &optional string)
+ "Return string of text matched by last search.
+ NUM specifies which parenthesized expression in the last regexp.
+ Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
+ Zero means the entire text matched by the whole regexp or whole string.
+ STRING should be given if the last search was by `string-match' on STRING.
+ If STRING is nil, the current buffer should be the same buffer
+ the search/match was performed in."
+ (if (match-beginning num)
+ (if string
+ (substring string (match-beginning num) (match-end num))
+ (buffer-substring (match-beginning num) (match-end num)))))
+
+ (defun match-string-no-properties (num &optional string)
+ "Return string of text matched by last search, without text properties.
+ NUM specifies which parenthesized expression in the last regexp.
+ Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
+ Zero means the entire text matched by the whole regexp or whole string.
+ STRING should be given if the last search was by `string-match' on STRING.
+ If STRING is nil, the current buffer should be the same buffer
+ the search/match was performed in."
+ (if (match-beginning num)
+ (if string
+ (substring-no-properties string (match-beginning num)
+ (match-end num))
+ (buffer-substring-no-properties (match-beginning num)
+ (match-end num)))))
+
+
+ (defun match-substitute-replacement (replacement
+ &optional fixedcase literal string subexp)
+ "Return REPLACEMENT as it will be inserted by `replace-match'.
+ In other words, all back-references in the form `\\&' and `\\N'
+ are substituted with actual strings matched by the last search.
+ Optional FIXEDCASE, LITERAL, STRING and SUBEXP have the same
+ meaning as for `replace-match'."
+ (let ((match (match-string 0 string)))
+ (save-match-data
+ (set-match-data (mapcar (lambda (x)
+ (if (numberp x)
+ (- x (match-beginning 0))
+ x))
+ (match-data t)))
+ (replace-match replacement fixedcase literal match subexp))))
+
+
+ (defun looking-back (regexp &optional limit greedy)
+ "Return non-nil if text before point matches regular expression REGEXP.
+ Like `looking-at' except matches before point, and is slower.
+ LIMIT if non-nil speeds up the search by specifying a minimum
+ starting position, to avoid checking matches that would start
+ before LIMIT.
+
+ If GREEDY is non-nil, extend the match backwards as far as
+ possible, stopping when a single additional previous character
+ cannot be part of a match for REGEXP. When the match is
+ extended, its starting position is allowed to occur before
+ LIMIT.
+
+ As a general recommendation, try to avoid using `looking-back'
+ wherever possible, since it is slow."
+ (let ((start (point))
+ (pos
+ (save-excursion
+ (and (re-search-backward (concat "\\(?:" regexp "\\)\\=") limit t)
+ (point)))))
+ (if (and greedy pos)
+ (save-restriction
+ (narrow-to-region (point-min) start)
+ (while (and (> pos (point-min))
+ (save-excursion
+ (goto-char pos)
+ (backward-char 1)
+ (looking-at (concat "\\(?:" regexp "\\)\\'"))))
+ (setq pos (1- pos)))
+ (save-excursion
+ (goto-char pos)
+ (looking-at (concat "\\(?:" regexp "\\)\\'")))))
+ (not (null pos))))
+
+ (defsubst looking-at-p (regexp)
+ "\
+ Same as `looking-at' except this function does not change the match data."
+ (let ((inhibit-changing-match-data t))
+ (looking-at regexp)))
+
+ (defsubst string-match-p (regexp string &optional start)
+ "\
+ Same as `string-match' except this function does not change the match data."
+ (let ((inhibit-changing-match-data t))
+ (string-match regexp string start)))
+
+ (defun subregexp-context-p (regexp pos &optional start)
+ "Return non-nil if POS is in a normal subregexp context in REGEXP.
+ A subregexp context is one where a sub-regexp can appear.
+ A non-subregexp context is for example within brackets, or within a
+ repetition bounds operator `\\=\\{...\\}', or right after a `\\'.
+ If START is non-nil, it should be a position in REGEXP, smaller
+ than POS, and known to be in a subregexp context."
+ ;; Here's one possible implementation, with the great benefit that it
+ ;; reuses the regexp-matcher's own parser, so it understands all the
+ ;; details of the syntax. A disadvantage is that it needs to match the
+ ;; error string.
+ (condition-case err
+ (progn
+ (string-match (substring regexp (or start 0) pos) "")
+ t)
+ (invalid-regexp
+ (not (member (cadr err) '("Unmatched [ or [^"
+ "Unmatched \\{"
+ "Trailing backslash")))))
+ ;; An alternative implementation:
+ ;; (defconst re-context-re
+ ;; (let* ((harmless-ch "[^\\[]")
+ ;; (harmless-esc "\\\\[^{]")
+ ;; (class-harmless-ch "[^][]")
+ ;; (class-lb-harmless "[^]:]")
+ ;; (class-lb-colon-maybe-charclass ":\\([a-z]+:]\\)?")
+ ;; (class-lb (concat "\\[\\(" class-lb-harmless
+ ;; "\\|" class-lb-colon-maybe-charclass "\\)"))
+ ;; (class
+ ;; (concat "\\[^?]?"
+ ;; "\\(" class-harmless-ch
+ ;; "\\|" class-lb "\\)*"
+ ;; "\\[?]")) ; special handling for bare [ at end of re
+ ;; (braces "\\\\{[0-9,]+\\\\}"))
+ ;; (concat "\\`\\(" harmless-ch "\\|" harmless-esc
+ ;; "\\|" class "\\|" braces "\\)*\\'"))
+ ;; "Matches any prefix that corresponds to a normal subregexp context.")
+ ;; (string-match re-context-re (substring regexp (or start 0) pos))
+ )
+ \f
+ ;;;; split-string
+
+ (defconst split-string-default-separators "[ \f\t\n\r\v]+"
+ "The default value of separators for `split-string'.
+
+ A regexp matching strings of whitespace. May be locale-dependent
+ \(as yet unimplemented). Should not match non-breaking spaces.
+
+ Warning: binding this to a different value and using it as default is
+ likely to have undesired semantics.")
+
+ ;; The specification says that if both SEPARATORS and OMIT-NULLS are
+ ;; defaulted, OMIT-NULLS should be treated as t. Simplifying the logical
+ ;; expression leads to the equivalent implementation that if SEPARATORS
+ ;; is defaulted, OMIT-NULLS is treated as t.
+ (defun split-string (string &optional separators omit-nulls trim)
+ "Split STRING into substrings bounded by matches for SEPARATORS.
+
+ The beginning and end of STRING, and each match for SEPARATORS, are
+ splitting points. The substrings matching SEPARATORS are removed, and
+ the substrings between the splitting points are collected as a list,
+ which is returned.
+
+ If SEPARATORS is non-nil, it should be a regular expression matching text
+ which separates, but is not part of, the substrings. If nil it defaults to
+ `split-string-default-separators', normally \"[ \\f\\t\\n\\r\\v]+\", and
+ OMIT-NULLS is forced to t.
+
+ If OMIT-NULLS is t, zero-length substrings are omitted from the list (so
+ that for the default value of SEPARATORS leading and trailing whitespace
+ are effectively trimmed). If nil, all zero-length substrings are retained,
+ which correctly parses CSV format, for example.
+
+ If TRIM is non-nil, it should be a regular expression to match
+ text to trim from the beginning and end of each substring. If trimming
+ makes the substring empty, it is treated as null.
+
+ If you want to trim whitespace from the substrings, the reliably correct
+ way is using TRIM. Making SEPARATORS match that whitespace gives incorrect
+ results when there is whitespace at the start or end of STRING. If you
+ see such calls to `split-string', please fix them.
+
+ Note that the effect of `(split-string STRING)' is the same as
+ `(split-string STRING split-string-default-separators t)'. In the rare
+ case that you wish to retain zero-length substrings when splitting on
+ whitespace, use `(split-string STRING split-string-default-separators)'.
+
+ Modifies the match data; use `save-match-data' if necessary."
+ (let* ((keep-nulls (not (if separators omit-nulls t)))
+ (rexp (or separators split-string-default-separators))
+ (start 0)
+ this-start this-end
+ notfirst
+ (list nil)
+ (push-one
+ ;; Push the substring in range THIS-START to THIS-END
+ ;; onto LIST, trimming it and perhaps discarding it.
+ (lambda ()
+ (when trim
+ ;; Discard the trim from start of this substring.
+ (let ((tem (string-match trim string this-start)))
+ (and (eq tem this-start)
+ (setq this-start (match-end 0)))))
+
+ (when (or keep-nulls (< this-start this-end))
+ (let ((this (substring string this-start this-end)))
+
+ ;; Discard the trim from end of this substring.
+ (when trim
+ (let ((tem (string-match (concat trim "\\'") this 0)))
+ (and tem (< tem (length this))
+ (setq this (substring this 0 tem)))))
+
+ ;; Trimming could make it empty; check again.
+ (when (or keep-nulls (> (length this) 0))
+ (push this list)))))))
+
+ (while (and (string-match rexp string
+ (if (and notfirst
+ (= start (match-beginning 0))
+ (< start (length string)))
+ (1+ start) start))
+ (< start (length string)))
+ (setq notfirst t)
+ (setq this-start start this-end (match-beginning 0)
+ start (match-end 0))
+
+ (funcall push-one))
+
+ ;; Handle the substring at the end of STRING.
+ (setq this-start start this-end (length string))
+ (funcall push-one)
+
+ (nreverse list)))
+
+ (defun combine-and-quote-strings (strings &optional separator)
+ "Concatenate the STRINGS, adding the SEPARATOR (default \" \").
+ This tries to quote the strings to avoid ambiguity such that
+ (split-string-and-unquote (combine-and-quote-strings strs)) == strs
+ Only some SEPARATORs will work properly."
+ (let* ((sep (or separator " "))
+ (re (concat "[\\\"]" "\\|" (regexp-quote sep))))
+ (mapconcat
+ (lambda (str)
+ (if (string-match re str)
+ (concat "\"" (replace-regexp-in-string "[\\\"]" "\\\\\\&" str) "\"")
+ str))
+ strings sep)))
+
+ (defun split-string-and-unquote (string &optional separator)
+ "Split the STRING into a list of strings.
+ It understands Emacs Lisp quoting within STRING, such that
+ (split-string-and-unquote (combine-and-quote-strings strs)) == strs
+ The SEPARATOR regexp defaults to \"\\s-+\"."
+ (let ((sep (or separator "\\s-+"))
+ (i (string-match "\"" string)))
+ (if (null i)
+ (split-string string sep t) ; no quoting: easy
+ (append (unless (eq i 0) (split-string (substring string 0 i) sep t))
+ (let ((rfs (read-from-string string i)))
+ (cons (car rfs)
+ (split-string-and-unquote (substring string (cdr rfs))
+ sep)))))))
+
+ \f
+ ;;;; Replacement in strings.
+
+ (defun subst-char-in-string (fromchar tochar string &optional inplace)
+ "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
+ Unless optional argument INPLACE is non-nil, return a new string."
+ (let ((i (length string))
+ (newstr (if inplace string (copy-sequence string))))
+ (while (> i 0)
+ (setq i (1- i))
+ (if (eq (aref newstr i) fromchar)
+ (aset newstr i tochar)))
+ newstr))
+
+ (defun replace-regexp-in-string (regexp rep string &optional
+ fixedcase literal subexp start)
+ "Replace all matches for REGEXP with REP in STRING.
+
+ Return a new string containing the replacements.
+
+ Optional arguments FIXEDCASE, LITERAL and SUBEXP are like the
+ arguments with the same names of function `replace-match'. If START
+ is non-nil, start replacements at that index in STRING.
+
+ REP is either a string used as the NEWTEXT arg of `replace-match' or a
+ function. If it is a function, it is called with the actual text of each
+ match, and its value is used as the replacement text. When REP is called,
+ the match data are the result of matching REGEXP against a substring
+ of STRING.
+
+ To replace only the first match (if any), make REGEXP match up to \\'
+ and replace a sub-expression, e.g.
+ (replace-regexp-in-string \"\\\\(foo\\\\).*\\\\'\" \"bar\" \" foo foo\" nil nil 1)
+ => \" bar foo\""
+
+ ;; To avoid excessive consing from multiple matches in long strings,
+ ;; don't just call `replace-match' continually. Walk down the
+ ;; string looking for matches of REGEXP and building up a (reversed)
+ ;; list MATCHES. This comprises segments of STRING which weren't
+ ;; matched interspersed with replacements for segments that were.
+ ;; [For a `large' number of replacements it's more efficient to
+ ;; operate in a temporary buffer; we can't tell from the function's
+ ;; args whether to choose the buffer-based implementation, though it
+ ;; might be reasonable to do so for long enough STRING.]
+ (let ((l (length string))
+ (start (or start 0))
+ matches str mb me)
+ (save-match-data
+ (while (and (< start l) (string-match regexp string start))
+ (setq mb (match-beginning 0)
+ me (match-end 0))
+ ;; If we matched the empty string, make sure we advance by one char
+ (when (= me mb) (setq me (min l (1+ mb))))
+ ;; Generate a replacement for the matched substring.
+ ;; Operate only on the substring to minimize string consing.
+ ;; Set up match data for the substring for replacement;
+ ;; presumably this is likely to be faster than munging the
+ ;; match data directly in Lisp.
+ (string-match regexp (setq str (substring string mb me)))
+ (setq matches
+ (cons (replace-match (if (stringp rep)
+ rep
+ (funcall rep (match-string 0 str)))
+ fixedcase literal str subexp)
+ (cons (substring string start mb) ; unmatched prefix
+ matches)))
+ (setq start me))
+ ;; Reconstruct a string from the pieces.
+ (setq matches (cons (substring string start l) matches)) ; leftover
+ (apply #'concat (nreverse matches)))))
+ \f
+ (defun string-prefix-p (str1 str2 &optional ignore-case)
+ "Return non-nil if STR1 is a prefix of STR2.
+ If IGNORE-CASE is non-nil, the comparison is done without paying attention
+ to case differences."
+ (eq t (compare-strings str1 nil nil
+ str2 0 (length str1) ignore-case)))
+
+ (defun string-suffix-p (suffix string &optional ignore-case)
+ "Return non-nil if SUFFIX is a suffix of STRING.
+ If IGNORE-CASE is non-nil, the comparison is done without paying
+ attention to case differences."
+ (let ((start-pos (- (length string) (length suffix))))
+ (and (>= start-pos 0)
+ (eq t (compare-strings suffix nil nil
+ string start-pos nil ignore-case)))))
+
+ (defun bidi-string-mark-left-to-right (str)
+ "Return a string that can be safely inserted in left-to-right text.
+
+ Normally, inserting a string with right-to-left (RTL) script into
+ a buffer may cause some subsequent text to be displayed as part
+ of the RTL segment (usually this affects punctuation characters).
+ This function returns a string which displays as STR but forces
+ subsequent text to be displayed as left-to-right.
+
+ If STR contains any RTL character, this function returns a string
+ consisting of STR followed by an invisible left-to-right mark
+ \(LRM) character. Otherwise, it returns STR."
+ (unless (stringp str)
+ (signal 'wrong-type-argument (list 'stringp str)))
+ (if (string-match "\\cR" str)
+ (concat str (propertize (string ?\x200e) 'invisible t))
+ str))
+ \f
+ ;;;; Specifying things to do later.
+
+ (defun load-history-regexp (file)
+ "Form a regexp to find FILE in `load-history'.
+ FILE, a string, is described in the function `eval-after-load'."
+ (if (file-name-absolute-p file)
+ (setq file (file-truename file)))
+ (concat (if (file-name-absolute-p file) "\\`" "\\(\\`\\|/\\)")
+ (regexp-quote file)
+ (if (file-name-extension file)
+ ""
+ ;; Note: regexp-opt can't be used here, since we need to call
+ ;; this before Emacs has been fully started. 2006-05-21
+ (concat "\\(" (mapconcat 'regexp-quote load-suffixes "\\|") "\\)?"))
+ "\\(" (mapconcat 'regexp-quote jka-compr-load-suffixes "\\|")
+ "\\)?\\'"))
+
+ (defun load-history-filename-element (file-regexp)
+ "Get the first elt of `load-history' whose car matches FILE-REGEXP.
+ Return nil if there isn't one."
+ (let* ((loads load-history)
+ (load-elt (and loads (car loads))))
+ (save-match-data
+ (while (and loads
+ (or (null (car load-elt))
+ (not (string-match file-regexp (car load-elt)))))
+ (setq loads (cdr loads)
+ load-elt (and loads (car loads)))))
+ load-elt))
+
+ (put 'eval-after-load 'lisp-indent-function 1)
+ (defun eval-after-load (file form)
+ "Arrange that if FILE is loaded, FORM will be run immediately afterwards.
+ If FILE is already loaded, evaluate FORM right now.
+ FORM can be an Elisp expression (in which case it's passed to `eval'),
+ or a function (in which case it's passed to `funcall' with no argument).
+
+ If a matching file is loaded again, FORM will be evaluated again.
+
+ If FILE is a string, it may be either an absolute or a relative file
+ name, and may have an extension (e.g. \".el\") or may lack one, and
+ additionally may or may not have an extension denoting a compressed
+ format (e.g. \".gz\").
+
+ When FILE is absolute, this first converts it to a true name by chasing
+ symbolic links. Only a file of this name (see next paragraph regarding
+ extensions) will trigger the evaluation of FORM. When FILE is relative,
+ a file whose absolute true name ends in FILE will trigger evaluation.
+
+ When FILE lacks an extension, a file name with any extension will trigger
+ evaluation. Otherwise, its extension must match FILE's. A further
+ extension for a compressed format (e.g. \".gz\") on FILE will not affect
+ this name matching.
+
+ Alternatively, FILE can be a feature (i.e. a symbol), in which case FORM
+ is evaluated at the end of any file that `provide's this feature.
+ If the feature is provided when evaluating code not associated with a
+ file, FORM is evaluated immediately after the provide statement.
+
+ Usually FILE is just a library name like \"font-lock\" or a feature name
+ like 'font-lock.
+
+ This function makes or adds to an entry on `after-load-alist'."
+ (declare (compiler-macro
+ (lambda (whole)
+ (if (eq 'quote (car-safe form))
+ ;; Quote with lambda so the compiler can look inside.
+ `(eval-after-load ,file (lambda () ,(nth 1 form)))
+ whole))))
+ ;; Add this FORM into after-load-alist (regardless of whether we'll be
+ ;; evaluating it now).
+ (let* ((regexp-or-feature
+ (if (stringp file)
+ (setq file (purecopy (load-history-regexp file)))
+ file))
+ (elt (assoc regexp-or-feature after-load-alist))
+ (func
+ (if (functionp form) form
+ ;; Try to use the "current" lexical/dynamic mode for `form'.
+ (eval `(lambda () ,form) lexical-binding))))
+ (unless elt
+ (setq elt (list regexp-or-feature))
+ (push elt after-load-alist))
+ ;; Is there an already loaded file whose name (or `provide' name)
+ ;; matches FILE?
+ (prog1 (if (if (stringp file)
+ (load-history-filename-element regexp-or-feature)
+ (featurep file))
+ (funcall func))
+ (let ((delayed-func
+ (if (not (symbolp regexp-or-feature)) func
+ ;; For features, the after-load-alist elements get run when
+ ;; `provide' is called rather than at the end of the file.
+ ;; So add an indirection to make sure that `func' is really run
+ ;; "after-load" in case the provide call happens early.
+ (lambda ()
+ (if (not load-file-name)
+ ;; Not being provided from a file, run func right now.
+ (funcall func)
+ (let ((lfn load-file-name)
+ ;; Don't use letrec, because equal (in
+ ;; add/remove-hook) would get trapped in a cycle.
+ (fun (make-symbol "eval-after-load-helper")))
+ (fset fun (lambda (file)
+ (when (equal file lfn)
+ (remove-hook 'after-load-functions fun)
+ (funcall func))))
+ (add-hook 'after-load-functions fun 'append)))))))
+ ;; Add FORM to the element unless it's already there.
+ (unless (member delayed-func (cdr elt))
+ (nconc elt (list delayed-func)))))))
+
+ (defmacro with-eval-after-load (file &rest body)
+ "Execute BODY after FILE is loaded.
+ FILE is normally a feature name, but it can also be a file name,
+ in case that file does not provide any feature."
+ (declare (indent 1) (debug t))
+ `(eval-after-load ,file (lambda () ,@body)))
+
+ (defvar after-load-functions nil
+ "Special hook run after loading a file.
+ Each function there is called with a single argument, the absolute
+ name of the file just loaded.")
+
+ (defun do-after-load-evaluation (abs-file)
+ "Evaluate all `eval-after-load' forms, if any, for ABS-FILE.
+ ABS-FILE, a string, should be the absolute true name of a file just loaded.
+ This function is called directly from the C code."
+ ;; Run the relevant eval-after-load forms.
+ (dolist (a-l-element after-load-alist)
+ (when (and (stringp (car a-l-element))
+ (string-match-p (car a-l-element) abs-file))
+ ;; discard the file name regexp
+ (mapc #'funcall (cdr a-l-element))))
+ ;; Complain when the user uses obsolete files.
+ (when (string-match-p "/obsolete/[^/]*\\'" abs-file)
+ ;; Maybe we should just use display-warning? This seems yucky...
+ (let* ((file (file-name-nondirectory abs-file))
+ (msg (format "Package %s is obsolete!"
+ (substring file 0
+ (string-match "\\.elc?\\>" file)))))
+ ;; Cribbed from cl--compiling-file.
+ (if (and (boundp 'byte-compile--outbuffer)
+ (bufferp (symbol-value 'byte-compile--outbuffer))
+ (equal (buffer-name (symbol-value 'byte-compile--outbuffer))
+ " *Compiler Output*"))
+ ;; Don't warn about obsolete files using other obsolete files.
+ (unless (and (stringp byte-compile-current-file)
+ (string-match-p "/obsolete/[^/]*\\'"
+ (expand-file-name
+ byte-compile-current-file
+ byte-compile-root-dir)))
+ (byte-compile-log-warning msg))
+ (run-with-timer 0 nil
+ (lambda (msg)
+ (message "%s" msg)) msg))))
+
+ ;; Finally, run any other hook.
+ (run-hook-with-args 'after-load-functions abs-file))
+
+ (defun eval-next-after-load (file)
+ "Read the following input sexp, and run it whenever FILE is loaded.
+ This makes or adds to an entry on `after-load-alist'.
+ FILE should be the name of a library, with no directory name."
+ (declare (obsolete eval-after-load "23.2"))
+ (eval-after-load file (read)))
+
+ \f
+ (defun display-delayed-warnings ()
+ "Display delayed warnings from `delayed-warnings-list'.
+ Used from `delayed-warnings-hook' (which see)."
+ (dolist (warning (nreverse delayed-warnings-list))
+ (apply 'display-warning warning))
+ (setq delayed-warnings-list nil))
+
+ (defun collapse-delayed-warnings ()
+ "Remove duplicates from `delayed-warnings-list'.
+ Collapse identical adjacent warnings into one (plus count).
+ Used from `delayed-warnings-hook' (which see)."
+ (let ((count 1)
+ collapsed warning)
+ (while delayed-warnings-list
+ (setq warning (pop delayed-warnings-list))
+ (if (equal warning (car delayed-warnings-list))
+ (setq count (1+ count))
+ (when (> count 1)
+ (setcdr warning (cons (format "%s [%d times]" (cadr warning) count)
+ (cddr warning)))
+ (setq count 1))
+ (push warning collapsed)))
+ (setq delayed-warnings-list (nreverse collapsed))))
+
+ ;; At present this is only used for Emacs internals.
+ ;; Ref http://lists.gnu.org/archive/html/emacs-devel/2012-02/msg00085.html
+ (defvar delayed-warnings-hook '(collapse-delayed-warnings
+ display-delayed-warnings)
+ "Normal hook run to process and display delayed warnings.
+ By default, this hook contains functions to consolidate the
+ warnings listed in `delayed-warnings-list', display them, and set
+ `delayed-warnings-list' back to nil.")
+
+ (defun delay-warning (type message &optional level buffer-name)
+ "Display a delayed warning.
+ Aside from going through `delayed-warnings-list', this is equivalent
+ to `display-warning'."
+ (push (list type message level buffer-name) delayed-warnings-list))
+
+ \f
+ ;;;; invisibility specs
+
+ (defun add-to-invisibility-spec (element)
+ "Add ELEMENT to `buffer-invisibility-spec'.
+ See documentation for `buffer-invisibility-spec' for the kind of elements
+ that can be added."
+ (if (eq buffer-invisibility-spec t)
+ (setq buffer-invisibility-spec (list t)))
+ (setq buffer-invisibility-spec
+ (cons element buffer-invisibility-spec)))
+
+ (defun remove-from-invisibility-spec (element)
+ "Remove ELEMENT from `buffer-invisibility-spec'."
+ (if (consp buffer-invisibility-spec)
+ (setq buffer-invisibility-spec
+ (delete element buffer-invisibility-spec))))
+ \f
+ ;;;; Syntax tables.
+
+ (defmacro with-syntax-table (table &rest body)
+ "Evaluate BODY with syntax table of current buffer set to TABLE.
+ The syntax table of the current buffer is saved, BODY is evaluated, and the
+ saved table is restored, even in case of an abnormal exit.
+ Value is what BODY returns."
+ (declare (debug t) (indent 1))
+ (let ((old-table (make-symbol "table"))
+ (old-buffer (make-symbol "buffer")))
+ `(let ((,old-table (syntax-table))
+ (,old-buffer (current-buffer)))
+ (unwind-protect
+ (progn
+ (set-syntax-table ,table)
+ ,@body)
+ (save-current-buffer
+ (set-buffer ,old-buffer)
+ (set-syntax-table ,old-table))))))
+
+ (defun make-syntax-table (&optional oldtable)
+ "Return a new syntax table.
+ Create a syntax table which inherits from OLDTABLE (if non-nil) or
+ from `standard-syntax-table' otherwise."
+ (let ((table (make-char-table 'syntax-table nil)))
+ (set-char-table-parent table (or oldtable (standard-syntax-table)))
+ table))
+
+ (defun syntax-after (pos)
+ "Return the raw syntax descriptor for the char after POS.
+ If POS is outside the buffer's accessible portion, return nil."
+ (unless (or (< pos (point-min)) (>= pos (point-max)))
+ (let ((st (if parse-sexp-lookup-properties
+ (get-char-property pos 'syntax-table))))
+ (if (consp st) st
+ (aref (or st (syntax-table)) (char-after pos))))))
+
+ (defun syntax-class (syntax)
+ "Return the code for the syntax class described by SYNTAX.
+
+ SYNTAX should be a raw syntax descriptor; the return value is a
+ integer which encodes the corresponding syntax class. See Info
+ node `(elisp)Syntax Table Internals' for a list of codes.
+
+ If SYNTAX is nil, return nil."
+ (and syntax (logand (car syntax) 65535)))
+ \f
+ ;; Utility motion commands
+
+ ;; Whitespace
+
+ (defun forward-whitespace (arg)
+ "Move point to the end of the next sequence of whitespace chars.
+ Each such sequence may be a single newline, or a sequence of
+ consecutive space and/or tab characters.
+ With prefix argument ARG, do it ARG times if positive, or move
+ backwards ARG times if negative."
+ (interactive "^p")
+ (if (natnump arg)
+ (re-search-forward "[ \t]+\\|\n" nil 'move arg)
+ (while (< arg 0)
+ (if (re-search-backward "[ \t]+\\|\n" nil 'move)
+ (or (eq (char-after (match-beginning 0)) ?\n)
+ (skip-chars-backward " \t")))
+ (setq arg (1+ arg)))))
+
+ ;; Symbols
+
+ (defun forward-symbol (arg)
+ "Move point to the next position that is the end of a symbol.
+ A symbol is any sequence of characters that are in either the
+ word constituent or symbol constituent syntax class.
+ With prefix argument ARG, do it ARG times if positive, or move
+ backwards ARG times if negative."
+ (interactive "^p")
+ (if (natnump arg)
+ (re-search-forward "\\(\\sw\\|\\s_\\)+" nil 'move arg)
+ (while (< arg 0)
+ (if (re-search-backward "\\(\\sw\\|\\s_\\)+" nil 'move)
+ (skip-syntax-backward "w_"))
+ (setq arg (1+ arg)))))
+
+ ;; Syntax blocks
+
+ (defun forward-same-syntax (&optional arg)
+ "Move point past all characters with the same syntax class.
+ With prefix argument ARG, do it ARG times if positive, or move
+ backwards ARG times if negative."
+ (interactive "^p")
+ (or arg (setq arg 1))
+ (while (< arg 0)
+ (skip-syntax-backward
+ (char-to-string (char-syntax (char-before))))
+ (setq arg (1+ arg)))
+ (while (> arg 0)
+ (skip-syntax-forward (char-to-string (char-syntax (char-after))))
+ (setq arg (1- arg))))
+
+ \f
+ ;;;; Text clones
+
+ (defvar text-clone--maintaining nil)
+
+ (defun text-clone--maintain (ol1 after beg end &optional _len)
+ "Propagate the changes made under the overlay OL1 to the other clones.
+ This is used on the `modification-hooks' property of text clones."
+ (when (and after (not undo-in-progress)
+ (not text-clone--maintaining)
+ (overlay-start ol1))
+ (let ((margin (if (overlay-get ol1 'text-clone-spreadp) 1 0)))
+ (setq beg (max beg (+ (overlay-start ol1) margin)))
+ (setq end (min end (- (overlay-end ol1) margin)))
+ (when (<= beg end)
+ (save-excursion
+ (when (overlay-get ol1 'text-clone-syntax)
+ ;; Check content of the clone's text.
+ (let ((cbeg (+ (overlay-start ol1) margin))
+ (cend (- (overlay-end ol1) margin)))
+ (goto-char cbeg)
+ (save-match-data
+ (if (not (re-search-forward
+ (overlay-get ol1 'text-clone-syntax) cend t))
+ ;; Mark the overlay for deletion.
+ (setq end cbeg)
+ (when (< (match-end 0) cend)
+ ;; Shrink the clone at its end.
+ (setq end (min end (match-end 0)))
+ (move-overlay ol1 (overlay-start ol1)
+ (+ (match-end 0) margin)))
+ (when (> (match-beginning 0) cbeg)
+ ;; Shrink the clone at its beginning.
+ (setq beg (max (match-beginning 0) beg))
+ (move-overlay ol1 (- (match-beginning 0) margin)
+ (overlay-end ol1)))))))
+ ;; Now go ahead and update the clones.
+ (let ((head (- beg (overlay-start ol1)))
+ (tail (- (overlay-end ol1) end))
+ (str (buffer-substring beg end))
+ (nothing-left t)
+ (text-clone--maintaining t))
+ (dolist (ol2 (overlay-get ol1 'text-clones))
+ (let ((oe (overlay-end ol2)))
+ (unless (or (eq ol1 ol2) (null oe))
+ (setq nothing-left nil)
+ (let ((mod-beg (+ (overlay-start ol2) head)))
+ ;;(overlay-put ol2 'modification-hooks nil)
+ (goto-char (- (overlay-end ol2) tail))
+ (unless (> mod-beg (point))
+ (save-excursion (insert str))
+ (delete-region mod-beg (point)))
+ ;;(overlay-put ol2 'modification-hooks '(text-clone--maintain))
+ ))))
+ (if nothing-left (delete-overlay ol1))))))))
+
+ (defun text-clone-create (start end &optional spreadp syntax)
+ "Create a text clone of START...END at point.
+ Text clones are chunks of text that are automatically kept identical:
+ changes done to one of the clones will be immediately propagated to the other.
+
+ The buffer's content at point is assumed to be already identical to
+ the one between START and END.
+ If SYNTAX is provided it's a regexp that describes the possible text of
+ the clones; the clone will be shrunk or killed if necessary to ensure that
+ its text matches the regexp.
+ If SPREADP is non-nil it indicates that text inserted before/after the
+ clone should be incorporated in the clone."
+ ;; To deal with SPREADP we can either use an overlay with `nil t' along
+ ;; with insert-(behind|in-front-of)-hooks or use a slightly larger overlay
+ ;; (with a one-char margin at each end) with `t nil'.
+ ;; We opted for a larger overlay because it behaves better in the case
+ ;; where the clone is reduced to the empty string (we want the overlay to
+ ;; stay when the clone's content is the empty string and we want to use
+ ;; `evaporate' to make sure those overlays get deleted when needed).
+ ;;
+ (let* ((pt-end (+ (point) (- end start)))
+ (start-margin (if (or (not spreadp) (bobp) (<= start (point-min)))
+ 0 1))
+ (end-margin (if (or (not spreadp)
+ (>= pt-end (point-max))
+ (>= start (point-max)))
+ 0 1))
+ ;; FIXME: Reuse overlays at point to extend dups!
+ (ol1 (make-overlay (- start start-margin) (+ end end-margin) nil t))
+ (ol2 (make-overlay (- (point) start-margin) (+ pt-end end-margin) nil t))
+ (dups (list ol1 ol2)))
+ (overlay-put ol1 'modification-hooks '(text-clone--maintain))
+ (when spreadp (overlay-put ol1 'text-clone-spreadp t))
+ (when syntax (overlay-put ol1 'text-clone-syntax syntax))
+ ;;(overlay-put ol1 'face 'underline)
+ (overlay-put ol1 'evaporate t)
+ (overlay-put ol1 'text-clones dups)
+ ;;
+ (overlay-put ol2 'modification-hooks '(text-clone--maintain))
+ (when spreadp (overlay-put ol2 'text-clone-spreadp t))
+ (when syntax (overlay-put ol2 'text-clone-syntax syntax))
+ ;;(overlay-put ol2 'face 'underline)
+ (overlay-put ol2 'evaporate t)
+ (overlay-put ol2 'text-clones dups)))
+ \f
+ ;;;; Mail user agents.
+
+ ;; Here we include just enough for other packages to be able
+ ;; to define them.
+
+ (defun define-mail-user-agent (symbol composefunc sendfunc
+ &optional abortfunc hookvar)
+ "Define a symbol to identify a mail-sending package for `mail-user-agent'.
+
+ SYMBOL can be any Lisp symbol. Its function definition and/or
+ value as a variable do not matter for this usage; we use only certain
+ properties on its property list, to encode the rest of the arguments.
+
+ COMPOSEFUNC is program callable function that composes an outgoing
+ mail message buffer. This function should set up the basics of the
+ buffer without requiring user interaction. It should populate the
+ standard mail headers, leaving the `to:' and `subject:' headers blank
+ by default.
+
+ COMPOSEFUNC should accept several optional arguments--the same
+ arguments that `compose-mail' takes. See that function's documentation.
+
+ SENDFUNC is the command a user would run to send the message.
+
+ Optional ABORTFUNC is the command a user would run to abort the
+ message. For mail packages that don't have a separate abort function,
+ this can be `kill-buffer' (the equivalent of omitting this argument).
+
+ Optional HOOKVAR is a hook variable that gets run before the message
+ is actually sent. Callers that use the `mail-user-agent' may
+ install a hook function temporarily on this hook variable.
+ If HOOKVAR is nil, `mail-send-hook' is used.
+
+ The properties used on SYMBOL are `composefunc', `sendfunc',
+ `abortfunc', and `hookvar'."
+ (put symbol 'composefunc composefunc)
+ (put symbol 'sendfunc sendfunc)
+ (put symbol 'abortfunc (or abortfunc 'kill-buffer))
+ (put symbol 'hookvar (or hookvar 'mail-send-hook)))
+ \f
+ (defvar called-interactively-p-functions nil
+ "Special hook called to skip special frames in `called-interactively-p'.
+ The functions are called with 3 arguments: (I FRAME1 FRAME2),
+ where FRAME1 is a \"current frame\", FRAME2 is the next frame,
+ I is the index of the frame after FRAME2. It should return nil
+ if those frames don't seem special and otherwise, it should return
+ the number of frames to skip (minus 1).")
+
+ (defconst internal--call-interactively (symbol-function 'call-interactively))
+
+ (defun called-interactively-p (&optional kind)
+ "Return t if the containing function was called by `call-interactively'.
+ If KIND is `interactive', then only return t if the call was made
+ interactively by the user, i.e. not in `noninteractive' mode nor
+ when `executing-kbd-macro'.
+ If KIND is `any', on the other hand, it will return t for any kind of
+ interactive call, including being called as the binding of a key or
+ from a keyboard macro, even in `noninteractive' mode.
+
+ This function is very brittle, it may fail to return the intended result when
+ the code is debugged, advised, or instrumented in some form. Some macros and
+ special forms (such as `condition-case') may also sometimes wrap their bodies
+ in a `lambda', so any call to `called-interactively-p' from those bodies will
+ indicate whether that lambda (rather than the surrounding function) was called
+ interactively.
+
+ Instead of using this function, it is cleaner and more reliable to give your
+ function an extra optional argument whose `interactive' spec specifies
+ non-nil unconditionally (\"p\" is a good way to do this), or via
+ \(not (or executing-kbd-macro noninteractive)).
+
+ The only known proper use of `interactive' for KIND is in deciding
+ whether to display a helpful message, or how to display it. If you're
+ thinking of using it for any other purpose, it is quite likely that
+ you're making a mistake. Think: what do you want to do when the
+ command is called from a keyboard macro?"
+ (declare (advertised-calling-convention (kind) "23.1"))
+ (when (not (and (eq kind 'interactive)
+ (or executing-kbd-macro noninteractive)))
+ (let* ((i 1) ;; 0 is the called-interactively-p frame.
+ frame nextframe
+ (get-next-frame
+ (lambda ()
+ (setq frame nextframe)
+ (setq nextframe (backtrace-frame i 'called-interactively-p))
+ ;; (message "Frame %d = %S" i nextframe)
+ (setq i (1+ i)))))
+ (funcall get-next-frame) ;; Get the first frame.
+ (while
+ ;; FIXME: The edebug and advice handling should be made modular and
+ ;; provided directly by edebug.el and nadvice.el.
+ (progn
+ ;; frame =(backtrace-frame i-2)
+ ;; nextframe=(backtrace-frame i-1)
+ (funcall get-next-frame)
+ ;; `pcase' would be a fairly good fit here, but it sometimes moves
+ ;; branches within local functions, which then messes up the
+ ;; `backtrace-frame' data we get,
+ (or
+ ;; Skip special forms (from non-compiled code).
+ (and frame (null (car frame)))
+ ;; Skip also `interactive-p' (because we don't want to know if
+ ;; interactive-p was called interactively but if it's caller was)
+ ;; and `byte-code' (idem; this appears in subexpressions of things
+ ;; like condition-case, which are wrapped in a separate bytecode
+ ;; chunk).
+ ;; FIXME: For lexical-binding code, this is much worse,
+ ;; because the frames look like "byte-code -> funcall -> #[...]",
+ ;; which is not a reliable signature.
+ (memq (nth 1 frame) '(interactive-p 'byte-code))
+ ;; Skip package-specific stack-frames.
+ (let ((skip (run-hook-with-args-until-success
+ 'called-interactively-p-functions
+ i frame nextframe)))
+ (pcase skip
+ (`nil nil)
+ (`0 t)
+ (_ (setq i (+ i skip -1)) (funcall get-next-frame)))))))
+ ;; Now `frame' should be "the function from which we were called".
+ (pcase (cons frame nextframe)
+ ;; No subr calls `interactive-p', so we can rule that out.
+ (`((,_ ,(pred (lambda (f) (subrp (indirect-function f)))) . ,_) . ,_) nil)
+ ;; In case #<subr call-interactively> without going through the
+ ;; `call-interactively' symbol (bug#3984).
+ (`(,_ . (t ,(pred (eq internal--call-interactively)) . ,_)) t)
+ (`(,_ . (t call-interactively . ,_)) t)))))
+
+ (defun interactive-p ()
+ "Return t if the containing function was run directly by user input.
+ This means that the function was called with `call-interactively'
+ \(which includes being called as the binding of a key)
+ and input is currently coming from the keyboard (not a keyboard macro),
+ and Emacs is not running in batch mode (`noninteractive' is nil).
+
+ The only known proper use of `interactive-p' is in deciding whether to
+ display a helpful message, or how to display it. If you're thinking
+ of using it for any other purpose, it is quite likely that you're
+ making a mistake. Think: what do you want to do when the command is
+ called from a keyboard macro or in batch mode?
+
+ To test whether your function was called with `call-interactively',
+ either (i) add an extra optional argument and give it an `interactive'
+ spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
+ use `called-interactively-p'."
+ (declare (obsolete called-interactively-p "23.2"))
+ (called-interactively-p 'interactive))
+
+ (defun internal-push-keymap (keymap symbol)
+ (let ((map (symbol-value symbol)))
+ (unless (memq keymap map)
+ (unless (memq 'add-keymap-witness (symbol-value symbol))
+ (setq map (make-composed-keymap nil (symbol-value symbol)))
+ (push 'add-keymap-witness (cdr map))
+ (set symbol map))
+ (push keymap (cdr map)))))
+
+ (defun internal-pop-keymap (keymap symbol)
+ (let ((map (symbol-value symbol)))
+ (when (memq keymap map)
+ (setf (cdr map) (delq keymap (cdr map))))
+ (let ((tail (cddr map)))
+ (and (or (null tail) (keymapp tail))
+ (eq 'add-keymap-witness (nth 1 map))
+ (set symbol tail)))))
+
+ (define-obsolete-function-alias
+ 'set-temporary-overlay-map 'set-transient-map "24.4")
+
+ (defun set-transient-map (map &optional keep-pred on-exit)
+ "Set MAP as a temporary keymap taking precedence over other keymaps.
+ Normally, MAP is used only once, to look up the very next key.
+ However, if the optional argument KEEP-PRED is t, MAP stays
+ active if a key from MAP is used. KEEP-PRED can also be a
+ function of no arguments: if it returns non-nil, then MAP stays
+ active.
+
+ Optional arg ON-EXIT, if non-nil, specifies a function that is
+ called, with no arguments, after MAP is deactivated.
+
+ This uses `overriding-terminal-local-map' which takes precedence over all other
+ keymaps. As usual, if no match for a key is found in MAP, the normal key
+ lookup sequence then continues."
+ (let ((clearfun (make-symbol "clear-transient-map")))
+ ;; Don't use letrec, because equal (in add/remove-hook) would get trapped
+ ;; in a cycle.
+ (fset clearfun
+ (lambda ()
+ (with-demoted-errors "set-transient-map PCH: %S"
+ (unless (cond
+ ((null keep-pred) nil)
+ ((not (eq map (cadr overriding-terminal-local-map)))
+ ;; There's presumably some other transient-map in
+ ;; effect. Wait for that one to terminate before we
+ ;; remove ourselves.
+ ;; For example, if isearch and C-u both use transient
+ ;; maps, then the lifetime of the C-u should be nested
+ ;; within isearch's, so the pre-command-hook of
+ ;; isearch should be suspended during the C-u one so
+ ;; we don't exit isearch just because we hit 1 after
+ ;; C-u and that 1 exits isearch whereas it doesn't
+ ;; exit C-u.
+ t)
+ ((eq t keep-pred)
+ (eq this-command
+ (lookup-key map (this-command-keys-vector))))
+ (t (funcall keep-pred)))
+ (internal-pop-keymap map 'overriding-terminal-local-map)
+ (remove-hook 'pre-command-hook clearfun)
+ (when on-exit (funcall on-exit))))))
+ (add-hook 'pre-command-hook clearfun)
+ (internal-push-keymap map 'overriding-terminal-local-map)))
+
+ ;;;; Progress reporters.
+
+ ;; Progress reporter has the following structure:
+ ;;
+ ;; (NEXT-UPDATE-VALUE . [NEXT-UPDATE-TIME
+ ;; MIN-VALUE
+ ;; MAX-VALUE
+ ;; MESSAGE
+ ;; MIN-CHANGE
+ ;; MIN-TIME])
+ ;;
+ ;; This weirdness is for optimization reasons: we want
+ ;; `progress-reporter-update' to be as fast as possible, so
+ ;; `(car reporter)' is better than `(aref reporter 0)'.
+ ;;
+ ;; NEXT-UPDATE-TIME is a float. While `float-time' loses a couple
+ ;; digits of precision, it doesn't really matter here. On the other
+ ;; hand, it greatly simplifies the code.
+
+ (defsubst progress-reporter-update (reporter &optional value)
+ "Report progress of an operation in the echo area.
+ REPORTER should be the result of a call to `make-progress-reporter'.
+
+ If REPORTER is a numerical progress reporter---i.e. if it was
+ made using non-nil MIN-VALUE and MAX-VALUE arguments to
+ `make-progress-reporter'---then VALUE should be a number between
+ MIN-VALUE and MAX-VALUE.
+
+ If REPORTER is a non-numerical reporter, VALUE should be nil.
+
+ This function is relatively inexpensive. If the change since
+ last update is too small or insufficient time has passed, it does
+ nothing."
+ (when (or (not (numberp value)) ; For pulsing reporter
+ (>= value (car reporter))) ; For numerical reporter
+ (progress-reporter-do-update reporter value)))
+
+ (defun make-progress-reporter (message &optional min-value max-value
+ current-value min-change min-time)
+ "Return progress reporter object for use with `progress-reporter-update'.
+
+ MESSAGE is shown in the echo area, with a status indicator
+ appended to the end. When you call `progress-reporter-done', the
+ word \"done\" is printed after the MESSAGE. You can change the
+ MESSAGE of an existing progress reporter by calling
+ `progress-reporter-force-update'.
+
+ MIN-VALUE and MAX-VALUE, if non-nil, are starting (0% complete)
+ and final (100% complete) states of operation; the latter should
+ be larger. In this case, the status message shows the percentage
+ progress.
+
+ If MIN-VALUE and/or MAX-VALUE is omitted or nil, the status
+ message shows a \"spinning\", non-numeric indicator.
+
+ Optional CURRENT-VALUE is the initial progress; the default is
+ MIN-VALUE.
+ Optional MIN-CHANGE is the minimal change in percents to report;
+ the default is 1%.
+ CURRENT-VALUE and MIN-CHANGE do not have any effect if MIN-VALUE
+ and/or MAX-VALUE are nil.
+
+ Optional MIN-TIME specifies the minimum interval time between
+ echo area updates (default is 0.2 seconds.) If the function
+ `float-time' is not present, time is not tracked at all. If the
+ OS is not capable of measuring fractions of seconds, this
+ parameter is effectively rounded up."
+ (when (string-match "[[:alnum:]]\\'" message)
+ (setq message (concat message "...")))
+ (unless min-time
+ (setq min-time 0.2))
+ (let ((reporter
+ ;; Force a call to `message' now
+ (cons (or min-value 0)
+ (vector (if (and (fboundp 'float-time)
+ (>= min-time 0.02))
+ (float-time) nil)
+ min-value
+ max-value
+ message
+ (if min-change (max (min min-change 50) 1) 1)
+ min-time))))
+ (progress-reporter-update reporter (or current-value min-value))
+ reporter))
+
+ (defun progress-reporter-force-update (reporter &optional value new-message)
+ "Report progress of an operation in the echo area unconditionally.
+
+ The first two arguments are the same as in `progress-reporter-update'.
+ NEW-MESSAGE, if non-nil, sets a new message for the reporter."
+ (let ((parameters (cdr reporter)))
+ (when new-message
+ (aset parameters 3 new-message))
+ (when (aref parameters 0)
+ (aset parameters 0 (float-time)))
+ (progress-reporter-do-update reporter value)))
+
+ (defvar progress-reporter--pulse-characters ["-" "\\" "|" "/"]
+ "Characters to use for pulsing progress reporters.")
+
+ (defun progress-reporter-do-update (reporter value)
+ (let* ((parameters (cdr reporter))
+ (update-time (aref parameters 0))
+ (min-value (aref parameters 1))
+ (max-value (aref parameters 2))
+ (text (aref parameters 3))
+ (current-time (float-time))
+ (enough-time-passed
+ ;; See if enough time has passed since the last update.
+ (or (not update-time)
+ (when (>= current-time update-time)
+ ;; Calculate time for the next update
+ (aset parameters 0 (+ update-time (aref parameters 5)))))))
+ (cond ((and min-value max-value)
+ ;; Numerical indicator
+ (let* ((one-percent (/ (- max-value min-value) 100.0))
+ (percentage (if (= max-value min-value)
+ 0
+ (truncate (/ (- value min-value)
+ one-percent)))))
+ ;; Calculate NEXT-UPDATE-VALUE. If we are not printing
+ ;; message because not enough time has passed, use 1
+ ;; instead of MIN-CHANGE. This makes delays between echo
+ ;; area updates closer to MIN-TIME.
+ (setcar reporter
+ (min (+ min-value (* (+ percentage
+ (if enough-time-passed
+ ;; MIN-CHANGE
+ (aref parameters 4)
+ 1))
+ one-percent))
+ max-value))
+ (when (integerp value)
+ (setcar reporter (ceiling (car reporter))))
+ ;; Only print message if enough time has passed
+ (when enough-time-passed
+ (if (> percentage 0)
+ (message "%s%d%%" text percentage)
+ (message "%s" text)))))
+ ;; Pulsing indicator
+ (enough-time-passed
+ (let ((index (mod (1+ (car reporter)) 4))
+ (message-log-max nil))
+ (setcar reporter index)
+ (message "%s %s"
+ text
+ (aref progress-reporter--pulse-characters
+ index)))))))
+
+ (defun progress-reporter-done (reporter)
+ "Print reporter's message followed by word \"done\" in echo area."
+ (message "%sdone" (aref (cdr reporter) 3)))
+
+ (defmacro dotimes-with-progress-reporter (spec message &rest body)
+ "Loop a certain number of times and report progress in the echo area.
+ Evaluate BODY with VAR bound to successive integers running from
+ 0, inclusive, to COUNT, exclusive. Then evaluate RESULT to get
+ the return value (nil if RESULT is omitted).
+
+ At each iteration MESSAGE followed by progress percentage is
+ printed in the echo area. After the loop is finished, MESSAGE
+ followed by word \"done\" is printed. This macro is a
+ convenience wrapper around `make-progress-reporter' and friends.
+
+ \(fn (VAR COUNT [RESULT]) MESSAGE BODY...)"
+ (declare (indent 2) (debug ((symbolp form &optional form) form body)))
+ (let ((temp (make-symbol "--dotimes-temp--"))
+ (temp2 (make-symbol "--dotimes-temp2--"))
+ (start 0)
+ (end (nth 1 spec)))
+ `(let ((,temp ,end)
+ (,(car spec) ,start)
+ (,temp2 (make-progress-reporter ,message ,start ,end)))
+ (while (< ,(car spec) ,temp)
+ ,@body
+ (progress-reporter-update ,temp2
+ (setq ,(car spec) (1+ ,(car spec)))))
+ (progress-reporter-done ,temp2)
+ nil ,@(cdr (cdr spec)))))
+
+ \f
+ ;;;; Comparing version strings.
+
+ (defconst version-separator "."
+ "Specify the string used to separate the version elements.
+
+ Usually the separator is \".\", but it can be any other string.")
+
+
+ (defconst version-regexp-alist
+ '(("^[-_+ ]?snapshot$" . -4)
+ ;; treat "1.2.3-20050920" and "1.2-3" as snapshot releases
+ ("^[-_+]$" . -4)
+ ;; treat "1.2.3-CVS" as snapshot release
+ ("^[-_+ ]?\\(cvs\\|git\\|bzr\\|svn\\|hg\\|darcs\\)$" . -4)
+ ("^[-_+ ]?alpha$" . -3)
+ ("^[-_+ ]?beta$" . -2)
+ ("^[-_+ ]?\\(pre\\|rc\\)$" . -1))
+ "Specify association between non-numeric version and its priority.
+
+ This association is used to handle version string like \"1.0pre2\",
+ \"0.9alpha1\", etc. It's used by `version-to-list' (which see) to convert the
+ non-numeric part of a version string to an integer. For example:
+
+ String Version Integer List Version
+ \"0.9snapshot\" (0 9 -4)
+ \"1.0-git\" (1 0 -4)
+ \"1.0pre2\" (1 0 -1 2)
+ \"1.0PRE2\" (1 0 -1 2)
+ \"22.8beta3\" (22 8 -2 3)
+ \"22.8 Beta3\" (22 8 -2 3)
+ \"0.9alpha1\" (0 9 -3 1)
+ \"0.9AlphA1\" (0 9 -3 1)
+ \"0.9 alpha\" (0 9 -3)
+
+ Each element has the following form:
+
+ (REGEXP . PRIORITY)
+
+ Where:
+
+ REGEXP regexp used to match non-numeric part of a version string.
+ It should begin with the `^' anchor and end with a `$' to
+ prevent false hits. Letter-case is ignored while matching
+ REGEXP.
+
+ PRIORITY a negative integer specifying non-numeric priority of REGEXP.")
+
+
+ (defun version-to-list (ver)
+ "Convert version string VER into a list of integers.
+
+ The version syntax is given by the following EBNF:
+
+ VERSION ::= NUMBER ( SEPARATOR NUMBER )*.
+
+ NUMBER ::= (0|1|2|3|4|5|6|7|8|9)+.
+
+ SEPARATOR ::= `version-separator' (which see)
+ | `version-regexp-alist' (which see).
+
+ The NUMBER part is optional if SEPARATOR is a match for an element
+ in `version-regexp-alist'.
+
+ Examples of valid version syntax:
+
+ 1.0pre2 1.0.7.5 22.8beta3 0.9alpha1 6.9.30Beta
+
+ Examples of invalid version syntax:
+
+ 1.0prepre2 1.0..7.5 22.8X3 alpha3.2 .5
+
+ Examples of version conversion:
+
+ Version String Version as a List of Integers
+ \"1.0.7.5\" (1 0 7 5)
+ \"1.0pre2\" (1 0 -1 2)
+ \"1.0PRE2\" (1 0 -1 2)
+ \"22.8beta3\" (22 8 -2 3)
+ \"22.8Beta3\" (22 8 -2 3)
+ \"0.9alpha1\" (0 9 -3 1)
+ \"0.9AlphA1\" (0 9 -3 1)
+ \"0.9alpha\" (0 9 -3)
+ \"0.9snapshot\" (0 9 -4)
+ \"1.0-git\" (1 0 -4)
+
+ See documentation for `version-separator' and `version-regexp-alist'."
+ (or (and (stringp ver) (> (length ver) 0))
+ (error "Invalid version string: '%s'" ver))
+ ;; Change .x.y to 0.x.y
+ (if (and (>= (length ver) (length version-separator))
+ (string-equal (substring ver 0 (length version-separator))
+ version-separator))
+ (setq ver (concat "0" ver)))
+ (save-match-data
+ (let ((i 0)
+ (case-fold-search t) ; ignore case in matching
+ lst s al)
+ (while (and (setq s (string-match "[0-9]+" ver i))
+ (= s i))
+ ;; handle numeric part
+ (setq lst (cons (string-to-number (substring ver i (match-end 0)))
+ lst)
+ i (match-end 0))
+ ;; handle non-numeric part
+ (when (and (setq s (string-match "[^0-9]+" ver i))
+ (= s i))
+ (setq s (substring ver i (match-end 0))
+ i (match-end 0))
+ ;; handle alpha, beta, pre, etc. separator
+ (unless (string= s version-separator)
+ (setq al version-regexp-alist)
+ (while (and al (not (string-match (caar al) s)))
+ (setq al (cdr al)))
+ (cond (al
+ (push (cdar al) lst))
+ ;; Convert 22.3a to 22.3.1, 22.3b to 22.3.2, etc.
+ ((string-match "^[-_+ ]?\\([a-zA-Z]\\)$" s)
+ (push (- (aref (downcase (match-string 1 s)) 0) ?a -1)
+ lst))
+ (t (error "Invalid version syntax: '%s'" ver))))))
+ (if (null lst)
+ (error "Invalid version syntax: '%s'" ver)
+ (nreverse lst)))))
+
+
+ (defun version-list-< (l1 l2)
+ "Return t if L1, a list specification of a version, is lower than L2.
+
+ Note that a version specified by the list (1) is equal to (1 0),
+ \(1 0 0), (1 0 0 0), etc. That is, the trailing zeros are insignificant.
+ Also, a version given by the list (1) is higher than (1 -1), which in
+ turn is higher than (1 -2), which is higher than (1 -3)."
+ (while (and l1 l2 (= (car l1) (car l2)))
+ (setq l1 (cdr l1)
+ l2 (cdr l2)))
+ (cond
+ ;; l1 not null and l2 not null
+ ((and l1 l2) (< (car l1) (car l2)))
+ ;; l1 null and l2 null ==> l1 length = l2 length
+ ((and (null l1) (null l2)) nil)
+ ;; l1 not null and l2 null ==> l1 length > l2 length
+ (l1 (< (version-list-not-zero l1) 0))
+ ;; l1 null and l2 not null ==> l2 length > l1 length
+ (t (< 0 (version-list-not-zero l2)))))
+
+
+ (defun version-list-= (l1 l2)
+ "Return t if L1, a list specification of a version, is equal to L2.
+
+ Note that a version specified by the list (1) is equal to (1 0),
+ \(1 0 0), (1 0 0 0), etc. That is, the trailing zeros are insignificant.
+ Also, a version given by the list (1) is higher than (1 -1), which in
+ turn is higher than (1 -2), which is higher than (1 -3)."
+ (while (and l1 l2 (= (car l1) (car l2)))
+ (setq l1 (cdr l1)
+ l2 (cdr l2)))
+ (cond
+ ;; l1 not null and l2 not null
+ ((and l1 l2) nil)
+ ;; l1 null and l2 null ==> l1 length = l2 length
+ ((and (null l1) (null l2)))
+ ;; l1 not null and l2 null ==> l1 length > l2 length
+ (l1 (zerop (version-list-not-zero l1)))
+ ;; l1 null and l2 not null ==> l2 length > l1 length
+ (t (zerop (version-list-not-zero l2)))))
+
+
+ (defun version-list-<= (l1 l2)
+ "Return t if L1, a list specification of a version, is lower or equal to L2.
+
+ Note that integer list (1) is equal to (1 0), (1 0 0), (1 0 0 0),
+ etc. That is, the trailing zeroes are insignificant. Also, integer
+ list (1) is greater than (1 -1) which is greater than (1 -2)
+ which is greater than (1 -3)."
+ (while (and l1 l2 (= (car l1) (car l2)))
+ (setq l1 (cdr l1)
+ l2 (cdr l2)))
+ (cond
+ ;; l1 not null and l2 not null
+ ((and l1 l2) (< (car l1) (car l2)))
+ ;; l1 null and l2 null ==> l1 length = l2 length
+ ((and (null l1) (null l2)))
+ ;; l1 not null and l2 null ==> l1 length > l2 length
+ (l1 (<= (version-list-not-zero l1) 0))
+ ;; l1 null and l2 not null ==> l2 length > l1 length
+ (t (<= 0 (version-list-not-zero l2)))))
+
+ (defun version-list-not-zero (lst)
+ "Return the first non-zero element of LST, which is a list of integers.
+
+ If all LST elements are zeros or LST is nil, return zero."
+ (while (and lst (zerop (car lst)))
+ (setq lst (cdr lst)))
+ (if lst
+ (car lst)
+ ;; there is no element different of zero
+ 0))
+
+
+ (defun version< (v1 v2)
+ "Return t if version V1 is lower (older) than V2.
+
+ Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\",
+ etc. That is, the trailing \".0\"s are insignificant. Also, version
+ string \"1\" is higher (newer) than \"1pre\", which is higher than \"1beta\",
+ which is higher than \"1alpha\", which is higher than \"1snapshot\".
+ Also, \"-GIT\", \"-CVS\" and \"-NNN\" are treated as snapshot versions."
+ (version-list-< (version-to-list v1) (version-to-list v2)))
+
+ (defun version<= (v1 v2)
+ "Return t if version V1 is lower (older) than or equal to V2.
+
+ Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\",
+ etc. That is, the trailing \".0\"s are insignificant. Also, version
+ string \"1\" is higher (newer) than \"1pre\", which is higher than \"1beta\",
+ which is higher than \"1alpha\", which is higher than \"1snapshot\".
+ Also, \"-GIT\", \"-CVS\" and \"-NNN\" are treated as snapshot versions."
+ (version-list-<= (version-to-list v1) (version-to-list v2)))
+
+ (defun version= (v1 v2)
+ "Return t if version V1 is equal to V2.
+
+ Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\",
+ etc. That is, the trailing \".0\"s are insignificant. Also, version
+ string \"1\" is higher (newer) than \"1pre\", which is higher than \"1beta\",
+ which is higher than \"1alpha\", which is higher than \"1snapshot\".
+ Also, \"-GIT\", \"-CVS\" and \"-NNN\" are treated as snapshot versions."
+ (version-list-= (version-to-list v1) (version-to-list v2)))
+
+ \f
+ ;;; Misc.
+ (defconst menu-bar-separator '("--")
+ "Separator for menus.")
+
+ ;; The following statement ought to be in print.c, but `provide' can't
+ ;; be used there.
+ ;; http://lists.gnu.org/archive/html/emacs-devel/2009-08/msg00236.html
+ (when (hash-table-p (car (read-from-string
+ (prin1-to-string (make-hash-table)))))
+ (provide 'hashtable-print-readable))
+
+ ;; This is used in lisp/Makefile.in and in leim/Makefile.in to
+ ;; generate file names for autoloads, custom-deps, and finder-data.
+ (defun unmsys--file-name (file)
+ "Produce the canonical file name for FILE from its MSYS form.
+
+ On systems other than MS-Windows, just returns FILE.
+ On MS-Windows, converts /d/foo/bar form of file names
+ passed by MSYS Make into d:/foo/bar that Emacs can grok.
+
+ This function is called from lisp/Makefile and leim/Makefile."
+ (when (and (eq system-type 'windows-nt)
+ (string-match "\\`/[a-zA-Z]/" file))
+ (setq file (concat (substring file 1 2) ":" (substring file 2))))
+ file)
+
+
+ ;;; subr.el ends here
;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
;; Author: Jackson Ray Hamilton <jackson@jacksonrayhamilton.com>
- ;; Version: 6.3.0
+ ;; Version: 6.4.0
;; Keywords: convenience faces tools
;; Package-Requires: ((emacs "24") (js2-mode "20150126"))
;; URL: https://github.com/jacksonrayhamilton/context-coloring
(defun context-coloring-join (strings delimiter)
"Join a list of STRINGS with the string DELIMITER."
- (mapconcat 'identity strings delimiter))
+ (mapconcat #'identity strings delimiter))
(defsubst context-coloring-trim-right (string)
"Remove leading whitespace from STRING."
(defvar context-coloring-original-maximum-face nil
"Fallback value for `context-coloring-maximum-face' when all
- themes have been disabled.")
+ themes have been disabled.")
(setq context-coloring-maximum-face 7)
(context-coloring-level-face (min level context-coloring-maximum-face)))
+ ;;; Change detection
+
+ (defvar-local context-coloring-changed-p nil
+ "Indication that the buffer has changed recently, which implies
+ that it should be colored again by
+ `context-coloring-maybe-colorize-idle-timer' if that timer is
+ being used.")
+
+ (defvar-local context-coloring-changed-start nil
+ "Beginning of last text that changed.")
+
+ (defvar-local context-coloring-changed-end nil
+ "End of last text that changed.")
+
+ (defvar-local context-coloring-changed-length nil
+ "Length of last text that changed.")
+
+ (defun context-coloring-change-function (start end length)
+ "Register a change so that a buffer can be colorized soon.
+
+ START, END and LENGTH are recorded for later use."
+ ;; Tokenization is obsolete if there was a change.
+ (context-coloring-cancel-scopification)
+ (setq context-coloring-changed-start start)
+ (setq context-coloring-changed-end end)
+ (setq context-coloring-changed-length length)
+ (setq context-coloring-changed-p t))
+
+ (defun context-coloring-maybe-colorize-with-buffer (buffer)
+ "Color BUFFER and if it has changed."
+ (when context-coloring-changed-p
+ (context-coloring-colorize-with-buffer buffer)
+ (setq context-coloring-changed-p nil)
+ (setq context-coloring-changed-start nil)
+ (setq context-coloring-changed-end nil)
+ (setq context-coloring-changed-length nil)))
+
+ (defvar-local context-coloring-maybe-colorize-idle-timer nil
+ "The currently-running idle timer for conditional coloring.")
+
+ (defvar-local context-coloring-colorize-idle-timer nil
+ "The currently-running idle timer for unconditional coloring.")
+
+ (defcustom context-coloring-default-delay 0.25
+ "Default (sometimes overridden) delay between a buffer update
+ and colorization.
+
+ Increase this if your machine is high-performing. Decrease it if
+ it ain't.
+
+ Supported modes: `js-mode', `js3-mode'"
+ :group 'context-coloring)
+
+ (make-obsolete-variable
+ 'context-coloring-delay
+ 'context-coloring-default-delay
+ "6.4.0")
+
+ (defun context-coloring-cancel-timer (timer)
+ "Cancel TIMER."
+ (when timer
+ (cancel-timer timer)))
+
+ (defun context-coloring-schedule-coloring (time)
+ "Schedule coloring to occur once after Emacs is idle for TIME."
+ (context-coloring-cancel-timer context-coloring-colorize-idle-timer)
+ (setq context-coloring-colorize-idle-timer
+ (run-with-idle-timer
+ time
+ nil
+ #'context-coloring-colorize-with-buffer
+ (current-buffer))))
+
+ (defun context-coloring-setup-idle-change-detection ()
+ "Setup idle change detection."
+ (let ((dispatch (context-coloring-get-dispatch-for-mode major-mode)))
+ (add-hook
+ 'after-change-functions #'context-coloring-change-function nil t)
+ (add-hook
+ 'kill-buffer-hook #'context-coloring-teardown-idle-change-detection nil t)
+ (setq context-coloring-maybe-colorize-idle-timer
+ (run-with-idle-timer
+ (or (plist-get dispatch :delay) context-coloring-default-delay)
+ t
+ #'context-coloring-maybe-colorize-with-buffer
+ (current-buffer)))))
+
+ (defun context-coloring-teardown-idle-change-detection ()
+ "Teardown idle change detection."
+ (context-coloring-cancel-scopification)
+ (dolist (timer (list context-coloring-colorize-idle-timer
+ context-coloring-maybe-colorize-idle-timer))
+ (context-coloring-cancel-timer timer))
+ (remove-hook
+ 'kill-buffer-hook #'context-coloring-teardown-idle-change-detection t)
+ (remove-hook
+ 'after-change-functions #'context-coloring-change-function t))
+
+
;;; Colorization utilities
(defsubst context-coloring-colorize-region (start end level)
end
`(face ,(context-coloring-bounded-level-face level))))
- (defcustom context-coloring-comments-and-strings nil
- "If non-nil, also color comments and strings using `font-lock'."
- :group 'context-coloring)
-
(make-obsolete-variable
'context-coloring-comments-and-strings
"use `context-coloring-syntactic-comments' and
:group 'context-coloring)
(defun context-coloring-font-lock-syntactic-comment-function (state)
- "Tell `font-lock' to color a comment but not a string."
+ "Tell `font-lock' to color a comment but not a string according
+ to STATE."
(if (nth 3 state) nil font-lock-comment-face))
(defun context-coloring-font-lock-syntactic-string-function (state)
- "Tell `font-lock' to color a string but not a comment."
+ "Tell `font-lock' to color a string but not a comment according
+ to STATE."
(if (nth 3 state) font-lock-string-face nil))
- (defsubst context-coloring-maybe-colorize-comments-and-strings (&optional min max)
- "Color the current buffer's comments and strings if
- `context-coloring-comments-and-strings' is non-nil."
- (when (or context-coloring-comments-and-strings
- context-coloring-syntactic-comments
+ (defsubst context-coloring-colorize-comments-and-strings (&optional min max)
+ "Color the current buffer's comments or strings if
+ `context-coloring-syntactic-comments' or
+ `context-coloring-syntactic-strings' are non-nil. MIN defaults
+ to the beginning of the buffer and MAX defaults to the end."
+ (when (or context-coloring-syntactic-comments
context-coloring-syntactic-strings)
(let ((min (or min (point-min)))
(max (or max (point-max)))
(cond
((and context-coloring-syntactic-comments
(not context-coloring-syntactic-strings))
- 'context-coloring-font-lock-syntactic-comment-function)
+ #'context-coloring-font-lock-syntactic-comment-function)
((and context-coloring-syntactic-strings
(not context-coloring-syntactic-comments))
- 'context-coloring-font-lock-syntactic-string-function)
+ #'context-coloring-font-lock-syntactic-string-function)
(t
font-lock-syntactic-face-function))))
(save-excursion
"Color the current buffer using the abstract syntax tree
generated by `js2-mode'."
;; Reset the hash table; the old one could be obsolete.
- (setq context-coloring-js2-scope-level-hash-table (make-hash-table :test 'eq))
+ (setq context-coloring-js2-scope-level-hash-table (make-hash-table :test #'eq))
(setq context-coloring-point-max (point-max))
(with-silent-modifications
(js2-visit-ast
(context-coloring-js2-scope-level defining-scope))))))
;; The `t' indicates to search children.
t)))
- (context-coloring-maybe-colorize-comments-and-strings)))
+ (context-coloring-colorize-comments-and-strings)))
;;; Emacs Lisp colorization
- (defsubst context-coloring-make-scope (depth level)
- (list
- :depth depth
- :level level
- :variables (make-hash-table)))
-
- (defsubst context-coloring-scope-get-level (scope)
- (plist-get scope :level))
-
- (defsubst context-coloring-scope-add-variable (scope variable)
- (puthash variable t (plist-get scope :variables)))
-
- (defsubst context-coloring-scope-get-variable (scope variable)
- (gethash variable (plist-get scope :variables)))
-
- (defsubst context-coloring-get-variable-level (scope-stack variable)
- (let* (scope
- level)
- (while (and scope-stack (not level))
- (setq scope (car scope-stack))
- (cond
- ((context-coloring-scope-get-variable scope variable)
- (setq level (context-coloring-scope-get-level scope)))
- (t
- (setq scope-stack (cdr scope-stack)))))
- ;; Assume a global variable.
- (or level 0)))
-
- (defsubst context-coloring-make-backtick (end enabled)
- (list
- :end end
- :enabled enabled))
-
- (defsubst context-coloring-backtick-get-end (backtick)
- (plist-get backtick :end))
-
- (defsubst context-coloring-backtick-get-enabled (backtick)
- (plist-get backtick :enabled))
-
- (defsubst context-coloring-backtick-enabled-p (backtick-stack)
- (context-coloring-backtick-get-enabled (car backtick-stack)))
-
- (defsubst context-coloring-make-let-varlist (depth type)
- (list
- :depth depth
- :type type
- :vars '()))
-
- (defsubst context-coloring-let-varlist-get-type (let-varlist)
- (plist-get let-varlist :type))
-
- (defsubst context-coloring-let-varlist-add-var (let-varlist var)
- (plist-put let-varlist :vars (cons var (plist-get let-varlist :vars))))
-
- (defsubst context-coloring-let-varlist-pop-vars (let-varlist)
- (let ((type (context-coloring-let-varlist-get-type let-varlist))
- (vars (plist-get let-varlist :vars)))
- (cond
- ;; `let' binds all at once at the end.
- ((eq type 'let)
- (prog1
- vars
- (plist-put let-varlist :vars '())))
- ;; `let*' binds incrementally.
- ((eq type 'let*)
- (prog1
- (list (car vars))
- (plist-put let-varlist :vars (cdr vars)))))))
-
(defsubst context-coloring-forward-sws ()
"Move forward through whitespace and comments."
(while (forward-comment 1)))
- (defsubst context-coloring-forward-sexp-position ()
- "Like vanilla `forward-sexp', but just return the position."
- (scan-sexps (point) 1))
-
- (defsubst context-coloring-emacs-lisp-identifier-syntax-p (syntax-code)
- (or (= 2 syntax-code)
- (= 3 syntax-code)))
-
- (defsubst context-coloring-open-parenthesis-p (syntax-code)
- (= 4 syntax-code))
-
- (defsubst context-coloring-close-parenthesis-p (syntax-code)
- (= 5 syntax-code))
-
- (defsubst context-coloring-expression-prefix-p (syntax-code)
- (= 6 syntax-code))
-
- (defsubst context-coloring-at-open-parenthesis-p ()
- (= 4 (logand #xFFFF (car (syntax-after (point))))))
-
- (defsubst context-coloring-ppss-depth (ppss)
- ;; Same as (nth 0 ppss).
- (car ppss))
-
- (defsubst context-coloring-at-stack-depth-p (stack depth)
- (= (plist-get (car stack) :depth) depth))
+ (defsubst context-coloring-elisp-forward-sws ()
+ "Move forward through whitespace and comments, colorizing
+ comments along the way."
+ (let ((start (point)))
+ (context-coloring-forward-sws)
+ (context-coloring-colorize-comments-and-strings start (point))))
+
+ (defsubst context-coloring-elisp-forward-sexp ()
+ "Like `forward-sexp', but colorize comments and strings along
+ the way."
+ (let ((start (point)))
+ (forward-sexp)
+ (context-coloring-elisp-colorize-comments-and-strings-in-region
+ start (point))))
+
+ (defsubst context-coloring-get-syntax-code ()
+ "Get the syntax code at point."
+ (syntax-class
+ ;; Faster version of `syntax-after':
+ (aref (syntax-table) (char-after (point)))))
(defsubst context-coloring-exact-regexp (word)
- "Create a regexp that matches exactly WORD."
+ "Create a regexp matching exactly WORD."
(concat "\\`" (regexp-quote word) "\\'"))
(defsubst context-coloring-exact-or-regexp (words)
- "Create a regexp that matches any exact word in WORDS."
+ "Create a regexp matching any exact word in WORDS."
(context-coloring-join
- (mapcar 'context-coloring-exact-regexp words) "\\|"))
-
- (defconst context-coloring-emacs-lisp-defun-regexp
- (context-coloring-exact-or-regexp
- '("defun" "defun*" "defsubst" "defmacro"
- "cl-defun" "cl-defsubst" "cl-defmacro")))
-
- (defconst context-coloring-emacs-lisp-lambda-regexp
- (context-coloring-exact-regexp "lambda"))
-
- (defconst context-coloring-emacs-lisp-let-regexp
- (context-coloring-exact-regexp "let"))
-
- (defconst context-coloring-emacs-lisp-let*-regexp
- (context-coloring-exact-regexp "let*"))
-
- (defconst context-coloring-arglist-arg-regexp
- "\\`[^&:]")
-
- (defconst context-coloring-ignored-word-regexp
- (concat "\\`[-+]?[0-9]\\|" (context-coloring-exact-or-regexp
- '("t" "nil" "." "?"))))
-
- (defconst context-coloring-COMMA-CHAR 44)
- (defconst context-coloring-BACKTICK-CHAR 96)
+ (mapcar #'context-coloring-exact-regexp words) "\\|"))
+
+ (defconst context-coloring-elisp-ignored-word-regexp
+ (context-coloring-join (list "\\`[-+]?[0-9]"
+ "\\`[&:].+"
+ (context-coloring-exact-or-regexp
+ '("t" "nil" "." "?")))
+ "\\|")
+ "Match words that might be considered symbols but can't be
+ bound as variables.")
+
+ (defconst context-coloring-WORD-CODE 2)
+ (defconst context-coloring-SYMBOL-CODE 3)
+ (defconst context-coloring-OPEN-PARENTHESIS-CODE 4)
+ (defconst context-coloring-CLOSE-PARENTHESIS-CODE 5)
+ (defconst context-coloring-EXPRESSION-PREFIX-CODE 6)
+ (defconst context-coloring-STRING-QUOTE-CODE 7)
+ (defconst context-coloring-ESCAPE-CODE 9)
+ (defconst context-coloring-COMMENT-START-CODE 11)
+ (defconst context-coloring-COMMENT-END-CODE 12)
+
+ (defconst context-coloring-OCTOTHORPE-CHAR (string-to-char "#"))
+ (defconst context-coloring-APOSTROPHE-CHAR (string-to-char "'"))
+ (defconst context-coloring-OPEN-PARENTHESIS-CHAR (string-to-char "("))
+ (defconst context-coloring-COMMA-CHAR (string-to-char ","))
+ (defconst context-coloring-AT-CHAR (string-to-char "@"))
+ (defconst context-coloring-BACKTICK-CHAR (string-to-char "`"))
+
+ (defsubst context-coloring-elisp-identifier-p (syntax-code)
+ "Check if SYNTAX-CODE is an elisp identifier constituent."
+ (or (= syntax-code context-coloring-WORD-CODE)
+ (= syntax-code context-coloring-SYMBOL-CODE)))
(defvar context-coloring-parse-interruptable-p t
"Set this to nil to force parse to continue until finished.")
- (defconst context-coloring-emacs-lisp-iterations-per-pause 1000
+ (defconst context-coloring-elisp-sexps-per-pause 1000
"Pause after this many iterations to check for user input.
If user input is pending, stop the parse. This makes for a
- smoother user experience for large files.
+ smoother user experience for large files.")
+
+ (defvar context-coloring-elisp-sexp-count 0
+ "Current number of sexps leading up to the next pause.")
+
+ (defsubst context-coloring-elisp-increment-sexp-count ()
+ "Maybe check if the current parse should be interrupted as a
+ result of pending user input."
+ (setq context-coloring-elisp-sexp-count
+ (1+ context-coloring-elisp-sexp-count))
+ (when (and (zerop (% context-coloring-elisp-sexp-count
+ context-coloring-elisp-sexps-per-pause))
+ context-coloring-parse-interruptable-p
+ (input-pending-p))
+ (throw 'interrupted t)))
+
+ (defvar context-coloring-elisp-scope-stack '()
+ "List of scopes in the current parse.")
+
+ (defsubst context-coloring-elisp-make-scope (level)
+ "Make a scope object for LEVEL."
+ (list
+ :level level
+ :variables '()))
+
+ (defsubst context-coloring-elisp-scope-get-level (scope)
+ "Get the level of SCOPE object."
+ (plist-get scope :level))
+
+ (defsubst context-coloring-elisp-scope-add-variable (scope variable)
+ "Add to SCOPE a VARIABLE."
+ (plist-put scope :variables (cons variable (plist-get scope :variables))))
- As of this writing, emacs lisp colorization seems to run at about
- 60,000 iterations per second. A default value of 1000 should
- provide visually \"instant\" updates at 60 frames per second.")
+ (defsubst context-coloring-elisp-scope-has-variable (scope variable)
+ "Check if SCOPE has VARIABLE."
+ (member variable (plist-get scope :variables)))
+
+ (defsubst context-coloring-elisp-get-variable-level (variable)
+ "Search up the scope chain for the first instance of VARIABLE
+ and return its level, or 0 (global) if it isn't found."
+ (let* ((scope-stack context-coloring-elisp-scope-stack)
+ scope
+ level)
+ (while (and scope-stack (not level))
+ (setq scope (car scope-stack))
+ (cond
+ ((context-coloring-elisp-scope-has-variable scope variable)
+ (setq level (context-coloring-elisp-scope-get-level scope)))
+ (t
+ (setq scope-stack (cdr scope-stack)))))
+ ;; Assume a global variable.
+ (or level 0)))
+
+ (defsubst context-coloring-elisp-get-current-scope-level ()
+ "Get the nesting level of the current scope."
+ (cond
+ ((car context-coloring-elisp-scope-stack)
+ (context-coloring-elisp-scope-get-level (car context-coloring-elisp-scope-stack)))
+ (t
+ 0)))
+
+ (defsubst context-coloring-elisp-push-scope ()
+ "Add a new scope to the bottom of the scope chain."
+ (push (context-coloring-elisp-make-scope
+ (1+ (context-coloring-elisp-get-current-scope-level)))
+ context-coloring-elisp-scope-stack))
+
+ (defsubst context-coloring-elisp-pop-scope ()
+ "Remove the scope on the bottom of the scope chain."
+ (pop context-coloring-elisp-scope-stack))
+
+ (defsubst context-coloring-elisp-add-variable (variable)
+ "Add VARIABLE to the current scope."
+ (context-coloring-elisp-scope-add-variable
+ (car context-coloring-elisp-scope-stack)
+ variable))
+
+ (defsubst context-coloring-elisp-parse-bindable (callback)
+ "Parse the symbol at point, and if the symbol can be bound,
+ invoke CALLBACK with it."
+ (let* ((arg-string (buffer-substring-no-properties
+ (point)
+ (progn (context-coloring-elisp-forward-sexp)
+ (point)))))
+ (when (not (string-match-p
+ context-coloring-elisp-ignored-word-regexp
+ arg-string))
+ (funcall callback arg-string))))
+
+ (defun context-coloring-elisp-parse-let-varlist (type)
+ "Parse the list of variable initializers at point. If TYPE is
+ `let', all the variables are bound after all their initializers
+ are parsed; if TYPE is `let*', each variable is bound immediately
+ after its own initializer is parsed."
+ (let ((varlist '())
+ syntax-code)
+ ;; Enter.
+ (forward-char)
+ (while (/= (setq syntax-code (context-coloring-get-syntax-code))
+ context-coloring-CLOSE-PARENTHESIS-CODE)
+ (cond
+ ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
+ (forward-char)
+ (context-coloring-elisp-forward-sws)
+ (setq syntax-code (context-coloring-get-syntax-code))
+ (when (context-coloring-elisp-identifier-p syntax-code)
+ (context-coloring-elisp-parse-bindable
+ (lambda (var)
+ (push var varlist)))
+ (context-coloring-elisp-forward-sws)
+ (setq syntax-code (context-coloring-get-syntax-code))
+ (when (/= syntax-code context-coloring-CLOSE-PARENTHESIS-CODE)
+ (context-coloring-elisp-colorize-sexp)))
+ (context-coloring-elisp-forward-sws)
+ ;; Skip past the closing parenthesis.
+ (forward-char))
+ ((context-coloring-elisp-identifier-p syntax-code)
+ (context-coloring-elisp-parse-bindable
+ (lambda (var)
+ (push var varlist))))
+ (t
+ ;; Ignore artifacts.
+ (context-coloring-elisp-forward-sexp)))
+ (when (eq type 'let*)
+ (context-coloring-elisp-add-variable (pop varlist)))
+ (context-coloring-elisp-forward-sws))
+ (when (eq type 'let)
+ (while varlist
+ (context-coloring-elisp-add-variable (pop varlist))))
+ ;; Exit.
+ (forward-char)))
+
+ (defun context-coloring-elisp-parse-arglist ()
+ "Parse the list of function arguments at point."
+ (let (syntax-code)
+ ;; Enter.
+ (forward-char)
+ (while (/= (setq syntax-code (context-coloring-get-syntax-code))
+ context-coloring-CLOSE-PARENTHESIS-CODE)
+ (cond
+ ((context-coloring-elisp-identifier-p syntax-code)
+ (context-coloring-elisp-parse-bindable
+ (lambda (arg)
+ (context-coloring-elisp-add-variable arg))))
+ (t
+ ;; Ignore artifacts.
+ (context-coloring-elisp-forward-sexp)))
+ (context-coloring-elisp-forward-sws))
+ ;; Exit.
+ (forward-char)))
+
+ (defun context-coloring-elisp-skip-callee-name ()
+ "Skip past the opening parenthesis and name of a function."
+ ;; Enter.
+ (forward-char)
+ (context-coloring-elisp-forward-sws)
+ ;; Skip past the function name.
+ (forward-sexp)
+ (context-coloring-elisp-forward-sws))
+
+ (defun context-coloring-elisp-colorize-scope (callback)
+ "Color the whole scope at point with its one color. Handle a
+ header in CALLBACK."
+ (let ((start (point))
+ (end (progn (forward-sexp)
+ (point))))
+ (context-coloring-elisp-push-scope)
+ ;; Splash the whole thing in one color.
+ (context-coloring-colorize-region
+ start
+ end
+ (context-coloring-elisp-get-current-scope-level))
+ ;; Even if the parse is interrupted, this region should still be colored
+ ;; syntactically.
+ (context-coloring-elisp-colorize-comments-and-strings-in-region
+ start
+ end)
+ (goto-char start)
+ (context-coloring-elisp-skip-callee-name)
+ (funcall callback)
+ (context-coloring-elisp-colorize-region (point) (1- end))
+ ;; Exit.
+ (forward-char)
+ (context-coloring-elisp-pop-scope)))
+
+ (defun context-coloring-elisp-parse-header (callback start)
+ "Parse a function header at point with CALLBACK. If there is
+ no header, skip past the sexp at START."
+ (cond
+ ((= (context-coloring-get-syntax-code) context-coloring-OPEN-PARENTHESIS-CODE)
+ (funcall callback))
+ (t
+ ;; Skip it.
+ (goto-char start)
+ (context-coloring-elisp-forward-sexp))))
+
+ (defun context-coloring-elisp-colorize-defun-like (callback)
+ "Color the defun-like function at point, parsing the header
+ with CALLBACK."
+ (let ((start (point)))
+ (context-coloring-elisp-colorize-scope
+ (lambda ()
+ (cond
+ ((context-coloring-elisp-identifier-p (context-coloring-get-syntax-code))
+ ;; Color the defun's name with the top-level color.
+ (context-coloring-colorize-region
+ (point)
+ (progn (forward-sexp)
+ (point))
+ 0)
+ (context-coloring-elisp-forward-sws)
+ (context-coloring-elisp-parse-header callback start))
+ (t
+ ;; Skip it.
+ (goto-char start)
+ (context-coloring-elisp-forward-sexp)))))))
+
+ (defun context-coloring-elisp-colorize-defun ()
+ "Color the `defun' at point."
+ (context-coloring-elisp-colorize-defun-like
+ 'context-coloring-elisp-parse-arglist))
+
+ (defun context-coloring-elisp-colorize-defadvice ()
+ "Color the `defadvice' at point."
+ (context-coloring-elisp-colorize-defun-like
+ (lambda ()
+ (let (syntax-code)
+ ;; Enter.
+ (forward-char)
+ (while (/= (setq syntax-code (context-coloring-get-syntax-code))
+ context-coloring-CLOSE-PARENTHESIS-CODE)
+ (cond
+ ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
+ (context-coloring-elisp-parse-arglist))
+ (t
+ ;; Ignore artifacts.
+ (context-coloring-elisp-forward-sexp)))
+ (context-coloring-elisp-forward-sws))
+ ;; Exit.
+ (forward-char)))))
+
+ (defun context-coloring-elisp-colorize-lambda-like (callback)
+ "Color the lambda-like function at point, parsing the header
+ with CALLBACK."
+ (let ((start (point)))
+ (context-coloring-elisp-colorize-scope
+ (lambda ()
+ (context-coloring-elisp-parse-header callback start)))))
+
+ (defun context-coloring-elisp-colorize-lambda ()
+ "Color the `lambda' at point."
+ (context-coloring-elisp-colorize-lambda-like
+ 'context-coloring-elisp-parse-arglist))
+
+ (defun context-coloring-elisp-colorize-let ()
+ "Color the `let' at point."
+ (context-coloring-elisp-colorize-lambda-like
+ (lambda ()
+ (context-coloring-elisp-parse-let-varlist 'let))))
- (defun context-coloring-emacs-lisp-colorize ()
- "Color the current buffer by parsing emacs lisp sexps."
+ (defun context-coloring-elisp-colorize-let* ()
+ "Color the `let*' at point."
+ (context-coloring-elisp-colorize-lambda-like
+ (lambda ()
+ (context-coloring-elisp-parse-let-varlist 'let*))))
+
+ (defun context-coloring-elisp-colorize-cond ()
+ "Color the `cond' at point."
+ (let (syntax-code)
+ (context-coloring-elisp-skip-callee-name)
+ (while (/= (setq syntax-code (context-coloring-get-syntax-code))
+ context-coloring-CLOSE-PARENTHESIS-CODE)
+ (cond
+ ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
+ ;; Colorize inside the parens.
+ (let ((start (point)))
+ (forward-sexp)
+ (context-coloring-elisp-colorize-region
+ (1+ start) (1- (point)))
+ ;; Exit.
+ (forward-char)))
+ (t
+ ;; Ignore artifacts.
+ (context-coloring-elisp-forward-sexp)))
+ (context-coloring-elisp-forward-sws))
+ ;; Exit.
+ (forward-char)))
+
+ (defun context-coloring-elisp-colorize-condition-case ()
+ "Color the `condition-case' at point."
+ (let (syntax-code
+ variable
+ case-pos
+ case-end)
+ (context-coloring-elisp-colorize-scope
+ (lambda ()
+ (setq syntax-code (context-coloring-get-syntax-code))
+ ;; Gracefully ignore missing variables.
+ (when (context-coloring-elisp-identifier-p syntax-code)
+ (context-coloring-elisp-parse-bindable
+ (lambda (parsed-variable)
+ (setq variable parsed-variable)))
+ (context-coloring-elisp-forward-sws))
+ (context-coloring-elisp-colorize-sexp)
+ (context-coloring-elisp-forward-sws)
+ ;; Parse the handlers with the error variable in scope.
+ (when variable
+ (context-coloring-elisp-add-variable variable))
+ (while (/= (setq syntax-code (context-coloring-get-syntax-code))
+ context-coloring-CLOSE-PARENTHESIS-CODE)
+ (cond
+ ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
+ (setq case-pos (point))
+ (context-coloring-elisp-forward-sexp)
+ (setq case-end (point))
+ (goto-char case-pos)
+ ;; Enter.
+ (forward-char)
+ (context-coloring-elisp-forward-sws)
+ (setq syntax-code (context-coloring-get-syntax-code))
+ (when (/= syntax-code context-coloring-CLOSE-PARENTHESIS-CODE)
+ ;; Skip the condition name(s).
+ (context-coloring-elisp-forward-sexp)
+ ;; Color the remaining portion of the handler.
+ (context-coloring-elisp-colorize-region
+ (point)
+ (1- case-end)))
+ ;; Exit.
+ (forward-char))
+ (t
+ ;; Ignore artifacts.
+ (context-coloring-elisp-forward-sexp)))
+ (context-coloring-elisp-forward-sws))))))
+
+ (defun context-coloring-elisp-colorize-dolist ()
+ "Color the `dolist' at point."
+ (let (syntax-code
+ (index 0))
+ (context-coloring-elisp-colorize-scope
+ (lambda ()
+ (setq syntax-code (context-coloring-get-syntax-code))
+ (when (= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
+ (forward-char)
+ (context-coloring-elisp-forward-sws)
+ (while (/= (setq syntax-code (context-coloring-get-syntax-code))
+ context-coloring-CLOSE-PARENTHESIS-CODE)
+ (cond
+ ((and
+ (or (= index 0) (= index 2))
+ (context-coloring-elisp-identifier-p syntax-code))
+ ;; Add the first or third name to the scope.
+ (context-coloring-elisp-parse-bindable
+ (lambda (variable)
+ (context-coloring-elisp-add-variable variable))))
+ (t
+ ;; Color artifacts.
+ (context-coloring-elisp-colorize-sexp)))
+ (context-coloring-elisp-forward-sws)
+ (setq index (1+ index)))
+ ;; Exit.
+ (forward-char))))))
+
+ (defun context-coloring-elisp-colorize-quote ()
+ "Color the `quote' at point."
+ (let* ((start (point))
+ (end (progn (forward-sexp)
+ (point))))
+ (context-coloring-colorize-region
+ start
+ end
+ (context-coloring-elisp-get-current-scope-level))
+ (context-coloring-elisp-colorize-comments-and-strings-in-region start end)))
+
+ (defvar context-coloring-elisp-callee-dispatch-hash-table
+ (let ((table (make-hash-table :test 'equal)))
+ (dolist (callee '("defun" "defun*" "defsubst" "defmacro" "cl-defun" "cl-defsubst" "cl-defmacro"))
+ (puthash callee #'context-coloring-elisp-colorize-defun table))
+ (dolist (callee '("condition-case" "condition-case-unless-debug"))
+ (puthash callee #'context-coloring-elisp-colorize-condition-case table))
+ (dolist (callee '("dolist" "dotimes"))
+ (puthash callee #'context-coloring-elisp-colorize-dolist table))
+ (puthash "let" #'context-coloring-elisp-colorize-let table)
+ (puthash "let*" #'context-coloring-elisp-colorize-let* table)
+ (puthash "lambda" #'context-coloring-elisp-colorize-lambda table)
+ (puthash "cond" #'context-coloring-elisp-colorize-cond table)
+ (puthash "defadvice" #'context-coloring-elisp-colorize-defadvice table)
+ (puthash "quote" #'context-coloring-elisp-colorize-quote table)
+ (puthash "backquote" #'context-coloring-elisp-colorize-backquote table)
+ table)
+ "Map function names to their coloring functions.")
+
+ (defun context-coloring-elisp-colorize-parenthesized-sexp ()
+ "Color the sexp enclosed by parenthesis at point."
+ (context-coloring-elisp-increment-sexp-count)
+ (let* ((start (point))
+ (end (progn (forward-sexp)
+ (point)))
+ (syntax-code (progn (goto-char start)
+ (forward-char)
+ ;; Coloring is unnecessary here, it'll happen
+ ;; presently.
+ (context-coloring-forward-sws)
+ (context-coloring-get-syntax-code)))
+ dispatch-function)
+ ;; Figure out if the sexp is a special form.
+ (cond
+ ((and (context-coloring-elisp-identifier-p syntax-code)
+ (setq dispatch-function (gethash
+ (buffer-substring-no-properties
+ (point)
+ (progn (forward-sexp)
+ (point)))
+ context-coloring-elisp-callee-dispatch-hash-table)))
+ (goto-char start)
+ (funcall dispatch-function))
+ ;; Not a special form; just colorize the remaining region.
+ (t
+ (context-coloring-colorize-region
+ start
+ end
+ (context-coloring-elisp-get-current-scope-level))
+ (context-coloring-elisp-colorize-region (point) (1- end))
+ (forward-char)))))
+
+ (defun context-coloring-elisp-colorize-symbol ()
+ "Color the symbol at point."
+ (context-coloring-elisp-increment-sexp-count)
+ (let* ((symbol-pos (point))
+ (symbol-end (progn (forward-sexp)
+ (point)))
+ (symbol-string (buffer-substring-no-properties
+ symbol-pos
+ symbol-end)))
+ (cond
+ ((string-match-p context-coloring-elisp-ignored-word-regexp symbol-string))
+ (t
+ (context-coloring-colorize-region
+ symbol-pos
+ symbol-end
+ (context-coloring-elisp-get-variable-level
+ symbol-string))))))
+
+ (defun context-coloring-elisp-colorize-backquote-form ()
+ "Color the backquote form at point."
+ (let ((start (point))
+ (end (progn (forward-sexp)
+ (point)))
+ char)
+ (goto-char start)
+ (while (> end (progn (forward-char)
+ (point)))
+ (setq char (char-after))
+ (when (= char context-coloring-COMMA-CHAR)
+ (forward-char)
+ (when (= (char-after) context-coloring-AT-CHAR)
+ ;; If we don't do this "@" could be interpreted as a symbol.
+ (forward-char))
+ (context-coloring-elisp-forward-sws)
+ (context-coloring-elisp-colorize-sexp)))
+ ;; We could probably do this as part of the above loop but it'd be
+ ;; repetitive.
+ (context-coloring-elisp-colorize-comments-and-strings-in-region
+ start end)))
+
+ (defun context-coloring-elisp-colorize-backquote ()
+ "Color the `backquote' at point."
+ (context-coloring-elisp-skip-callee-name)
+ (context-coloring-elisp-colorize-backquote-form)
+ ;; Exit.
+ (forward-char))
+
+ (defun context-coloring-elisp-colorize-expression-prefix ()
+ "Color the expression prefix and the following expression at
+ point. It could be a quoted or backquoted expression."
+ (context-coloring-elisp-increment-sexp-count)
+ (cond
+ ((/= (char-after) context-coloring-BACKTICK-CHAR)
+ (context-coloring-elisp-forward-sexp))
+ (t
+ (context-coloring-elisp-colorize-backquote-form))))
+
+ (defun context-coloring-elisp-colorize-comment ()
+ "Color the comment at point."
+ (context-coloring-elisp-increment-sexp-count)
+ (context-coloring-elisp-forward-sws))
+
+ (defun context-coloring-elisp-colorize-string ()
+ "Color the string at point."
+ (context-coloring-elisp-increment-sexp-count)
+ (let ((start (point)))
+ (forward-sexp)
+ (context-coloring-colorize-comments-and-strings start (point))))
+
+ ;; Elisp has whitespace, words, symbols, open/close parenthesis, expression
+ ;; prefix, string quote, comment starters/enders and escape syntax classes only.
+
+ (defun context-coloring-elisp-colorize-sexp ()
+ "Color the sexp at point."
+ (let ((syntax-code (context-coloring-get-syntax-code)))
+ (cond
+ ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
+ (context-coloring-elisp-colorize-parenthesized-sexp))
+ ((context-coloring-elisp-identifier-p syntax-code)
+ (context-coloring-elisp-colorize-symbol))
+ ((= syntax-code context-coloring-EXPRESSION-PREFIX-CODE)
+ (context-coloring-elisp-colorize-expression-prefix))
+ ((= syntax-code context-coloring-STRING-QUOTE-CODE)
+ (context-coloring-elisp-colorize-string))
+ ((= syntax-code context-coloring-ESCAPE-CODE)
+ (forward-char 2)))))
+
+ (defun context-coloring-elisp-colorize-comments-and-strings-in-region (start end)
+ "Color comments and strings between START and END."
+ (let (syntax-code)
+ (goto-char start)
+ (while (> end (progn (skip-syntax-forward "^\"<\\" end)
+ (point)))
+ (setq syntax-code (context-coloring-get-syntax-code))
+ (cond
+ ((= syntax-code context-coloring-STRING-QUOTE-CODE)
+ (context-coloring-elisp-colorize-string))
+ ((= syntax-code context-coloring-COMMENT-START-CODE)
+ (context-coloring-elisp-colorize-comment))
+ ((= syntax-code context-coloring-ESCAPE-CODE)
+ (forward-char 2))))))
+
+ (defun context-coloring-elisp-colorize-region (start end)
+ "Color everything between START and END."
+ (let (syntax-code)
+ (goto-char start)
+ (while (> end (progn (skip-syntax-forward "^w_('\"<\\" end)
+ (point)))
+ (setq syntax-code (context-coloring-get-syntax-code))
+ (cond
+ ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
+ (context-coloring-elisp-colorize-parenthesized-sexp))
+ ((context-coloring-elisp-identifier-p syntax-code)
+ (context-coloring-elisp-colorize-symbol))
+ ((= syntax-code context-coloring-EXPRESSION-PREFIX-CODE)
+ (context-coloring-elisp-colorize-expression-prefix))
+ ((= syntax-code context-coloring-STRING-QUOTE-CODE)
+ (context-coloring-elisp-colorize-string))
+ ((= syntax-code context-coloring-COMMENT-START-CODE)
+ (context-coloring-elisp-colorize-comment))
+ ((= syntax-code context-coloring-ESCAPE-CODE)
+ (forward-char 2))))))
+
+ (defun context-coloring-elisp-colorize-region-initially (start end)
+ "Begin coloring everything between START and END."
+ (setq context-coloring-elisp-sexp-count 0)
+ (setq context-coloring-elisp-scope-stack '())
+ (let ((inhibit-point-motion-hooks t)
+ (case-fold-search nil)
+ ;; This is a recursive-descent parser, so give it a big stack.
+ (max-lisp-eval-depth (max max-lisp-eval-depth 3000))
+ (max-specpdl-size (max max-specpdl-size 3000)))
+ (context-coloring-elisp-colorize-region start end)))
+
+ (defun context-coloring-elisp-colorize ()
+ "Color the current buffer, parsing elisp to determine its
+ scopes and variables."
+ (interactive)
(with-silent-modifications
(save-excursion
- ;; TODO: Can probably make this lazy to the nearest defun.
- (goto-char (point-min))
- (let* ((inhibit-point-motion-hooks t)
- (end (point-max))
- (iteration-count 0)
- (last-fontified-position (point))
- beginning-of-current-defun
- end-of-current-defun
- (last-ppss-pos (point))
- (ppss (syntax-ppss))
- ppss-depth
- ;; -1 never matches a depth. This is a minor optimization.
- (scope-stack `(,(context-coloring-make-scope -1 0)))
- (backtick-stack '())
- (let-varlist-stack '())
- (let-var-stack '())
- popped-vars
- one-word-found-p
- in-defun-p
- in-lambda-p
- in-let-p
- in-let*-p
- defun-arglist
- defun-arg
- let-varlist
- let-varlist-type
- variable
- variable-end
- variable-string
- variable-scope-level
- token-pos
- token-syntax
- token-syntax-code
- token-char
- child-0-pos
- child-0-end
- child-0-syntax
- child-0-syntax-code
- child-0-string
- child-1-pos
- child-1-end
- child-1-syntax
- child-1-syntax-code
- child-2-end)
- (while (> end (progn (skip-syntax-forward "^()w_'" end)
- (point)))
- ;; Sparingly-executed tasks.
- (setq iteration-count (1+ iteration-count))
- (when (zerop (% iteration-count
- context-coloring-emacs-lisp-iterations-per-pause))
- ;; Fontify until the end of the current defun because doing it in
- ;; chunks based soley on point could result in partial
- ;; re-fontifications over the contents of scopes.
- (save-excursion
- (end-of-defun)
- (setq end-of-current-defun (point))
- (beginning-of-defun)
- (setq beginning-of-current-defun (point)))
-
- ;; Fontify in chunks.
- (context-coloring-maybe-colorize-comments-and-strings
- last-fontified-position
- (cond
- ;; We weren't actually in a defun, so don't color the next one, as
- ;; that could result in `font-lock' properties being added to it.
- ((> beginning-of-current-defun (point))
- (point))
- (t
- end-of-current-defun)))
- (setq last-fontified-position (point))
- (when (and context-coloring-parse-interruptable-p
- (input-pending-p))
- (throw 'interrupted t)))
-
- (setq token-pos (point))
- (setq token-syntax (syntax-after token-pos))
- (setq token-syntax-code (logand #xFFFF (car token-syntax)))
- (setq token-char (char-after))
- (setq ppss (parse-partial-sexp last-ppss-pos token-pos nil nil ppss))
- (setq last-ppss-pos token-pos)
+ (condition-case nil
(cond
-
- ;; Resolve an invalid state.
- ((cond
- ;; Inside string?
- ((nth 3 ppss)
- (skip-syntax-forward "^\"" end)
- (forward-char)
- t)
- ;; Inside comment?
- ((nth 4 ppss)
- (skip-syntax-forward "^>" end)
- t)))
-
- ;; Need to check early in case there's a comma.
- ((context-coloring-expression-prefix-p token-syntax-code)
- (forward-char)
- (cond
- ;; Skip top-level symbols.
- ((not (or backtick-stack
- (= token-char context-coloring-BACKTICK-CHAR)))
- (goto-char (context-coloring-forward-sexp-position)))
- ;; Push a backtick state.
- ((or (= token-char context-coloring-BACKTICK-CHAR)
- (= token-char context-coloring-COMMA-CHAR))
- (setq backtick-stack (cons (context-coloring-make-backtick
- (context-coloring-forward-sexp-position)
- (= token-char context-coloring-BACKTICK-CHAR))
- backtick-stack)))))
-
- ;; Pop a backtick state.
- ((and backtick-stack
- (>= (point) (context-coloring-backtick-get-end (car backtick-stack))))
- (setq backtick-stack (cdr backtick-stack)))
-
- ;; Restricted by an enabled backtick.
- ((and backtick-stack
- (context-coloring-backtick-enabled-p backtick-stack))
- (forward-char))
-
- ((context-coloring-open-parenthesis-p token-syntax-code)
- (forward-char)
- ;; Look for function calls.
- (context-coloring-forward-sws)
- (setq child-0-pos (point))
- (setq child-0-syntax (syntax-after child-0-pos))
- (setq child-0-syntax-code (logand #xFFFF (car child-0-syntax)))
- (cond
- ((context-coloring-emacs-lisp-identifier-syntax-p child-0-syntax-code)
- (setq one-word-found-p t)
- (setq child-0-end (scan-sexps child-0-pos 1))
- (setq child-0-string (buffer-substring-no-properties child-0-pos child-0-end))
- (cond
- ;; Parse a var in a `let' varlist.
- ((and
- let-varlist-stack
- (context-coloring-at-stack-depth-p
- let-varlist-stack
- ;; 1- because we're inside the varlist.
- (1- (context-coloring-ppss-depth ppss))))
- (context-coloring-let-varlist-add-var
- (car let-varlist-stack)
- (intern child-0-string))
- (setq let-var-stack (cons (context-coloring-ppss-depth ppss)
- let-var-stack)))
- ((string-match-p context-coloring-emacs-lisp-defun-regexp child-0-string)
- (setq in-defun-p t))
- ((string-match-p context-coloring-emacs-lisp-lambda-regexp child-0-string)
- (setq in-lambda-p t))
- ((string-match-p context-coloring-emacs-lisp-let-regexp child-0-string)
- (setq in-let-p t)
- (setq let-varlist-type 'let))
- ((string-match-p context-coloring-emacs-lisp-let*-regexp child-0-string)
- (setq in-let*-p t)
- (setq let-varlist-type 'let*)))))
- (when (or in-defun-p
- in-lambda-p
- in-let-p
- in-let*-p)
- (setq scope-stack (cons (context-coloring-make-scope
- (context-coloring-ppss-depth ppss)
- (1+ (context-coloring-scope-get-level
- (car scope-stack))))
- scope-stack)))
- ;; TODO: Maybe wasteful but doing this conditionally doesn't make
- ;; much of a difference.
- (context-coloring-colorize-region token-pos
- (scan-sexps token-pos 1)
- (context-coloring-scope-get-level
- (car scope-stack)))
- (cond
- ((or in-defun-p
- in-lambda-p)
- (goto-char child-0-end)
- (when in-defun-p
- ;; Look for a function name.
- (context-coloring-forward-sws)
- (setq child-1-pos (point))
- (setq child-1-syntax (syntax-after child-1-pos))
- (setq child-1-syntax-code (logand #xFFFF (car child-1-syntax)))
- (cond
- ((context-coloring-emacs-lisp-identifier-syntax-p child-1-syntax-code)
- (setq child-1-end (scan-sexps child-1-pos 1))
- ;; Defuns are global, so use level 0.
- (context-coloring-colorize-region child-1-pos child-1-end 0)
- (goto-char child-1-end))))
- ;; Look for an arglist.
- (context-coloring-forward-sws)
- (when (context-coloring-at-open-parenthesis-p)
- ;; (Actually it should be `child-1-end' for `lambda'.)
- (setq child-2-end (context-coloring-forward-sexp-position))
- (setq defun-arglist (read (buffer-substring-no-properties
- (point)
- child-2-end)))
- (while defun-arglist
- (setq defun-arg (car defun-arglist))
- (when (and (symbolp defun-arg)
- (string-match-p
- context-coloring-arglist-arg-regexp
- (symbol-name defun-arg)))
- (context-coloring-scope-add-variable
- (car scope-stack)
- defun-arg))
- (setq defun-arglist (cdr defun-arglist)))
- (goto-char child-2-end))
- ;; Cleanup.
- (setq in-defun-p nil)
- (setq in-lambda-p nil))
- ((or in-let-p
- in-let*-p)
- (goto-char child-0-end)
- ;; Look for a varlist.
- (context-coloring-forward-sws)
- (setq child-1-pos (point))
- (setq child-1-syntax (syntax-after child-1-pos))
- (setq child-1-syntax-code (logand #xFFFF (car child-1-syntax)))
- (when (context-coloring-open-parenthesis-p child-1-syntax-code)
- ;; Begin parsing the varlist.
- (forward-char)
- (setq let-varlist-stack (cons (context-coloring-make-let-varlist
- ;; 1+ because we parsed it at a
- ;; higher depth.
- (1+ (context-coloring-ppss-depth ppss))
- let-varlist-type)
- let-varlist-stack)))
- ;; Cleanup.
- (setq in-let-p nil)
- (setq in-let*-p nil))
- (t
- (goto-char (cond
- ;; If there was a word, continue parsing after it.
- (one-word-found-p
- (1+ child-0-end))
- (t
- (1+ token-pos))))))
- ;; Cleanup.
- (setq one-word-found-p nil))
-
- ((context-coloring-emacs-lisp-identifier-syntax-p token-syntax-code)
- (setq variable-end (context-coloring-forward-sexp-position))
- (setq variable-string (buffer-substring-no-properties
- token-pos
- variable-end))
- (cond
- ;; Ignore constants such as numbers, keywords, t, nil. These can't
- ;; be rebound, so they should be treated like syntax.
- ((string-match-p context-coloring-ignored-word-regexp variable-string))
- ((keywordp (read variable-string)))
- (t
- (setq variable (intern variable-string))
- (cond
- ;; Parse a `let' varlist's uninitialized var.
- ((and
- let-varlist-stack
- (context-coloring-at-stack-depth-p
- let-varlist-stack
- ;; 1- because we're inside the varlist.
- (1- (context-coloring-ppss-depth ppss))))
- (setq let-varlist (car let-varlist-stack))
- (setq let-varlist-type (context-coloring-let-varlist-get-type let-varlist))
- (cond
- ;; Defer `let' binding until the end of the varlist.
- ((eq let-varlist-type 'let)
- (context-coloring-let-varlist-add-var let-varlist variable))
- ;; Bind a `let*' right away.
- ((eq let-varlist-type 'let*)
- (context-coloring-scope-add-variable (car scope-stack) variable))))
- (t
- (setq variable-scope-level
- (context-coloring-get-variable-level scope-stack variable))
- (when (/= variable-scope-level (context-coloring-scope-get-level
- (car scope-stack)))
- (context-coloring-colorize-region
- token-pos
- variable-end
- variable-scope-level))))))
- (goto-char variable-end))
-
- ((context-coloring-close-parenthesis-p token-syntax-code)
- (forward-char)
- (setq ppss (parse-partial-sexp last-ppss-pos (point) nil nil ppss))
- (setq last-ppss-pos (point))
- (setq ppss-depth (context-coloring-ppss-depth ppss))
- ;; TODO: Order might matter here but I'm not certain.
- (when (context-coloring-at-stack-depth-p scope-stack ppss-depth)
- (setq scope-stack (cdr scope-stack)))
- (when (and
- let-var-stack
- (= (car let-var-stack) ppss-depth))
- (setq let-var-stack (cdr let-var-stack))
- (when (eq (context-coloring-let-varlist-get-type (car let-varlist-stack))
- 'let*)
- (setq popped-vars (context-coloring-let-varlist-pop-vars
- (car let-varlist-stack)))))
- (when (and
- let-varlist-stack
- (context-coloring-at-stack-depth-p let-varlist-stack ppss-depth))
- (setq popped-vars (context-coloring-let-varlist-pop-vars
- (car let-varlist-stack)))
- (setq let-varlist-stack (cdr let-varlist-stack)))
- (while popped-vars
- (context-coloring-scope-add-variable (car scope-stack) (car popped-vars))
- (setq popped-vars (cdr popped-vars))))
-
- ))
- ;; Fontify the last stretch.
- (context-coloring-maybe-colorize-comments-and-strings
- last-fontified-position
- (point))))))
+ ;; Just colorize the changed region.
+ (context-coloring-changed-p
+ (let* (;; Prevent `beginning-of-defun' from making poor assumptions.
+ (open-paren-in-column-0-is-defun-start nil)
+ ;; Seek the beginning and end of the previous and next
+ ;; offscreen defuns, so just enough is colored.
+ (start (progn (goto-char context-coloring-changed-start)
+ (while (and (< (point-min) (point))
+ (pos-visible-in-window-p))
+ (end-of-line 0))
+ (beginning-of-defun)
+ (point)))
+ (end (progn (goto-char context-coloring-changed-end)
+ (while (and (> (point-max) (point))
+ (pos-visible-in-window-p))
+ (forward-line 1))
+ (end-of-defun)
+ (point))))
+ (context-coloring-elisp-colorize-region-initially start end)
+ ;; Fast coloring is nice, but if the code is not well-formed
+ ;; (e.g. an unclosed string literal is parsed at any time) then
+ ;; there could be leftover incorrectly-colored code offscreen. So
+ ;; do a clean sweep as soon as appropriate.
+ (context-coloring-schedule-coloring context-coloring-default-delay)))
+ (t
+ (context-coloring-elisp-colorize-region-initially (point-min) (point-max))))
+ ;; Scan errors can happen virtually anywhere if parenthesis are
+ ;; unbalanced. Just swallow them. (`progn' for test coverage.)
+ (scan-error (progn))))))
;;; Shell command scopification / colorization
(defun context-coloring-apply-tokens (tokens)
- "Process a vector of TOKENS to apply context-based coloring to
- the current buffer. Tokens are 3 integers: start, end, level.
- The vector is flat, with a new token occurring after every 3rd
- element."
- (with-silent-modifications
- (let ((i 0)
- (len (length tokens)))
- (while (< i len)
- (context-coloring-colorize-region
- (elt tokens i)
- (elt tokens (+ i 1))
- (elt tokens (+ i 2)))
- (setq i (+ i 3))))
- (context-coloring-maybe-colorize-comments-and-strings)))
+ "Process a string of TOKENS to apply context-based coloring to
+ the current buffer. Tokens are 3 integers: start, end, level. A
+ new token occurrs after every 3rd element, and the elements are
+ separated by commas."
+ (let* ((tokens (mapcar #'string-to-number (split-string tokens ","))))
+ (while tokens
+ (context-coloring-colorize-region
+ (pop tokens)
+ (pop tokens)
+ (pop tokens))))
+ (context-coloring-colorize-comments-and-strings))
(defun context-coloring-parse-array (array)
- "Parse ARRAY as a flat JSON array of numbers."
- (let ((braceless (substring (context-coloring-trim array) 1 -1)))
- (cond
- ((> (length braceless) 0)
- (vconcat
- (mapcar 'string-to-number (split-string braceless ","))))
- (t
- (vector)))))
+ "Parse ARRAY as a flat JSON array of numbers and use the tokens
+ to colorize the buffer."
+ (let* ((braceless (substring-no-properties (context-coloring-trim array) 1 -1)))
+ (when (> (length braceless) 0)
+ (with-silent-modifications
+ (context-coloring-apply-tokens braceless)))))
+
+ (defvar-local context-coloring-scopifier-cancel-function nil
+ "Kills the current scopification process.")
(defvar-local context-coloring-scopifier-process nil
"The single scopifier process that can be running.")
- (defun context-coloring-kill-scopifier ()
- "Kill the currently-running scopifier process."
+ (defun context-coloring-cancel-scopification ()
+ "Stop the currently-running scopifier from scopifying."
+ (when context-coloring-scopifier-cancel-function
+ (funcall context-coloring-scopifier-cancel-function)
+ (setq context-coloring-scopifier-cancel-function nil))
(when (not (null context-coloring-scopifier-process))
(delete-process context-coloring-scopifier-process)
(setq context-coloring-scopifier-process nil)))
- (defun context-coloring-scopify-shell-command (command callback)
- "Invoke a scopifier via COMMAND, read its response
- asynchronously and invoke CALLBACK with its output."
-
- ;; Prior running tokenization is implicitly obsolete if this function is
- ;; called.
- (context-coloring-kill-scopifier)
-
- ;; Start the process.
- (setq context-coloring-scopifier-process
- (start-process-shell-command "scopifier" nil command))
-
- (let ((output ""))
-
+ (defun context-coloring-shell-command (command callback)
+ "Invoke COMMAND, read its response asynchronously and invoke
+ CALLBACK with its output. Return the command process."
+ (let ((process (start-process-shell-command "context-coloring-process" nil command))
+ (output ""))
;; The process may produce output in multiple chunks. This filter
;; accumulates the chunks into a message.
(set-process-filter
- context-coloring-scopifier-process
+ process
(lambda (_process chunk)
(setq output (concat output chunk))))
-
;; When the process's message is complete, this sentinel parses it as JSON
;; and applies the tokens to the buffer.
(set-process-sentinel
- context-coloring-scopifier-process
+ process
(lambda (_process event)
(when (equal "finished\n" event)
- (funcall callback output))))))
+ (funcall callback output))))
+ process))
+
+ (defun context-coloring-scopify-shell-command (command callback)
+ "Invoke a scopifier via COMMAND, read its response
+ asynchronously and invoke CALLBACK with its output."
+ ;; Prior running tokenization is implicitly obsolete if this function is
+ ;; called.
+ (context-coloring-cancel-scopification)
+ ;; Start the process.
+ (setq context-coloring-scopifier-process
+ (context-coloring-shell-command command callback)))
(defun context-coloring-send-buffer-to-scopifier ()
"Give the scopifier process its input so it can begin
(process-send-eof
context-coloring-scopifier-process))
- (defun context-coloring-scopify-and-colorize (command &optional callback)
- "Invoke a scopifier via COMMAND with the current buffer's contents,
- read the scopifier's response asynchronously and apply a parsed
- list of tokens to `context-coloring-apply-tokens'.
+ (defun context-coloring-start-scopifier-server (command host port callback)
+ "Connect to or start a scopifier server with COMMAND, HOST and PORT.
+ Invoke CALLBACK with a network stream when the server is ready
+ for connections."
+ (let* ((connect
+ (lambda ()
+ (let ((stream (open-network-stream "context-coloring-stream" nil host port)))
+ (funcall callback stream)))))
+ ;; Try to connect in case a server is running, otherwise start one.
+ (condition-case nil
+ (progn
+ (funcall connect))
+ (error
+ (let ((server (start-process-shell-command
+ "context-coloring-scopifier-server" nil
+ (context-coloring-join
+ (list command
+ "--server"
+ "--host" host
+ "--port" (number-to-string port))
+ " ")))
+ (output ""))
+ ;; Connect as soon as the "listening" message is printed.
+ (set-process-filter
+ server
+ (lambda (_process chunk)
+ (setq output (concat output chunk))
+ (when (string-match-p (format "^Scopifier listening at %s:%s$" host port) output)
+ (funcall connect)))))))))
+
+ (defun context-coloring-send-buffer-to-scopifier-server (command host port callback)
+ "Send the current buffer to the scopifier server running with
+ COMMAND, HOST and PORT. Invoke CALLBACK with the server's
+ response (a stringified JSON array)."
+ (context-coloring-start-scopifier-server
+ command host port
+ (lambda (process)
+ (let* ((body (buffer-substring-no-properties (point-min) (point-max)))
+ (header (concat "POST / HTTP/1.0\r\n"
+ "Host: localhost\r\n"
+ "Content-Type: application/x-www-form-urlencoded"
+ "; charset=UTF8\r\n"
+ (format "Content-Length: %d\r\n" (length body))
+ "\r\n"))
+ (output "")
+ (active t))
+ (set-process-filter
+ process
+ (lambda (_process chunk)
+ (setq output (concat output chunk))))
+ (set-process-sentinel
+ process
+ (lambda (_process event)
+ (when (and (equal "connection broken by remote peer\n" event)
+ active)
+ ;; Strip the response headers.
+ (string-match "\r\n\r\n" output)
+ (setq output (substring-no-properties output (match-end 0)))
+ (funcall callback output))))
+ (process-send-string process (concat header body "\r\n"))
+ (setq context-coloring-scopifier-cancel-function
+ (lambda ()
+ "Cancel this scopification."
+ (setq active nil)))))))
+
+ (defun context-coloring-scopify-and-colorize-server (command host port &optional callback)
+ "Color the current buffer via the server started with COMMAND,
+ HOST and PORT. Invoke CALLBACK when complete."
+ (let ((buffer (current-buffer)))
+ (context-coloring-send-buffer-to-scopifier-server
+ command host port
+ (lambda (output)
+ (with-current-buffer buffer
+ (context-coloring-parse-array output))
+ (when callback (funcall callback))))))
- Invoke CALLBACK when complete."
+ (defun context-coloring-scopify-and-colorize (command &optional callback)
+ "Color the current buffer via COMMAND. Invoke CALLBACK when
+ complete."
(let ((buffer (current-buffer)))
(context-coloring-scopify-shell-command
command
(lambda (output)
- (let ((tokens (context-coloring-parse-array output)))
- (with-current-buffer buffer
- (context-coloring-apply-tokens tokens))
- (setq context-coloring-scopifier-process nil)
- (when callback (funcall callback))))))
+ (with-current-buffer buffer
+ (context-coloring-parse-array output))
+ (setq context-coloring-scopifier-process nil)
+ (when callback (funcall callback)))))
(context-coloring-send-buffer-to-scopifier))
;;; Dispatch
- (defvar context-coloring-dispatch-hash-table (make-hash-table :test 'eq)
+ (defvar context-coloring-dispatch-hash-table (make-hash-table :test #'eq)
"Map dispatch strategy names to their corresponding property
- lists, which contain details about the strategies.")
+ lists, which contain details about the strategies.")
- (defvar context-coloring-mode-hash-table (make-hash-table :test 'eq)
+ (defvar context-coloring-mode-hash-table (make-hash-table :test #'eq)
"Map major mode names to dispatch property lists.")
(defun context-coloring-get-dispatch-for-mode (mode)
A \"dispatch\" is a property list describing a strategy for
coloring a buffer. There are three possible strategies: Parse
- and color in a single function (`:colorizer'), parse in a
- function that returns scope data (`:scopifier'), or parse with a
- shell command that returns scope data (`:command'). In the
- latter two cases, the scope data will be used to automatically
- color the buffer.
+ and color in a single function (`:colorizer'), parse with a shell
+ command that returns scope data (`:command'), or parse with a
+ server that returns scope data (`:command', `:host' and `:port').
+ In the latter two cases, the scope data will be used to
+ automatically color the buffer.
PROPERTIES must include `:modes' and one of `:colorizer',
`:scopifier' or `:command'.
`:colorizer' - Symbol referring to a function that parses and
colors the buffer.
- `:scopifier' - Symbol referring to a function that parses the
- buffer a returns a flat vector of start, end and level data.
-
`:executable' - Optional name of an executable required by
`:command'.
sent via stdin, and with a flat JSON array of start, end and
level data returned via stdout.
+ `:host' - Hostname of the scopifier server, e.g. \"localhost\".
+
+ `:port' - Port number of the scopifier server, e.g. 80, 1337.
+
+ `:delay' - Delay between buffer update and colorization, to
+ override `context-coloring-default-delay'.
+
`:version' - Minimum required version that should be printed when
executing `:command' with a \"--version\" flag. The version
should be numeric, e.g. \"2\", \"19700101\", \"1.2.3\",
`context-coloring-mode' is disabled."
(let ((modes (plist-get properties :modes))
(colorizer (plist-get properties :colorizer))
- (scopifier (plist-get properties :scopifier))
(command (plist-get properties :command)))
(when (null modes)
(error "No mode defined for dispatch"))
(when (not (or colorizer
- scopifier
command))
- (error "No colorizer, scopifier or command defined for dispatch"))
+ (error "No colorizer or command defined for dispatch"))
(puthash symbol properties context-coloring-dispatch-hash-table)
(dolist (mode modes)
(puthash mode properties context-coloring-mode-hash-table))))
(when callback (funcall callback))
(run-hooks 'context-coloring-colorize-hook))))
- (defvar-local context-coloring-changed nil
- "Indication that the buffer has changed recently, which implies
- that it should be colored again by
- `context-coloring-colorize-idle-timer' if that timer is being
- used.")
-
- (defun context-coloring-change-function (_start _end _length)
- "Register a change so that a buffer can be colorized soon."
- ;; Tokenization is obsolete if there was a change.
- (context-coloring-kill-scopifier)
- (setq context-coloring-changed t))
-
- (defun context-coloring-maybe-colorize (buffer)
- "Colorize the current buffer if it has changed."
- (when (and (eq buffer (current-buffer))
- context-coloring-changed)
- (setq context-coloring-changed nil)
- (context-coloring-colorize)))
+ (defun context-coloring-colorize-with-buffer (buffer)
+ "Color BUFFER."
+ ;; Don't select deleted buffers.
+ (when (get-buffer buffer)
+ (with-current-buffer buffer
+ (context-coloring-colorize))))
;;; Versioning
(when dispatch
(let ((version (plist-get dispatch :version))
(command (plist-get dispatch :command)))
- (context-coloring-scopify-shell-command
+ (context-coloring-shell-command
(context-coloring-join (list command "--version") " ")
(lambda (output)
- (if (context-coloring-check-version version output)
- (progn
- (when callback (funcall callback t)))
- (when callback (funcall callback nil)))
+ (cond
+ ((context-coloring-check-version version output)
+ (when callback (funcall callback t)))
+ (t
+ (when callback (funcall callback nil))))
(run-hooks 'context-coloring-check-scopifier-version-hook)))))))
;;; Themes
- (defvar context-coloring-theme-hash-table (make-hash-table :test 'eq)
+ (defvar context-coloring-theme-hash-table (make-hash-table :test #'eq)
"Map theme names to theme properties.")
(defun context-coloring-theme-p (theme)
"Extract a level from a face.")
(defvar context-coloring-originally-set-theme-hash-table
- (make-hash-table :test 'eq)
+ (make-hash-table :test #'eq)
"Cache custom themes who originally set their own
- `context-coloring-level-N-face' faces.")
+ `context-coloring-level-N-face' faces.")
(defun context-coloring-theme-originally-set-p (theme)
"Return t if there is a `context-coloring-level-N-face'
(when (custom-theme-enabled-p theme)
(setq context-coloring-maximum-face (- (length colors) 1)))
(apply
- 'custom-theme-set-faces
+ #'custom-theme-set-faces
theme
(mapcar
(lambda (color)
"Update `context-coloring-maximum-face'."
(when (custom-theme-p theme) ; Guard against non-existent themes.
(let ((enabled-theme (car custom-enabled-themes)))
- (if (context-coloring-theme-p enabled-theme)
- (progn
- (context-coloring-enable-theme enabled-theme))
+ (cond
+ ((context-coloring-theme-p enabled-theme)
+ (context-coloring-enable-theme enabled-theme))
+ (t
;; Assume we are back to no theme; act as if nothing ever happened.
;; This is still prone to intervention, but rather extraordinarily.
(setq context-coloring-maximum-face
- context-coloring-original-maximum-face)))))
+ context-coloring-original-maximum-face))))))
(context-coloring-define-theme
'ample
"#dca3a3"))
- ;;; Change detection
-
- (defvar-local context-coloring-colorize-idle-timer nil
- "The currently-running idle timer.")
-
- (defcustom context-coloring-delay 0.25
- "Delay between a buffer update and colorization.
-
- Increase this if your machine is high-performing. Decrease it if
- it ain't.
-
- Supported modes: `js-mode', `js3-mode', `emacs-lisp-mode'"
- :group 'context-coloring)
-
- (defun context-coloring-setup-idle-change-detection ()
- "Setup idle change detection."
- (add-hook
- 'after-change-functions 'context-coloring-change-function nil t)
- (add-hook
- 'kill-buffer-hook 'context-coloring-teardown-idle-change-detection nil t)
- (setq context-coloring-colorize-idle-timer
- (run-with-idle-timer
- context-coloring-delay
- t
- 'context-coloring-maybe-colorize
- (current-buffer))))
-
- (defun context-coloring-teardown-idle-change-detection ()
- "Teardown idle change detection."
- (context-coloring-kill-scopifier)
- (when context-coloring-colorize-idle-timer
- (cancel-timer context-coloring-colorize-idle-timer))
- (remove-hook
- 'kill-buffer-hook 'context-coloring-teardown-idle-change-detection t)
- (remove-hook
- 'after-change-functions 'context-coloring-change-function t))
-
-
;;; Built-in dispatches
(context-coloring-define-dispatch
:modes '(js-mode js3-mode)
:executable "scopifier"
:command "scopifier"
- :version "v1.1.1")
+ :version "v1.2.1"
+ :host "localhost"
+ :port 6969)
(context-coloring-define-dispatch
'javascript-js2
:modes '(js2-mode)
- :colorizer 'context-coloring-js2-colorize
+ :colorizer #'context-coloring-js2-colorize
:setup
(lambda ()
- (add-hook 'js2-post-parse-callbacks 'context-coloring-colorize nil t))
+ (add-hook 'js2-post-parse-callbacks #'context-coloring-colorize nil t))
:teardown
(lambda ()
- (remove-hook 'js2-post-parse-callbacks 'context-coloring-colorize t)))
+ (remove-hook 'js2-post-parse-callbacks #'context-coloring-colorize t)))
(context-coloring-define-dispatch
'emacs-lisp
:modes '(emacs-lisp-mode)
- :colorizer 'context-coloring-emacs-lisp-colorize
- :setup 'context-coloring-setup-idle-change-detection
- :teardown 'context-coloring-teardown-idle-change-detection)
+ :colorizer #'context-coloring-elisp-colorize
+ :delay 0.016 ;; Thanks to lazy colorization this can be 60 frames per second.
+ :setup #'context-coloring-setup-idle-change-detection
+ :teardown #'context-coloring-teardown-idle-change-detection)
(defun context-coloring-dispatch (&optional callback)
"Determine the optimal track for scopification / coloring of
elisp tracks, and asynchronously for shell command tracks."
(let* ((dispatch (context-coloring-get-dispatch-for-mode major-mode))
(colorizer (plist-get dispatch :colorizer))
- (scopifier (plist-get dispatch :scopifier))
(command (plist-get dispatch :command))
+ (host (plist-get dispatch :host))
+ (port (plist-get dispatch :port))
interrupted-p)
(cond
- ((or colorizer scopifier)
+ (colorizer
(setq interrupted-p
(catch 'interrupted
- (cond
- (colorizer
- (funcall colorizer))
- (scopifier
- (context-coloring-apply-tokens (funcall scopifier))))))
+ (funcall colorizer)))
+ (when (and (not interrupted-p)
+ callback)
+ (funcall callback)))
+ (command
(cond
- (interrupted-p
- (setq context-coloring-changed t))
+ ((and host port)
+ (context-coloring-scopify-and-colorize-server command host port callback))
(t
- (when callback (funcall callback)))))
- (command
- (context-coloring-scopify-and-colorize command callback)))))
+ (context-coloring-scopify-and-colorize command callback)))))))
;;; Minor mode
;;;###autoload
(define-minor-mode context-coloring-mode
- "Context-based code coloring, inspired by Douglas Crockford."
+ "Toggle contextual code coloring.
+ With a prefix argument ARG, enable Context Coloring mode if ARG
+ is positive, and disable it otherwise. If called from Lisp,
+ enable the mode if ARG is omitted or nil.
+
+ Context Coloring mode is a buffer-local minor mode. When
+ enabled, code is colored by scope. Scopes are colored
+ hierarchically. Variables referenced from nested scopes retain
+ the color of their defining scopes. Certain syntax, like
+ comments and strings, is still colored with `font-lock'.
+
+ The entire buffer is colored initially. Changes to the buffer
+ trigger recoloring.
+
+ Certain custom themes have predefined colors from their palettes
+ to use for coloring. See `context-coloring-theme-hash-table' for
+ the supported themes. If the currently-enabled custom theme is
+ not among these, you can define colors for it with
+ `context-coloring-define-theme', which see.
+
+ New language / major mode support can be added with
+ `context-coloring-define-dispatch', which see.
+
+ Feature inspired by Douglas Crockford."
nil " Context" nil
- (if (not context-coloring-mode)
- (progn
- (let ((dispatch (context-coloring-get-dispatch-for-mode major-mode)))
- (when dispatch
- (let ((command (plist-get dispatch :command))
- (teardown (plist-get dispatch :teardown)))
- (when command
- (context-coloring-teardown-idle-change-detection))
- (when teardown
- (funcall teardown)))))
- (font-lock-mode)
- (jit-lock-mode t))
-
+ (cond
+ (context-coloring-mode
;; Font lock is incompatible with this mode; the converse is also true.
(font-lock-mode 0)
(jit-lock-mode nil)
-
;; ...but we do use font-lock functions here.
(font-lock-set-defaults)
-
- ;; Safely change the valye of this function as necessary.
+ ;; Safely change the value of this function as necessary.
(make-local-variable 'font-lock-syntactic-face-function)
-
(let ((dispatch (context-coloring-get-dispatch-for-mode major-mode)))
- (if dispatch
- (progn
- (let ((command (plist-get dispatch :command))
- (version (plist-get dispatch :version))
- (executable (plist-get dispatch :executable))
- (setup (plist-get dispatch :setup))
- (colorize-initially-p t))
- (when command
- ;; Shell commands recolor on change, idly.
- (cond
- ((and executable
- (null (executable-find executable)))
- (message "Executable \"%s\" not found" executable)
- (setq colorize-initially-p nil))
- (version
- (context-coloring-check-scopifier-version
- (lambda (sufficient-p)
- (if sufficient-p
- (progn
- (context-coloring-setup-idle-change-detection)
- (context-coloring-colorize))
- (message "Update to the minimum version of \"%s\" (%s)"
- executable version))))
- (setq colorize-initially-p nil))
- (t
- (context-coloring-setup-idle-change-detection))))
- (when setup
- (funcall setup))
- ;; Colorize once initially.
- (when colorize-initially-p
- (let ((context-coloring-parse-interruptable-p nil))
- (context-coloring-colorize)))))
- (when (null dispatch)
- (message "Context coloring is not available for this major mode"))))))
+ (cond
+ (dispatch
+ (let ((command (plist-get dispatch :command))
+ (version (plist-get dispatch :version))
+ (executable (plist-get dispatch :executable))
+ (setup (plist-get dispatch :setup))
+ (colorize-initially-p t))
+ (when command
+ ;; Shell commands recolor on change, idly.
+ (cond
+ ((and executable
+ (null (executable-find executable)))
+ (message "Executable \"%s\" not found" executable)
+ (setq colorize-initially-p nil))
+ (version
+ (context-coloring-check-scopifier-version
+ (lambda (sufficient-p)
+ (cond
+ (sufficient-p
+ (context-coloring-setup-idle-change-detection)
+ (context-coloring-colorize))
+ (t
+ (message "Update to the minimum version of \"%s\" (%s)"
+ executable version)))))
+ (setq colorize-initially-p nil))
+ (t
+ (context-coloring-setup-idle-change-detection))))
+ (when setup
+ (funcall setup))
+ ;; Colorize once initially.
+ (when colorize-initially-p
+ (let ((context-coloring-parse-interruptable-p nil))
+ (context-coloring-colorize)))))
+ (t
+ (message "Context coloring is not available for this major mode")))))
+ (t
+ (let ((dispatch (context-coloring-get-dispatch-for-mode major-mode)))
+ (when dispatch
+ (let ((command (plist-get dispatch :command))
+ (teardown (plist-get dispatch :teardown)))
+ (when command
+ (context-coloring-teardown-idle-change-detection))
+ (when teardown
+ (funcall teardown)))))
+ (font-lock-mode)
+ (jit-lock-mode t))))
(provide 'context-coloring)
(defun context-coloring-coverage-join (strings delimiter)
"Join a list of STRINGS with the string DELIMITER."
- (mapconcat 'identity strings delimiter))
+ (mapconcat #'identity strings delimiter))
(defun context-coloring-coverage-percentage (dividend divisor)
"Get the percentage of DIVIDEND / DIVISOR with precision 2."
"Generate reports for all files in COVERAGE-DATA."
(context-coloring-coverage-join
(mapcar
- 'context-coloring-coverage-format-source-file
+ #'context-coloring-coverage-format-source-file
(cdr (assq 'source_files coverage-data)))
"\n"))
(setq undercover-force-coverage t)
(setenv "COVERALLS_REPO_TOKEN" "noop")
(undercover "context-coloring.el"
- (:report-file context-coloring-coverage-output-file))
+ (:report-file context-coloring-coverage-output-file)
+ (:send-report nil))
(add-hook
'kill-emacs-hook
(lambda ()
(provide 'context-coloring-coverage)
- ;; context-coloring-coverage.el ends here
+ ;;; context-coloring-coverage.el ends here
;;; Code:
+ (require 'cl-lib)
(require 'context-coloring)
(require 'ert-async)
(require 'js2-mode)
"This file's directory.")
(defun context-coloring-test-read-file (path)
- "Read a file's contents from PATH into a string."
+ "Return the file's contents from PATH as a string."
(with-temp-buffer
(insert-file-contents (expand-file-name path context-coloring-test-path))
(buffer-string)))
- (defun context-coloring-test-setup ()
- "Prepare before all tests."
- (setq context-coloring-syntactic-comments nil)
- (setq context-coloring-syntactic-strings nil))
-
- (defun context-coloring-test-cleanup ()
- "Cleanup after all tests."
- (setq context-coloring-comments-and-strings nil)
- (setq context-coloring-js-block-scopes nil)
- (setq context-coloring-colorize-hook nil)
- (setq context-coloring-check-scopifier-version-hook nil)
- (setq context-coloring-maximum-face 7)
- (setq context-coloring-original-maximum-face
- context-coloring-maximum-face))
-
(defmacro context-coloring-test-with-fixture (fixture &rest body)
"With the relative FIXTURE, evaluate BODY in a temporary
buffer."
`(with-temp-buffer
- (unwind-protect
- (progn
- (context-coloring-test-setup)
- (insert (context-coloring-test-read-file ,fixture))
- ,@body)
- (context-coloring-test-cleanup))))
+ (progn
+ (insert (context-coloring-test-read-file ,fixture))
+ ,@body)))
(defun context-coloring-test-with-temp-buffer-async (callback)
"Create a temporary buffer, and evaluate CALLBACK there. A
(kill-buffer temp-buffer))
(set-buffer previous-buffer)))))
- (defun context-coloring-test-with-fixture-async
- (fixture callback &optional setup)
+ (defun context-coloring-test-with-fixture-async (fixture callback)
"With the relative FIXTURE, evaluate CALLBACK in a temporary
buffer. A teardown callback is passed to CALLBACK for it to
- invoke when it is done. An optional SETUP callback can run
- arbitrary code before the mode is invoked."
+ invoke when it is done."
(context-coloring-test-with-temp-buffer-async
(lambda (done-with-temp-buffer)
- (context-coloring-test-setup)
- (when setup (funcall setup))
(insert (context-coloring-test-read-file fixture))
(funcall
callback
(lambda ()
- (context-coloring-test-cleanup)
(funcall done-with-temp-buffer))))))
;;; Test defining utilities
- (defun context-coloring-test-js-mode (fixture callback &optional setup)
- "Use FIXTURE as the subject matter for test logic in CALLBACK.
- Optionally, provide setup code to run before the mode is
- instantiated in SETUP."
- (context-coloring-test-with-fixture-async
- fixture
- (lambda (done-with-test)
- (js-mode)
- (context-coloring-mode)
- (context-coloring-colorize
- (lambda ()
- (funcall callback done-with-test))))
- setup))
-
- (defmacro context-coloring-test-js2-mode (fixture setup &rest body)
- "Use FIXTURE as the subject matter for test logic in BODY."
- `(context-coloring-test-with-fixture
- ,fixture
- (require 'js2-mode)
- (setq js2-mode-show-parse-errors nil)
- (setq js2-mode-show-strict-warnings nil)
- (js2-mode)
- (when ,setup (funcall ,setup))
- (context-coloring-mode)
- ,@body))
-
- (cl-defmacro context-coloring-test-deftest-js-mode (name &key fixture-name)
- "Define an asynchronous test for `js-mode' with the name NAME
- in the typical format."
+ (cl-defmacro context-coloring-test-define-deftest (name
+ &key mode
+ &key extension
+ &key no-fixture
+ &key async
+ &key post-colorization
+ &key enable-context-coloring-mode
+ &key get-args
+ &key before-each
+ &key after-each)
+ "Define a deftest defmacro for tests prefixed with NAME. MODE
+ is called to set up tests' environments. EXTENSION denotes the
+ suffix for tests' fixture files. If NO-FIXTURE is non-nil, don't
+ use a fixture. If ASYNC is non-nil, pass a callback to the
+ defined tests' bodies for them to call when they are done. If
+ POST-COLORIZATION is non-nil, the tests run after
+ `context-coloring-colorize' finishes asynchronously. If
+ ENABLE-CONTEXT-COLORING-MODE is non-nil, `context-coloring-mode'
+ is activated before tests. GET-ARGS provides arguments to apply
+ to BEFORE-EACH, AFTER-EACH, and each tests' body, before and
+ after functions. Functions BEFORE-EACH and AFTER-EACH run before
+ the major mode is activated before each test, and after each
+ test, even if an error is signaled."
(declare (indent defun))
- (let ((test-name (intern (format "context-coloring-test-js-mode-%s" name)))
- (fixture (format "./fixtures/%s.js" (or fixture-name name)))
- (function-name (intern-soft
- (format "context-coloring-test-js-%s" name)))
- (setup-function-name (intern-soft
- (format
- "context-coloring-test-js-%s-setup" name))))
- `(ert-deftest-async ,test-name (done)
- (context-coloring-test-js-mode
- ,fixture
- (lambda (teardown)
- (unwind-protect
- (,function-name)
- (funcall teardown))
- (funcall done))
- ',setup-function-name))))
-
- (cl-defmacro context-coloring-test-deftest-js2-mode (name &key fixture-name)
- "Define a test for `js2-mode' with the name NAME in the typical
- format."
+ (let ((macro-name (intern (format "context-coloring-test-deftest%s"
+ (cond
+ ;; No name means no dash.
+ ((eq name nil) "")
+ (t (format "-%s" name)))))))
+ `(cl-defmacro ,macro-name (name
+ body
+ &key fixture
+ &key before
+ &key after)
+ ,(format "Define a test for `%s' suffixed with NAME.
+
+ Function BODY makes assertions.
+ %s
+
+ Functions BEFORE and AFTER run before and after the test, even if
+ an error is signaled.
+
+ BODY is run after `context-coloring-mode' is activated, or after
+ initial colorization if colorization should occur."
+ (cadr mode)
+ (cond
+ (no-fixture "
+ There is no fixture, unless FIXTURE is specified.")
+ (t
+ (format "
+ The default fixture has a filename matching NAME (plus the
+ filetype extension, \"%s\"), unless FIXTURE is specified to
+ override it."
+ extension))))
+ (declare (indent defun))
+ ;; Commas in nested backquotes are not evaluated. Binding the variables
+ ;; here is probably the cleanest workaround.
+ (let ((mode ,mode)
+ (get-args ',(cond
+ (get-args get-args)
+ (t '(lambda () (list)))))
+ (args (make-symbol "args"))
+ (before-each ',before-each)
+ (after-each ',after-each)
+ (test-name (intern (format ,(format "%s-%%s"
+ (cond
+ (name)
+ (t "sync"))) name)))
+ (fixture (cond
+ (fixture (format "./fixtures/%s" fixture))
+ (,no-fixture "./fixtures/empty")
+ (t (format ,(format "./fixtures/%%s.%s" extension) name)))))
+ ,@(cond
+ ((or async post-colorization)
+ `((let ((post-colorization ,post-colorization))
+ `(ert-deftest-async ,test-name (done)
+ (let ((,args (funcall ,get-args)))
+ (context-coloring-test-with-fixture-async
+ ,fixture
+ (lambda (done-with-fixture)
+ (when ,before-each (apply ,before-each ,args))
+ (,mode)
+ (when ,before (apply ,before ,args))
+ (cond
+ (,post-colorization
+ (context-coloring-colorize
+ (lambda ()
+ (unwind-protect
+ (progn
+ (apply ,body ,args))
+ (when ,after (apply ,after ,args))
+ (when ,after-each (apply ,after-each ,args))
+ (funcall done-with-fixture))
+ (funcall done))))
+ (t
+ ;; Leave error handling up to the user.
+ (apply ,body (append
+ (list (lambda ()
+ (when ,after (apply ,after ,args))
+ (when ,after-each (apply ,after-each ,args))
+ (funcall done-with-fixture)
+ (funcall done)))
+ ,args)))))))))))
+ (t
+ `((let ((enable-context-coloring-mode ,enable-context-coloring-mode))
+ `(ert-deftest ,test-name ()
+ (let ((,args (funcall ,get-args)))
+ (context-coloring-test-with-fixture
+ ,fixture
+ (when ,before-each (apply ,before-each ,args))
+ (,mode)
+ (when ,before (apply ,before ,args))
+ (when ,enable-context-coloring-mode (context-coloring-mode))
+ (unwind-protect
+ (progn
+ (apply ,body ,args))
+ (when ,after (apply ,after ,args))
+ (when ,after-each (apply ,after-each ,args))))))))))))))
+
+ (context-coloring-test-define-deftest nil
+ :mode #'fundamental-mode
+ :no-fixture t)
+
+ (context-coloring-test-define-deftest async
+ :mode #'fundamental-mode
+ :no-fixture t
+ :async t)
+
+ (context-coloring-test-define-deftest js
+ :mode #'js-mode
+ :extension "js"
+ :post-colorization t)
+
+ (context-coloring-test-define-deftest js2
+ :mode #'js2-mode
+ :extension "js"
+ :enable-context-coloring-mode t
+ :before-each (lambda ()
+ (setq js2-mode-show-parse-errors nil)
+ (setq js2-mode-show-strict-warnings nil)))
+
+ (defmacro context-coloring-test-deftest-js-js2 (&rest args)
+ "Simultaneously define the same test for js and js2 (with
+ ARGS)."
(declare (indent defun))
- (let ((test-name (intern (format "context-coloring-test-js2-mode-%s" name)))
- (fixture (format "./fixtures/%s.js" (or fixture-name name)))
- (function-name (intern-soft
- (format "context-coloring-test-js-%s" name)))
- (setup-function-name (intern-soft
- (format
- "context-coloring-test-js-%s-setup" name))))
- `(ert-deftest ,test-name ()
- (context-coloring-test-js2-mode
- ,fixture
- ',setup-function-name
- (,function-name)))))
-
- (cl-defmacro context-coloring-test-deftest-emacs-lisp-mode (name
- body
- &key setup)
- "Define a test for `emacs-lisp-mode' with name and fixture as
- NAME, with BODY containing the assertions, and SETUP defining the
- environment."
- (declare (indent defun))
- (let ((test-name (intern (format "context-coloring-emacs-lisp-mode-%s" name)))
- (fixture (format "./fixtures/%s.el" name)))
- `(ert-deftest ,test-name ()
- (context-coloring-test-with-fixture
- ,fixture
- (emacs-lisp-mode)
- (when ,setup (funcall ,setup))
- (context-coloring-mode)
- (funcall ,body)))))
+ `(progn
+ (context-coloring-test-deftest-js ,@args)
+ (context-coloring-test-deftest-js2 ,@args)))
+
+ (context-coloring-test-define-deftest emacs-lisp
+ :mode #'emacs-lisp-mode
+ :extension "el"
+ :enable-context-coloring-mode t)
+
+ (context-coloring-test-define-deftest define-theme
+ :mode #'fundamental-mode
+ :no-fixture t
+ :get-args (lambda ()
+ (list (context-coloring-test-get-next-theme)))
+ :after-each (lambda (theme)
+ (setq context-coloring-maximum-face 7)
+ (setq context-coloring-original-maximum-face
+ context-coloring-maximum-face)
+ (disable-theme theme)
+ (context-coloring-test-kill-buffer "*Warnings*")))
;;; Assertion functions
- (defun context-coloring-test-assert-position-level (position level)
- "Assert that POSITION has LEVEL."
- (let ((face (get-text-property position 'face))
- actual-level)
- (when (not (and face
- (let* ((face-string (symbol-name face))
- (matches (string-match
- context-coloring-level-face-regexp
- face-string)))
- (when matches
- (setq actual-level (string-to-number
- (substring face-string
- (match-beginning 1)
- (match-end 1))))
- (= level actual-level)))))
- (ert-fail (format (concat "Expected level at position %s, "
- "which is \"%s\", to be %s; "
- "but it was %s")
- position
- (buffer-substring-no-properties position (1+ position)) level
- actual-level)))))
-
- (defun context-coloring-test-assert-position-face (position face-regexp)
- "Assert that the face at POSITION satisfies FACE-REGEXP."
- (let ((face (get-text-property position 'face)))
- (when (or
- ;; Pass a non-string to do an `equal' check (against a symbol or nil).
- (unless (stringp face-regexp)
- (not (equal face-regexp face)))
- ;; Otherwise do the matching.
- (when (stringp face-regexp)
- (not (string-match-p face-regexp (symbol-name face)))))
- (ert-fail (format (concat "Expected face at position %s, "
- "which is \"%s\", to be %s; "
- "but it was %s")
- position
- (buffer-substring-no-properties position (1+ position)) face-regexp
- face)))))
-
- (defun context-coloring-test-assert-position-comment (position)
- (context-coloring-test-assert-position-face
- position "\\`font-lock-comment\\(-delimiter\\)?-face\\'"))
-
- (defun context-coloring-test-assert-position-constant-comment (position)
- (context-coloring-test-assert-position-face position '(font-lock-constant-face
- font-lock-comment-face)))
-
- (defun context-coloring-test-assert-position-string (position)
- (context-coloring-test-assert-position-face position 'font-lock-string-face))
-
- (defun context-coloring-test-assert-position-nil (position)
- (context-coloring-test-assert-position-face position nil))
-
- (defun context-coloring-test-assert-coloring (map)
- "Assert that the current buffer's coloring matches MAP."
- ;; Omit the superfluous, formatting-related leading newline. Can't use
- ;; `save-excursion' here because if an assertion fails it will cause future
- ;; tests to get messed up.
- (goto-char (point-min))
- (let* ((map (substring map 1))
- (index 0)
- char-string
- char)
- (while (< index (length map))
- (setq char-string (substring map index (1+ index)))
- (setq char (string-to-char char-string))
- (cond
- ;; Newline
- ((= char 10)
- (next-logical-line)
- (beginning-of-line))
- ;; Number
- ((and (>= char 48)
- (<= char 57))
- (context-coloring-test-assert-position-level
- (point) (string-to-number char-string))
- (forward-char))
- ;; ';' = Comment
- ((= char 59)
- (context-coloring-test-assert-position-comment (point))
- (forward-char))
- ;; 'c' = Constant comment
- ((= char 99)
- (context-coloring-test-assert-position-constant-comment (point))
- (forward-char))
- ;; 'n' = nil
- ((= char 110)
- (context-coloring-test-assert-position-nil (point))
- (forward-char))
- ;; 's' = String
- ((= char 115)
- (context-coloring-test-assert-position-string (point))
- (forward-char))
- (t
- (forward-char)))
- (setq index (1+ index)))))
-
- (defmacro context-coloring-test-assert-region (&rest body)
- "Assert something about the face of points in a region.
- Provides the free variables `i', `length', `point', `face' and
- `actual-level' to the code in BODY."
- `(let ((i 0)
- (length (- end start)))
- (while (< i length)
- (let* ((point (+ i start))
- (face (get-text-property point 'face)))
- ,@body)
- (setq i (+ i 1)))))
-
- (defun context-coloring-test-assert-region-level (start end level)
- "Assert that all points in the range [START, END) are of level
- LEVEL."
- (context-coloring-test-assert-region
- (let (actual-level)
- (when (not (when face
- (let* ((face-string (symbol-name face))
- (matches (string-match
- context-coloring-level-face-regexp
- face-string)))
- (when matches
- (setq actual-level (string-to-number
- (substring face-string
- (match-beginning 1)
- (match-end 1))))
- (= level actual-level)))))
- (ert-fail (format (concat "Expected level in region [%s, %s), "
- "which is \"%s\", to be %s; "
- "but at point %s, it was %s")
- start end
- (buffer-substring-no-properties start end) level
- point actual-level))))))
-
- (defun context-coloring-test-assert-region-face (start end expected-face)
- "Assert that all points in the range [START, END) have the face
- EXPECTED-FACE."
- (context-coloring-test-assert-region
- (when (not (eq face expected-face))
- (ert-fail (format (concat "Expected face in region [%s, %s), "
- "which is \"%s\", to be %s; "
- "but at point %s, it was %s")
- start end
- (buffer-substring-no-properties start end) expected-face
- point face)))))
-
- (defun context-coloring-test-assert-region-comment-delimiter (start end)
- "Assert that all points in the range [START, END) have
- `font-lock-comment-delimiter-face'."
- (context-coloring-test-assert-region-face
- start end 'font-lock-comment-delimiter-face))
-
- (defun context-coloring-test-assert-region-comment (start end)
- "Assert that all points in the range [START, END) have
- `font-lock-comment-face'."
- (context-coloring-test-assert-region-face
- start end 'font-lock-comment-face))
-
- (defun context-coloring-test-assert-region-string (start end)
- "Assert that all points in the range [START, END) have
- `font-lock-string-face'."
- (context-coloring-test-assert-region-face
- start end 'font-lock-string-face))
-
(defun context-coloring-test-get-last-message ()
+ "Get the last message in the current messages bufffer."
(let ((messages (split-string
(buffer-substring-no-properties
(point-min)
(with-current-buffer buffer
(buffer-string))))))
- (defun context-coloring-test-kill-buffer (buffer)
- "Kill BUFFER if it exists."
- (when (get-buffer buffer) (kill-buffer buffer)))
-
- (defun context-coloring-test-assert-face (level foreground &optional negate)
- "Assert that a face for LEVEL exists and that its `:foreground'
- is FOREGROUND, or the inverse if NEGATE is non-nil."
- (let* ((face (context-coloring-level-face level))
- actual-foreground)
- (when (not (or negate
- face))
- (ert-fail (format (concat "Expected face for level `%s' to exist; "
- "but it didn't")
- level)))
- (setq actual-foreground (face-attribute face :foreground))
- (when (funcall (if negate 'identity 'not)
- (string-equal foreground actual-foreground))
- (ert-fail (format (concat "Expected face for level `%s' "
- "%sto have foreground `%s'; "
- "but it %s.")
- level
- (if negate "not " "") foreground
- (if negate
- "did" (format "was `%s'" actual-foreground)))))))
-
- (defun context-coloring-test-assert-not-face (&rest arguments)
- "Assert that LEVEL does not have a face with `:foreground'
- FOREGROUND. Apply ARGUMENTS to
- `context-coloring-test-assert-face', see that function."
- (apply 'context-coloring-test-assert-face
- (append arguments '(t))))
-
(defun context-coloring-test-assert-error (body error-message)
"Assert that BODY signals ERROR-MESSAGE."
(let ((error-signaled-p nil))
(when (not error-signaled-p)
(ert-fail "Expected an error to be thrown, but there wasn't."))))
+
+ ;;; Miscellaneous tests
+
(defun context-coloring-test-assert-trimmed (result expected)
+ "Assert that RESULT is trimmed like EXPECTED."
(when (not (string-equal result expected))
(ert-fail "Expected string to be trimmed, but it wasn't.")))
-
- ;;; The tests
-
- (ert-deftest context-coloring-test-trim ()
- (context-coloring-test-assert-trimmed (context-coloring-trim "") "")
- (context-coloring-test-assert-trimmed (context-coloring-trim " ") "")
- (context-coloring-test-assert-trimmed (context-coloring-trim "a") "a")
- (context-coloring-test-assert-trimmed (context-coloring-trim " a") "a")
- (context-coloring-test-assert-trimmed (context-coloring-trim "a ") "a")
- (context-coloring-test-assert-trimmed (context-coloring-trim " a ") "a"))
-
- (ert-deftest-async context-coloring-test-async-mode-startup (done)
- (context-coloring-test-with-fixture-async
- "./fixtures/empty"
- (lambda (teardown)
- (js-mode)
- (add-hook
- 'context-coloring-colorize-hook
- (lambda ()
- ;; If this runs we are implicitly successful; this test only confirms
- ;; that colorization occurs on mode startup.
- (funcall teardown)
- (funcall done)))
- (context-coloring-mode))))
-
- (define-derived-mode
- context-coloring-change-detection-mode
- fundamental-mode
- "Testing"
- "Prevent `context-coloring-test-change-detection' from
- having any unintentional side-effects on mode support.")
+ (context-coloring-test-deftest trim
+ (lambda ()
+ (context-coloring-test-assert-trimmed (context-coloring-trim "") "")
+ (context-coloring-test-assert-trimmed (context-coloring-trim " ") "")
+ (context-coloring-test-assert-trimmed (context-coloring-trim "a") "a")
+ (context-coloring-test-assert-trimmed (context-coloring-trim " a") "a")
+ (context-coloring-test-assert-trimmed (context-coloring-trim "a ") "a")
+ (context-coloring-test-assert-trimmed (context-coloring-trim " a ") "a")))
+
+ (context-coloring-test-deftest-async mode-startup
+ (lambda (done)
+ (js-mode)
+ (add-hook
+ 'context-coloring-colorize-hook
+ (lambda ()
+ ;; If this runs we are implicitly successful; this test only confirms
+ ;; that colorization occurs on mode startup.
+ (funcall done)))
+ (context-coloring-mode))
+ :after (lambda ()
+ ;; TODO: This won't run if there is a timeout. Will probably have to
+ ;; roll our own `ert-deftest-async'.
+ (setq context-coloring-colorize-hook nil)))
+
+ (defmacro context-coloring-test-define-derived-mode (name)
+ "Define a derived mode exclusively for any test with NAME."
+ (let ((name (intern (format "context-coloring-test-%s-mode" name))))
+ `(define-derived-mode ,name fundamental-mode "Testing")))
+
+ (context-coloring-test-define-derived-mode change-detection)
;; Simply cannot figure out how to trigger an idle timer; would much rather test
;; that. But (current-idle-time) always returns nil in these tests.
- (ert-deftest-async context-coloring-test-change-detection (done)
- (context-coloring-define-dispatch
+ (context-coloring-test-deftest-async change-detection
+ (lambda (done)
+ (context-coloring-define-dispatch
'idle-change
- :modes '(context-coloring-change-detection-mode)
+ :modes '(context-coloring-test-change-detection-mode)
:executable "node"
:command "node test/binaries/noop")
- (context-coloring-test-with-fixture-async
- "./fixtures/empty"
- (lambda (teardown)
- (context-coloring-change-detection-mode)
- (add-hook
- 'context-coloring-colorize-hook
- (lambda ()
- (setq context-coloring-colorize-hook nil)
- (add-hook
- 'context-coloring-colorize-hook
- (lambda ()
- (funcall teardown)
- (funcall done)))
- (insert " ")
- (set-window-buffer (selected-window) (current-buffer))
- (context-coloring-maybe-colorize (current-buffer))))
- (context-coloring-mode))))
-
- (ert-deftest context-coloring-test-check-version ()
- (when (not (context-coloring-check-version "2.1.3" "3.0.1"))
- (ert-fail "Expected version 3.0.1 to satisfy 2.1.3, but it didn't."))
- (when (context-coloring-check-version "3.0.1" "2.1.3")
- (ert-fail "Expected version 2.1.3 not to satisfy 3.0.1, but it did.")))
-
- (ert-deftest context-coloring-test-unsupported-mode ()
- (context-coloring-test-with-fixture
- "./fixtures/empty"
- (context-coloring-mode)
- (context-coloring-test-assert-message
- "Context coloring is not available for this major mode"
- "*Messages*")))
-
- (ert-deftest context-coloring-test-derived-mode ()
- (context-coloring-test-with-fixture
- "./fixtures/empty"
- (lisp-interaction-mode)
- (context-coloring-mode)
- (context-coloring-test-assert-not-message
- "Context coloring is not available for this major mode"
- "*Messages*")))
-
- (define-derived-mode
- context-coloring-test-define-dispatch-error-mode
- fundamental-mode
- "Testing"
- "Prevent `context-coloring-test-define-dispatch-error' from
- having any unintentional side-effects on mode support.")
-
- (ert-deftest context-coloring-test-define-dispatch-error ()
- (context-coloring-test-assert-error
- (lambda ()
- (context-coloring-define-dispatch
- 'define-dispatch-no-modes))
- "No mode defined for dispatch")
- (context-coloring-test-assert-error
- (lambda ()
- (context-coloring-define-dispatch
- 'define-dispatch-no-strategy
- :modes '(context-coloring-test-define-dispatch-error-mode)))
- "No colorizer, scopifier or command defined for dispatch"))
-
- (define-derived-mode
- context-coloring-test-define-dispatch-scopifier-mode
- fundamental-mode
- "Testing"
- "Prevent `context-coloring-test-define-dispatch-scopifier' from
- having any unintentional side-effects on mode support.")
-
- (ert-deftest context-coloring-test-define-dispatch-scopifier ()
- (context-coloring-define-dispatch
- 'define-dispatch-scopifier
- :modes '(context-coloring-test-define-dispatch-scopifier-mode)
- :scopifier (lambda () (vector)))
- (with-temp-buffer
- (context-coloring-test-define-dispatch-scopifier-mode)
+ (context-coloring-test-change-detection-mode)
+ (add-hook
+ 'context-coloring-colorize-hook
+ (lambda ()
+ (setq context-coloring-colorize-hook nil)
+ (add-hook
+ 'context-coloring-colorize-hook
+ (lambda ()
+ (funcall done)))
+ (insert " ")
+ (set-window-buffer (selected-window) (current-buffer))
+ (context-coloring-maybe-colorize-with-buffer (current-buffer))))
+ (context-coloring-mode))
+ :after (lambda ()
+ (setq context-coloring-colorize-hook nil)))
+
+ (context-coloring-test-deftest check-version
+ (lambda ()
+ (when (not (context-coloring-check-version "2.1.3" "3.0.1"))
+ (ert-fail "Expected version 3.0.1 to satisfy 2.1.3, but it didn't."))
+ (when (context-coloring-check-version "3.0.1" "2.1.3")
+ (ert-fail "Expected version 2.1.3 not to satisfy 3.0.1, but it did."))))
+
+ (context-coloring-test-deftest unsupported-mode
+ (lambda ()
(context-coloring-mode)
- (context-coloring-colorize)))
-
- (define-derived-mode
- context-coloring-test-missing-executable-mode
- fundamental-mode
- "Testing"
- "Prevent `context-coloring-test-define-dispatch-scopifier' from
- having any unintentional side-effects on mode support.")
-
- (ert-deftest context-coloring-test-missing-executable ()
- (context-coloring-define-dispatch
- 'scopifier
- :modes '(context-coloring-test-missing-executable-mode)
- :command ""
- :executable "__should_not_exist__")
- (with-temp-buffer
+ (context-coloring-test-assert-message
+ "Context coloring is not available for this major mode"
+ "*Messages*")))
+
+ (context-coloring-test-deftest derived-mode
+ (lambda ()
+ (lisp-interaction-mode)
+ (context-coloring-mode)
+ (context-coloring-test-assert-not-message
+ "Context coloring is not available for this major mode"
+ "*Messages*")))
+
+ (context-coloring-test-define-derived-mode define-dispatch-error)
+
+ (context-coloring-test-deftest define-dispatch-error
+ (lambda ()
+ (context-coloring-test-assert-error
+ (lambda ()
+ (context-coloring-define-dispatch
+ 'define-dispatch-no-modes))
+ "No mode defined for dispatch")
+ (context-coloring-test-assert-error
+ (lambda ()
+ (context-coloring-define-dispatch
+ 'define-dispatch-no-strategy
+ :modes '(context-coloring-test-define-dispatch-error-mode)))
+ "No colorizer or command defined for dispatch")))
+
+ (context-coloring-test-define-derived-mode missing-executable)
+
+ (context-coloring-test-deftest missing-executable
+ (lambda ()
+ (context-coloring-define-dispatch
+ 'scopifier
+ :modes '(context-coloring-test-missing-executable-mode)
+ :command ""
+ :executable "__should_not_exist__")
(context-coloring-test-missing-executable-mode)
(context-coloring-mode)))
- (define-derived-mode
- context-coloring-test-unsupported-version-mode
- fundamental-mode
- "Testing"
- "Prevent `context-coloring-test-unsupported-version' from
- having any unintentional side-effects on mode support.")
-
- (ert-deftest-async context-coloring-test-unsupported-version (done)
- (context-coloring-define-dispatch
- 'outta-date
- :modes '(context-coloring-test-unsupported-version-mode)
- :executable "node"
- :command "node test/binaries/outta-date"
- :version "v2.1.3")
- (context-coloring-test-with-fixture-async
- "./fixtures/empty"
- (lambda (teardown)
- (context-coloring-test-unsupported-version-mode)
- (add-hook
- 'context-coloring-check-scopifier-version-hook
- (lambda ()
- (unwind-protect
- (progn
- ;; Normally the executable would be something like "outta-date"
- ;; rather than "node".
- (context-coloring-test-assert-message
- "Update to the minimum version of \"node\" (v2.1.3)"
- "*Messages*"))
- (funcall teardown))
- (funcall done)))
- (context-coloring-mode))))
-
- (define-derived-mode
- context-coloring-test-disable-mode-mode
- fundamental-mode
- "Testing"
- "Prevent `context-coloring-test-disable-mode' from having any
- unintentional side-effects on mode support.")
-
- (ert-deftest-async context-coloring-test-disable-mode (done)
- (let (torn-down)
+ (context-coloring-test-define-derived-mode unsupported-version)
+
+ (context-coloring-test-deftest-async unsupported-version
+ (lambda (done)
(context-coloring-define-dispatch
- 'disable-mode
- :modes '(context-coloring-test-disable-mode-mode)
+ 'outta-date
+ :modes '(context-coloring-test-unsupported-version-mode)
:executable "node"
- :command "node test/binaries/noop"
- :teardown (lambda ()
- (setq torn-down t)))
- (context-coloring-test-with-fixture-async
- "./fixtures/empty"
- (lambda (teardown)
+ :command "node test/binaries/outta-date"
+ :version "v2.1.3")
+ (context-coloring-test-unsupported-version-mode)
+ (add-hook
+ 'context-coloring-check-scopifier-version-hook
+ (lambda ()
(unwind-protect
(progn
- (context-coloring-test-disable-mode-mode)
- (context-coloring-mode)
- (context-coloring-mode -1)
- (when (not torn-down)
- (ert-fail "Expected teardown function to have been called, but it wasn't.")))
- (funcall teardown))
- (funcall done)))))
+ ;; Normally the executable would be something like "outta-date"
+ ;; rather than "node".
+ (context-coloring-test-assert-message
+ "Update to the minimum version of \"node\" (v2.1.3)"
+ "*Messages*"))
+ (funcall done))))
+ (context-coloring-mode))
+ :after (lambda ()
+ (setq context-coloring-check-scopifier-version-hook nil)))
+
+ (context-coloring-test-define-derived-mode disable-mode)
+
+ (context-coloring-test-deftest-async disable-mode
+ (lambda (done)
+ (let (torn-down)
+ (context-coloring-define-dispatch
+ 'disable-mode
+ :modes '(context-coloring-test-disable-mode-mode)
+ :executable "node"
+ :command "node test/binaries/noop"
+ :teardown (lambda ()
+ (setq torn-down t)))
+ (unwind-protect
+ (progn
+ (context-coloring-test-disable-mode-mode)
+ (context-coloring-mode)
+ (context-coloring-mode -1)
+ (when (not torn-down)
+ (ert-fail "Expected teardown function to have been called, but it wasn't.")))
+ (funcall done)))))
+
+
+ ;;; Theme tests
(defvar context-coloring-test-theme-index 0
"Unique index for unique theme names.")
(setq context-coloring-test-theme-index
(+ context-coloring-test-theme-index 1))))
+ (defun context-coloring-test-assert-face (level foreground &optional negate)
+ "Assert that a face for LEVEL exists and that its `:foreground'
+ is FOREGROUND, or the inverse if NEGATE is non-nil."
+ (let* ((face (context-coloring-level-face level))
+ actual-foreground)
+ (when (not (or negate
+ face))
+ (ert-fail (format (concat "Expected face for level `%s' to exist; "
+ "but it didn't")
+ level)))
+ (setq actual-foreground (face-attribute face :foreground))
+ (when (funcall (if negate #'identity #'not)
+ (string-equal foreground actual-foreground))
+ (ert-fail (format (concat "Expected face for level `%s' "
+ "%sto have foreground `%s'; "
+ "but it %s.")
+ level
+ (if negate "not " "") foreground
+ (if negate
+ "did" (format "was `%s'" actual-foreground)))))))
+
+ (defun context-coloring-test-assert-not-face (&rest arguments)
+ "Assert that LEVEL does not have a face with `:foreground'
+ FOREGROUND. Apply ARGUMENTS to
+ `context-coloring-test-assert-face', see that function."
+ (apply #'context-coloring-test-assert-face
+ (append arguments '(t))))
+
(defun context-coloring-test-assert-theme-originally-set-p
(settings &optional negate)
- "Assert that `context-coloring-theme-originally-set-p' returns
- t for a theme with SETTINGS, or the inverse if NEGATE is
+ "Assert that `context-coloring-theme-originally-set-p' will
+ return t for a theme with SETTINGS, or the inverse if NEGATE is
non-nil."
(let ((theme (context-coloring-test-get-next-theme)))
(put theme 'theme-settings settings)
- (when (funcall (if negate 'identity 'not)
+ (when (funcall (if negate #'identity #'not)
(context-coloring-theme-originally-set-p theme))
(ert-fail (format (concat "Expected theme `%s' with settings `%s' "
"%sto be considered to have defined a level, "
return t for a theme with SETTINGS. Apply ARGUMENTS to
`context-coloring-test-assert-theme-originally-set-p', see that
function."
- (apply 'context-coloring-test-assert-theme-originally-set-p
+ (apply #'context-coloring-test-assert-theme-originally-set-p
(append arguments '(t))))
- (ert-deftest context-coloring-test-theme-originally-set-p ()
- (context-coloring-test-assert-theme-originally-set-p
- '((theme-face context-coloring-level-0-face)))
- (context-coloring-test-assert-theme-originally-set-p
- '((theme-face face)
- (theme-face context-coloring-level-0-face)))
- (context-coloring-test-assert-theme-originally-set-p
- '((theme-face context-coloring-level-0-face)
- (theme-face face)))
- (context-coloring-test-assert-not-theme-originally-set-p
- '((theme-face face)))
- )
+ (context-coloring-test-deftest theme-originally-set-p
+ (lambda ()
+ (context-coloring-test-assert-theme-originally-set-p
+ '((theme-face context-coloring-level-0-face)))
+ (context-coloring-test-assert-theme-originally-set-p
+ '((theme-face face)
+ (theme-face context-coloring-level-0-face)))
+ (context-coloring-test-assert-theme-originally-set-p
+ '((theme-face context-coloring-level-0-face)
+ (theme-face face)))
+ (context-coloring-test-assert-not-theme-originally-set-p
+ '((theme-face face)))))
(defun context-coloring-test-assert-theme-settings-highest-level
(settings expected-level)
"Assert that THEME has the highest level EXPECTED-LEVEL, or the
inverse if NEGATE is non-nil."
(let ((highest-level (context-coloring-theme-highest-level theme)))
- (when (funcall (if negate 'identity 'not) (eq highest-level expected-level))
+ (when (funcall (if negate #'identity #'not) (eq highest-level expected-level))
(ert-fail (format (concat "Expected theme with settings `%s' "
"%sto have a highest level of `%s', "
"but it %s.")
Apply ARGUMENTS to
`context-coloring-test-assert-theme-highest-level', see that
function."
- (apply 'context-coloring-test-assert-theme-highest-level
+ (apply #'context-coloring-test-assert-theme-highest-level
(append arguments '(t))))
- (ert-deftest context-coloring-test-theme-highest-level ()
- (context-coloring-test-assert-theme-settings-highest-level
- '((theme-face foo))
- -1)
- (context-coloring-test-assert-theme-settings-highest-level
- '((theme-face context-coloring-level-0-face))
- 0)
- (context-coloring-test-assert-theme-settings-highest-level
- '((theme-face context-coloring-level-1-face))
- 1)
- (context-coloring-test-assert-theme-settings-highest-level
- '((theme-face context-coloring-level-1-face)
- (theme-face context-coloring-level-0-face))
- 1)
- (context-coloring-test-assert-theme-settings-highest-level
- '((theme-face context-coloring-level-0-face)
- (theme-face context-coloring-level-1-face))
- 1)
- )
-
- (defmacro context-coloring-test-deftest-define-theme (name &rest body)
- "Define a test with name NAME and an automatically-generated
- theme symbol available as a free variable `theme'. Side-effects
- from enabling themes are reversed after BODY is executed and the
- test completes."
- (declare (indent defun))
- (let ((deftest-name (intern
- (format "context-coloring-test-define-theme-%s" name))))
- `(ert-deftest ,deftest-name ()
- (context-coloring-test-kill-buffer "*Warnings*")
- (context-coloring-test-setup)
- (let ((theme (context-coloring-test-get-next-theme)))
- (unwind-protect
- (progn
- ,@body)
- ;; Always cleanup.
- (disable-theme theme)
- (context-coloring-test-cleanup))))))
+ (context-coloring-test-deftest theme-highest-level
+ (lambda ()
+ (context-coloring-test-assert-theme-settings-highest-level
+ '((theme-face foo))
+ -1)
+ (context-coloring-test-assert-theme-settings-highest-level
+ '((theme-face context-coloring-level-0-face))
+ 0)
+ (context-coloring-test-assert-theme-settings-highest-level
+ '((theme-face context-coloring-level-1-face))
+ 1)
+ (context-coloring-test-assert-theme-settings-highest-level
+ '((theme-face context-coloring-level-1-face)
+ (theme-face context-coloring-level-0-face))
+ 1)
+ (context-coloring-test-assert-theme-settings-highest-level
+ '((theme-face context-coloring-level-0-face)
+ (theme-face context-coloring-level-1-face))
+ 1)))
+
+ (defun context-coloring-test-kill-buffer (buffer)
+ "Kill BUFFER if it exists."
+ (when (get-buffer buffer) (kill-buffer buffer)))
(defun context-coloring-test-deftheme (theme)
"Dynamically define theme THEME."
(eval (macroexpand `(deftheme ,theme))))
(context-coloring-test-deftest-define-theme additive
- (context-coloring-test-deftheme theme)
- (context-coloring-define-theme
- theme
- :colors '("#aaaaaa"
- "#bbbbbb"))
- (context-coloring-test-assert-no-message "*Warnings*")
- (enable-theme theme)
- (context-coloring-test-assert-no-message "*Warnings*")
- (context-coloring-test-assert-face 0 "#aaaaaa")
- (context-coloring-test-assert-face 1 "#bbbbbb"))
+ (lambda (theme)
+ (context-coloring-test-deftheme theme)
+ (context-coloring-define-theme
+ theme
+ :colors '("#aaaaaa"
+ "#bbbbbb"))
+ (context-coloring-test-assert-no-message "*Warnings*")
+ (enable-theme theme)
+ (context-coloring-test-assert-no-message "*Warnings*")
+ (context-coloring-test-assert-face 0 "#aaaaaa")
+ (context-coloring-test-assert-face 1 "#bbbbbb")))
(defun context-coloring-test-assert-defined-warning (theme)
"Assert that a warning about colors already being defined for
"*Warnings*"))
(context-coloring-test-deftest-define-theme unintentional-override
- (context-coloring-test-deftheme theme)
- (custom-theme-set-faces
- theme
- '(context-coloring-level-0-face ((t (:foreground "#aaaaaa"))))
- '(context-coloring-level-1-face ((t (:foreground "#bbbbbb")))))
- (context-coloring-define-theme
- theme
- :colors '("#cccccc"
- "#dddddd"))
- (context-coloring-test-assert-defined-warning theme)
- (context-coloring-test-kill-buffer "*Warnings*")
- (enable-theme theme)
- (context-coloring-test-assert-defined-warning theme)
- (context-coloring-test-assert-face 0 "#cccccc")
- (context-coloring-test-assert-face 1 "#dddddd"))
+ (lambda (theme)
+ (context-coloring-test-deftheme theme)
+ (custom-theme-set-faces
+ theme
+ '(context-coloring-level-0-face ((t (:foreground "#aaaaaa"))))
+ '(context-coloring-level-1-face ((t (:foreground "#bbbbbb")))))
+ (context-coloring-define-theme
+ theme
+ :colors '("#cccccc"
+ "#dddddd"))
+ (context-coloring-test-assert-defined-warning theme)
+ (context-coloring-test-kill-buffer "*Warnings*")
+ (enable-theme theme)
+ (context-coloring-test-assert-defined-warning theme)
+ (context-coloring-test-assert-face 0 "#cccccc")
+ (context-coloring-test-assert-face 1 "#dddddd")))
(context-coloring-test-deftest-define-theme intentional-override
- (context-coloring-test-deftheme theme)
- (custom-theme-set-faces
- theme
- '(context-coloring-level-0-face ((t (:foreground "#aaaaaa"))))
- '(context-coloring-level-1-face ((t (:foreground "#bbbbbb")))))
- (context-coloring-define-theme
- theme
- :override t
- :colors '("#cccccc"
- "#dddddd"))
- (context-coloring-test-assert-no-message "*Warnings*")
- (enable-theme theme)
- (context-coloring-test-assert-no-message "*Warnings*")
- (context-coloring-test-assert-face 0 "#cccccc")
- (context-coloring-test-assert-face 1 "#dddddd"))
+ (lambda (theme)
+ (context-coloring-test-deftheme theme)
+ (custom-theme-set-faces
+ theme
+ '(context-coloring-level-0-face ((t (:foreground "#aaaaaa"))))
+ '(context-coloring-level-1-face ((t (:foreground "#bbbbbb")))))
+ (context-coloring-define-theme
+ theme
+ :override t
+ :colors '("#cccccc"
+ "#dddddd"))
+ (context-coloring-test-assert-no-message "*Warnings*")
+ (enable-theme theme)
+ (context-coloring-test-assert-no-message "*Warnings*")
+ (context-coloring-test-assert-face 0 "#cccccc")
+ (context-coloring-test-assert-face 1 "#dddddd")))
(context-coloring-test-deftest-define-theme pre-recede
- (context-coloring-define-theme
- theme
- :recede t
- :colors '("#aaaaaa"
- "#bbbbbb"))
- (context-coloring-test-deftheme theme)
- (custom-theme-set-faces
- theme
- '(context-coloring-level-0-face ((t (:foreground "#cccccc"))))
- '(context-coloring-level-1-face ((t (:foreground "#dddddd")))))
- (enable-theme theme)
- (context-coloring-test-assert-no-message "*Warnings*")
- (context-coloring-test-assert-face 0 "#cccccc")
- (context-coloring-test-assert-face 1 "#dddddd"))
+ (lambda (theme)
+ (context-coloring-define-theme
+ theme
+ :recede t
+ :colors '("#aaaaaa"
+ "#bbbbbb"))
+ (context-coloring-test-deftheme theme)
+ (custom-theme-set-faces
+ theme
+ '(context-coloring-level-0-face ((t (:foreground "#cccccc"))))
+ '(context-coloring-level-1-face ((t (:foreground "#dddddd")))))
+ (enable-theme theme)
+ (context-coloring-test-assert-no-message "*Warnings*")
+ (context-coloring-test-assert-face 0 "#cccccc")
+ (context-coloring-test-assert-face 1 "#dddddd")))
(context-coloring-test-deftest-define-theme pre-recede-delayed-application
- (context-coloring-define-theme
- theme
- :recede t
- :colors '("#aaaaaa"
- "#bbbbbb"))
- (context-coloring-test-deftheme theme)
- (enable-theme theme)
- (context-coloring-test-assert-no-message "*Warnings*")
- (context-coloring-test-assert-face 0 "#aaaaaa")
- (context-coloring-test-assert-face 1 "#bbbbbb"))
+ (lambda (theme)
+ (context-coloring-define-theme
+ theme
+ :recede t
+ :colors '("#aaaaaa"
+ "#bbbbbb"))
+ (context-coloring-test-deftheme theme)
+ (enable-theme theme)
+ (context-coloring-test-assert-no-message "*Warnings*")
+ (context-coloring-test-assert-face 0 "#aaaaaa")
+ (context-coloring-test-assert-face 1 "#bbbbbb")))
(context-coloring-test-deftest-define-theme post-recede
- (context-coloring-test-deftheme theme)
- (custom-theme-set-faces
- theme
- '(context-coloring-level-0-face ((t (:foreground "#aaaaaa"))))
- '(context-coloring-level-1-face ((t (:foreground "#bbbbbb")))))
- (context-coloring-define-theme
- theme
- :recede t
- :colors '("#cccccc"
- "#dddddd"))
- (context-coloring-test-assert-no-message "*Warnings*")
- (context-coloring-test-assert-face 0 "#aaaaaa")
- (context-coloring-test-assert-face 1 "#bbbbbb")
- (enable-theme theme)
- (context-coloring-test-assert-no-message "*Warnings*")
- (context-coloring-test-assert-face 0 "#aaaaaa")
- (context-coloring-test-assert-face 1 "#bbbbbb"))
+ (lambda (theme)
+ (context-coloring-test-deftheme theme)
+ (custom-theme-set-faces
+ theme
+ '(context-coloring-level-0-face ((t (:foreground "#aaaaaa"))))
+ '(context-coloring-level-1-face ((t (:foreground "#bbbbbb")))))
+ (context-coloring-define-theme
+ theme
+ :recede t
+ :colors '("#cccccc"
+ "#dddddd"))
+ (context-coloring-test-assert-no-message "*Warnings*")
+ (context-coloring-test-assert-face 0 "#aaaaaa")
+ (context-coloring-test-assert-face 1 "#bbbbbb")
+ (enable-theme theme)
+ (context-coloring-test-assert-no-message "*Warnings*")
+ (context-coloring-test-assert-face 0 "#aaaaaa")
+ (context-coloring-test-assert-face 1 "#bbbbbb")))
(context-coloring-test-deftest-define-theme recede-not-defined
- (context-coloring-test-deftheme theme)
- (custom-theme-set-faces
- theme
- '(foo-face ((t (:foreground "#ffffff")))))
- (context-coloring-define-theme
- theme
- :recede t
- :colors '("#aaaaaa"
- "#bbbbbb"))
- (context-coloring-test-assert-no-message "*Warnings*")
- (context-coloring-test-assert-face 0 "#aaaaaa")
- (context-coloring-test-assert-face 1 "#bbbbbb")
- (enable-theme theme)
- (context-coloring-test-assert-no-message "*Warnings*")
- (context-coloring-test-assert-face 0 "#aaaaaa")
- (context-coloring-test-assert-face 1 "#bbbbbb"))
+ (lambda (theme)
+ (context-coloring-test-deftheme theme)
+ (custom-theme-set-faces
+ theme
+ '(foo-face ((t (:foreground "#ffffff")))))
+ (context-coloring-define-theme
+ theme
+ :recede t
+ :colors '("#aaaaaa"
+ "#bbbbbb"))
+ (context-coloring-test-assert-no-message "*Warnings*")
+ (context-coloring-test-assert-face 0 "#aaaaaa")
+ (context-coloring-test-assert-face 1 "#bbbbbb")
+ (enable-theme theme)
+ (context-coloring-test-assert-no-message "*Warnings*")
+ (context-coloring-test-assert-face 0 "#aaaaaa")
+ (context-coloring-test-assert-face 1 "#bbbbbb")))
(context-coloring-test-deftest-define-theme unintentional-obstinance
- (context-coloring-define-theme
- theme
- :colors '("#aaaaaa"
- "#bbbbbb"))
- (context-coloring-test-deftheme theme)
- (custom-theme-set-faces
- theme
- '(context-coloring-level-0-face ((t (:foreground "#cccccc"))))
- '(context-coloring-level-1-face ((t (:foreground "#dddddd")))))
- (enable-theme theme)
- (context-coloring-test-assert-defined-warning theme)
- (context-coloring-test-assert-face 0 "#aaaaaa")
- (context-coloring-test-assert-face 1 "#bbbbbb"))
+ (lambda (theme)
+ (context-coloring-define-theme
+ theme
+ :colors '("#aaaaaa"
+ "#bbbbbb"))
+ (context-coloring-test-deftheme theme)
+ (custom-theme-set-faces
+ theme
+ '(context-coloring-level-0-face ((t (:foreground "#cccccc"))))
+ '(context-coloring-level-1-face ((t (:foreground "#dddddd")))))
+ (enable-theme theme)
+ (context-coloring-test-assert-defined-warning theme)
+ (context-coloring-test-assert-face 0 "#aaaaaa")
+ (context-coloring-test-assert-face 1 "#bbbbbb")))
(context-coloring-test-deftest-define-theme intentional-obstinance
- (context-coloring-define-theme
- theme
- :override t
- :colors '("#aaaaaa"
- "#bbbbbb"))
- (context-coloring-test-deftheme theme)
- (custom-theme-set-faces
- theme
- '(context-coloring-level-0-face ((t (:foreground "#cccccc"))))
- '(context-coloring-level-1-face ((t (:foreground "#dddddd")))))
- (enable-theme theme)
- (context-coloring-test-assert-no-message "*Warnings*")
- (context-coloring-test-assert-face 0 "#aaaaaa")
- (context-coloring-test-assert-face 1 "#bbbbbb"))
+ (lambda (theme)
+ (context-coloring-define-theme
+ theme
+ :override t
+ :colors '("#aaaaaa"
+ "#bbbbbb"))
+ (context-coloring-test-deftheme theme)
+ (custom-theme-set-faces
+ theme
+ '(context-coloring-level-0-face ((t (:foreground "#cccccc"))))
+ '(context-coloring-level-1-face ((t (:foreground "#dddddd")))))
+ (enable-theme theme)
+ (context-coloring-test-assert-no-message "*Warnings*")
+ (context-coloring-test-assert-face 0 "#aaaaaa")
+ (context-coloring-test-assert-face 1 "#bbbbbb")))
(defun context-coloring-test-assert-maximum-face (maximum &optional negate)
"Assert that `context-coloring-maximum-face' is MAXIMUM, or the
inverse if NEGATE is non-nil."
- (when (funcall (if negate 'identity 'not)
+ (when (funcall (if negate #'identity #'not)
(eq context-coloring-maximum-face maximum))
(ert-fail (format (concat "Expected `context-coloring-maximum-face' "
"%sto be `%s', "
"Assert that `context-coloring-maximum-face' is not MAXIMUM.
Apply ARGUMENTS to `context-coloring-test-assert-maximum-face',
see that function."
- (apply 'context-coloring-test-assert-maximum-face
+ (apply #'context-coloring-test-assert-maximum-face
(append arguments '(t))))
(context-coloring-test-deftest-define-theme disable-cascade
- (let ((maximum-face-value 9999))
- (setq context-coloring-maximum-face maximum-face-value)
- (context-coloring-test-deftheme theme)
- (context-coloring-define-theme
- theme
- :colors '("#aaaaaa"
- "#bbbbbb"))
- (let ((second-theme (context-coloring-test-get-next-theme)))
- (context-coloring-test-deftheme second-theme)
+ (lambda (theme)
+ (let ((maximum-face-value 9999))
+ (setq context-coloring-maximum-face maximum-face-value)
+ (context-coloring-test-deftheme theme)
(context-coloring-define-theme
- second-theme
- :colors '("#cccccc"
- "#dddddd"
- "#eeeeee"))
- (let ((third-theme (context-coloring-test-get-next-theme)))
- (context-coloring-test-deftheme third-theme)
+ theme
+ :colors '("#aaaaaa"
+ "#bbbbbb"))
+ (let ((second-theme (context-coloring-test-get-next-theme)))
+ (context-coloring-test-deftheme second-theme)
(context-coloring-define-theme
- third-theme
- :colors '("#111111"
- "#222222"
- "#333333"
- "#444444"))
- (enable-theme theme)
- (enable-theme second-theme)
- (enable-theme third-theme)
- (disable-theme third-theme)
- (context-coloring-test-assert-face 0 "#cccccc")
- (context-coloring-test-assert-face 1 "#dddddd")
- (context-coloring-test-assert-face 2 "#eeeeee")
- (context-coloring-test-assert-maximum-face 2))
- (disable-theme second-theme)
- (context-coloring-test-assert-face 0 "#aaaaaa")
- (context-coloring-test-assert-face 1 "#bbbbbb")
- (context-coloring-test-assert-maximum-face 1))
- (disable-theme theme)
- (context-coloring-test-assert-not-face 0 "#aaaaaa")
- (context-coloring-test-assert-not-face 1 "#bbbbbb")
- (context-coloring-test-assert-maximum-face
- maximum-face-value)))
-
- (defun context-coloring-test-js-function-scopes ()
- "Test fixtures/functions-scopes.js."
- (context-coloring-test-assert-region-level 1 9 0)
- (context-coloring-test-assert-region-level 9 23 1)
- (context-coloring-test-assert-region-level 23 25 0)
- (context-coloring-test-assert-region-level 25 34 1)
- (context-coloring-test-assert-region-level 34 35 0)
- (context-coloring-test-assert-region-level 35 52 1)
- (context-coloring-test-assert-region-level 52 66 2)
- (context-coloring-test-assert-region-level 66 72 1)
- (context-coloring-test-assert-region-level 72 81 2)
- (context-coloring-test-assert-region-level 81 82 1)
- (context-coloring-test-assert-region-level 82 87 2)
- (context-coloring-test-assert-region-level 87 89 1))
-
- (context-coloring-test-deftest-js-mode function-scopes)
- (context-coloring-test-deftest-js2-mode function-scopes)
-
- (defun context-coloring-test-js-global ()
- "Test fixtures/global.js."
- (context-coloring-test-assert-region-level 20 28 1)
- (context-coloring-test-assert-region-level 28 35 0)
- (context-coloring-test-assert-region-level 35 41 1))
-
- (context-coloring-test-deftest-js-mode global)
- (context-coloring-test-deftest-js2-mode global)
-
- (defun context-coloring-test-js-block-scopes ()
- "Test fixtures/block-scopes.js."
- (context-coloring-test-assert-region-level 20 64 1)
- (setq context-coloring-js-block-scopes t)
- (context-coloring-colorize)
- (context-coloring-test-assert-region-level 20 27 1)
- (context-coloring-test-assert-region-level 27 41 2)
- (context-coloring-test-assert-region-level 41 42 1)
- (context-coloring-test-assert-region-level 42 64 2))
-
- (context-coloring-test-deftest-js2-mode block-scopes)
-
- (defun context-coloring-test-js-catch ()
- "Test fixtures/js-catch.js."
- (context-coloring-test-assert-region-level 20 27 1)
- (context-coloring-test-assert-region-level 27 51 2)
- (context-coloring-test-assert-region-level 51 52 1)
- (context-coloring-test-assert-region-level 52 73 2)
- (context-coloring-test-assert-region-level 73 101 3)
- (context-coloring-test-assert-region-level 101 102 1)
- (context-coloring-test-assert-region-level 102 117 3)
- (context-coloring-test-assert-region-level 117 123 2))
-
- (context-coloring-test-deftest-js-mode catch)
- (context-coloring-test-deftest-js2-mode catch)
-
- (defun context-coloring-test-js-key-names ()
- "Test fixtures/key-names.js."
- (context-coloring-test-assert-region-level 20 63 1))
-
- (context-coloring-test-deftest-js-mode key-names)
- (context-coloring-test-deftest-js2-mode key-names)
-
- (defun context-coloring-test-js-property-lookup ()
- "Test fixtures/property-lookup.js."
- (context-coloring-test-assert-region-level 20 26 0)
- (context-coloring-test-assert-region-level 26 38 1)
- (context-coloring-test-assert-region-level 38 44 0)
- (context-coloring-test-assert-region-level 44 52 1)
- (context-coloring-test-assert-region-level 57 63 0)
- (context-coloring-test-assert-region-level 63 74 1))
-
- (context-coloring-test-deftest-js-mode property-lookup)
- (context-coloring-test-deftest-js2-mode property-lookup)
-
- (defun context-coloring-test-js-key-values ()
- "Test fixtures/key-values.js."
- (context-coloring-test-assert-region-level 78 79 1))
-
- (context-coloring-test-deftest-js-mode key-values)
- (context-coloring-test-deftest-js2-mode key-values)
-
- (defun context-coloring-test-js-syntactic-comments-and-strings ()
- "Test comments and strings."
- (context-coloring-test-assert-region-level 1 8 0)
- (context-coloring-test-assert-region-comment-delimiter 9 12)
- (context-coloring-test-assert-region-comment 12 16)
- (context-coloring-test-assert-region-comment-delimiter 17 20)
- (context-coloring-test-assert-region-comment 20 27)
- (context-coloring-test-assert-region-string 28 40)
- (context-coloring-test-assert-region-level 40 41 0))
-
- (defun context-coloring-test-js-syntactic-comments-and-strings-setup ()
- (setq context-coloring-syntactic-comments t)
- (setq context-coloring-syntactic-strings t))
-
- (context-coloring-test-deftest-js-mode syntactic-comments-and-strings
- :fixture-name comments-and-strings)
- (context-coloring-test-deftest-js2-mode syntactic-comments-and-strings
- :fixture-name comments-and-strings)
-
- (defalias 'context-coloring-test-js-comments-and-strings
- 'context-coloring-test-js-syntactic-comments-and-strings
- "Test comments and strings. Deprecated.")
-
- (defun context-coloring-test-js-comments-and-strings-setup ()
- "Setup comments and strings. Deprecated."
- (setq context-coloring-comments-and-strings t))
-
- (context-coloring-test-deftest-js-mode comments-and-strings)
- (context-coloring-test-deftest-js2-mode comments-and-strings)
-
- (defun context-coloring-test-js-syntactic-comments ()
- "Test syntactic comments."
- (context-coloring-test-assert-region-level 1 8 0)
- (context-coloring-test-assert-region-comment-delimiter 9 12)
- (context-coloring-test-assert-region-comment 12 16)
- (context-coloring-test-assert-region-comment-delimiter 17 20)
- (context-coloring-test-assert-region-comment 20 27)
- (context-coloring-test-assert-region-level 28 41 0))
-
- (defun context-coloring-test-js-syntactic-comments-setup ()
- "Setup syntactic comments."
- (setq context-coloring-syntactic-comments t))
-
- (context-coloring-test-deftest-js-mode syntactic-comments
- :fixture-name comments-and-strings)
- (context-coloring-test-deftest-js2-mode syntactic-comments
- :fixture-name comments-and-strings)
-
- (defun context-coloring-test-js-syntactic-strings ()
- "Test syntactic strings."
- (context-coloring-test-assert-region-level 1 28 0)
- (context-coloring-test-assert-region-string 28 40)
- (context-coloring-test-assert-region-level 40 41 0))
-
- (defun context-coloring-test-js-syntactic-strings-setup ()
- "Setup syntactic strings."
- (setq context-coloring-syntactic-strings t))
-
- (context-coloring-test-deftest-js-mode syntactic-strings
- :fixture-name comments-and-strings)
- (context-coloring-test-deftest-js2-mode syntactic-strings
- :fixture-name comments-and-strings)
-
- ;; As long as `add-text-properties' doesn't signal an error, this test passes.
- (defun context-coloring-test-js-unterminated-comment ()
- "Test unterminated multiline comments.")
-
- (context-coloring-test-deftest-js2-mode unterminated-comment)
-
- (context-coloring-test-deftest-emacs-lisp-mode defun
+ second-theme
+ :colors '("#cccccc"
+ "#dddddd"
+ "#eeeeee"))
+ (let ((third-theme (context-coloring-test-get-next-theme)))
+ (context-coloring-test-deftheme third-theme)
+ (context-coloring-define-theme
+ third-theme
+ :colors '("#111111"
+ "#222222"
+ "#333333"
+ "#444444"))
+ (enable-theme theme)
+ (enable-theme second-theme)
+ (enable-theme third-theme)
+ (disable-theme third-theme)
+ (context-coloring-test-assert-face 0 "#cccccc")
+ (context-coloring-test-assert-face 1 "#dddddd")
+ (context-coloring-test-assert-face 2 "#eeeeee")
+ (context-coloring-test-assert-maximum-face 2))
+ (disable-theme second-theme)
+ (context-coloring-test-assert-face 0 "#aaaaaa")
+ (context-coloring-test-assert-face 1 "#bbbbbb")
+ (context-coloring-test-assert-maximum-face 1))
+ (disable-theme theme)
+ (context-coloring-test-assert-not-face 0 "#aaaaaa")
+ (context-coloring-test-assert-not-face 1 "#bbbbbb")
+ (context-coloring-test-assert-maximum-face
+ maximum-face-value))))
+
+
+ ;;; Coloring tests
+
+ (defun context-coloring-test-assert-position-level (position level)
+ "Assert that POSITION has LEVEL."
+ (let ((face (get-text-property position 'face))
+ actual-level)
+ (when (not (and face
+ (let* ((face-string (symbol-name face))
+ (matches (string-match
+ context-coloring-level-face-regexp
+ face-string)))
+ (when matches
+ (setq actual-level (string-to-number
+ (substring face-string
+ (match-beginning 1)
+ (match-end 1))))
+ (= level actual-level)))))
+ (ert-fail (format (concat "Expected level at position %s, "
+ "which is \"%s\", to be %s; "
+ "but it was %s")
+ position
+ (buffer-substring-no-properties position (1+ position)) level
+ actual-level)))))
+
+ (defun context-coloring-test-assert-position-face (position face-regexp)
+ "Assert that the face at POSITION satisfies FACE-REGEXP."
+ (let ((face (get-text-property position 'face)))
+ (when (or
+ ;; Pass a non-string to do an `equal' check (against a symbol or nil).
+ (unless (stringp face-regexp)
+ (not (equal face-regexp face)))
+ ;; Otherwise do the matching.
+ (when (stringp face-regexp)
+ (not (string-match-p face-regexp (symbol-name face)))))
+ (ert-fail (format (concat "Expected face at position %s, "
+ "which is \"%s\", to be %s; "
+ "but it was %s")
+ position
+ (buffer-substring-no-properties position (1+ position)) face-regexp
+ face)))))
+
+ (defun context-coloring-test-assert-position-comment (position)
+ "Assert that the face at POSITION is a comment."
+ (context-coloring-test-assert-position-face
+ position "\\`font-lock-comment\\(-delimiter\\)?-face\\'"))
+
+ (defun context-coloring-test-assert-position-constant-comment (position)
+ "Assert that the face at POSITION is a constant comment."
+ (context-coloring-test-assert-position-face position '(font-lock-constant-face
+ font-lock-comment-face)))
+
+ (defun context-coloring-test-assert-position-string (position)
+ "Assert that the face at POSITION is a string."
+ (context-coloring-test-assert-position-face position 'font-lock-string-face))
+
+ (defun context-coloring-test-assert-position-nil (position)
+ "Assert that the face at POSITION is nil."
+ (context-coloring-test-assert-position-face position nil))
+
+ (defun context-coloring-test-assert-coloring (map)
+ "Assert that the current buffer's coloring will match MAP.
+
+ MAP's newlines should correspond to the current fixture.
+
+ The following characters appearing in MAP assert coloring for
+ corresponding points in the fixture:
+
+ 0-9: Level equals number.
+ C: Face is constant comment.
+ c: Face is comment.
+ n: Face is nil.
+ s: Face is string.
+
+ Any other characters are discarded. Characters \"x\" and any
+ other non-letters are guaranteed to always be discarded."
+ ;; Omit the superfluous, formatting-related leading newline. Can't use
+ ;; `save-excursion' here because if an assertion fails it will cause future
+ ;; tests to get messed up.
+ (goto-char (point-min))
+ (let* ((map (substring map 1))
+ (index 0)
+ char-string
+ char)
+ (while (< index (length map))
+ (setq char-string (substring map index (1+ index)))
+ (setq char (string-to-char char-string))
+ (cond
+ ;; Newline
+ ((= char 10)
+ (forward-line)
+ (beginning-of-line))
+ ;; Number
+ ((and (>= char 48)
+ (<= char 57))
+ (context-coloring-test-assert-position-level
+ (point) (string-to-number char-string))
+ (forward-char))
+ ;; 'C' = Constant comment
+ ((= char 67)
+ (context-coloring-test-assert-position-constant-comment (point))
+ (forward-char))
+ ;; 'c' = Comment
+ ((= char 99)
+ (context-coloring-test-assert-position-comment (point))
+ (forward-char))
+ ;; 'n' = nil
+ ((= char 110)
+ (context-coloring-test-assert-position-nil (point))
+ (forward-char))
+ ;; 's' = String
+ ((= char 115)
+ (context-coloring-test-assert-position-string (point))
+ (forward-char))
+ (t
+ (forward-char)))
+ (setq index (1+ index)))))
+
+ (context-coloring-test-deftest-js-js2 function-scopes
+ (lambda ()
+ (context-coloring-test-assert-coloring "
+ 000 0 0 11111111 11 110
+ 11111111 011 1
+ 111 1 1 22222222 22 221
+ 22222222 122 22
+ 1")))
+
+ (context-coloring-test-deftest-js-js2 global
+ (lambda ()
+ (context-coloring-test-assert-coloring "
+ (xxxxxxxx () {
+ 111 1 1 00000001xxx11
+ }());")))
+
+ (context-coloring-test-deftest-js2 block-scopes
+ (lambda ()
+ (context-coloring-test-assert-coloring "
+ (xxxxxxxx () {
+ 11 111 2
+ 222 12
+ 222 22
+ 2
+ }());"))
+ :before (lambda ()
+ (setq context-coloring-js-block-scopes t))
+ :after (lambda ()
+ (setq context-coloring-js-block-scopes nil)))
+
+ (context-coloring-test-deftest-js-js2 catch
+ (lambda ()
+ (context-coloring-test-assert-coloring "
+ (xxxxxxxx () {
+ 111 11 22222 222 2
+ 222 1 2 22
+ 222 22 33333 333 3
+ 333 1 3 33
+ 3
+ 2
+ }());")))
+
+ (context-coloring-test-deftest-js-js2 key-names
+ (lambda ()
+ (context-coloring-test-assert-coloring "
+ (xxxxxxxx () {
+ 111111 1
+ 11 11
+ 1 1 1
+ 11
+ }());")))
+
+ (context-coloring-test-deftest-js-js2 property-lookup
+ (lambda ()
+ (context-coloring-test-assert-coloring "
+ (xxxxxxxx () {
+ 0000001111111
+ 0000001 111111
+ 00000011111111111
+ }());")))
+
+ (context-coloring-test-deftest-js-js2 key-values
+ (lambda ()
+ (context-coloring-test-assert-coloring "
+ (xxxxxxxx () {
+ xxx x;
+ (xxxxxxxx () {
+ xxxxxx {
+ x: 1
+ };
+ }());
+ }());")))
+
+ (context-coloring-test-deftest-js-js2 syntactic-comments-and-strings
+ (lambda ()
+ (context-coloring-test-assert-coloring "
+ 0000 00
+ ccccccc
+ cccccccccc
+ ssssssssssss0"))
+ :fixture "comments-and-strings.js")
+
+ (context-coloring-test-deftest-js-js2 syntactic-comments
+ (lambda ()
+ (context-coloring-test-assert-coloring "
+ 0000 00
+ ccccccc
+ cccccccccc
+ 0000000000000"))
+ :fixture "comments-and-strings.js"
+ :before (lambda ()
+ (setq context-coloring-syntactic-strings nil))
+ :after (lambda ()
+ (setq context-coloring-syntactic-strings t)))
+
+ (context-coloring-test-deftest-js-js2 syntactic-strings
+ (lambda ()
+ (context-coloring-test-assert-coloring "
+ 0000 00
+ 0000000
+ 0000000000
+ ssssssssssss0"))
+ :fixture "comments-and-strings.js"
+ :before (lambda ()
+ (setq context-coloring-syntactic-comments nil))
+ :after (lambda ()
+ (setq context-coloring-syntactic-comments t)))
+
+ (context-coloring-test-deftest-js2 unterminated-comment
+ ;; As long as `add-text-properties' doesn't signal an error, this test passes.
+ (lambda ()))
+
+ (context-coloring-test-deftest-emacs-lisp defun
(lambda ()
(context-coloring-test-assert-coloring "
111111 000 1111 111 111111111 1111
0000 0 0 00
111111 01
- 111111 111")))
+ 111111 111
+ 111111 0 1sss11")))
- (context-coloring-test-deftest-emacs-lisp-mode lambda
+ (context-coloring-test-deftest-emacs-lisp defadvice
+ (lambda ()
+ (context-coloring-test-assert-coloring "
+ 1111111111 0 1111111 111111 11111 111 111111111
+ 2222 222 122
+ 22 1 2221")))
+
+ (context-coloring-test-deftest-emacs-lisp lambda
(lambda ()
(context-coloring-test-assert-coloring "
00000000 1111111 1111
11111111 11 2222222 2222
222 22 12 2221 111 0 00")))
- (context-coloring-test-deftest-emacs-lisp-mode quote
+ (context-coloring-test-deftest-emacs-lisp quote
(lambda ()
(context-coloring-test-assert-coloring "
+ (xxxxx 0000000 00 00000)
+ (xxx () (xxxxxxxxx (,0000)))
+
(xxxxx x (x)
(xx (xx x 111
111111 1 111 111
- 111111 1 1111111111 11 111 1 111 1 00001 10000 11 00001 1 100001111")))
+ 111111 1 1111111111 11 111 1 111 1 00001 10000 11 00001 1 10000
+ sss ccc
+ 1111
+
+ (xxxxxx '(sss cc
+ sss cc
+ ))
+
+ (xxxxxx () 111111 11111)")))
- (context-coloring-test-deftest-emacs-lisp-mode comment
+ (context-coloring-test-deftest-emacs-lisp splice
+ (lambda ()
+ (context-coloring-test-assert-coloring "
+ (xxxxxx ()
+ 111111 00001 100001)")))
+
+ (context-coloring-test-deftest-emacs-lisp comment
(lambda ()
;; Just check that the comment isn't parsed syntactically.
(context-coloring-test-assert-coloring "
(xxxxx x ()
- (xx (x xxxxx-xxxx xx) ;;;;;;;;;;
- 11 00000-0000 11))) ;;;;;;;;;;"))
- :setup (lambda ()
- (setq context-coloring-syntactic-comments t)))
+ (xx (x xxxxx-xxxx xx) cccccccccc
+ 11 00000-0000 11))) cccccccccc")))
- (context-coloring-test-deftest-emacs-lisp-mode string
+ (context-coloring-test-deftest-emacs-lisp string
(lambda ()
(context-coloring-test-assert-coloring "
(xxxxx x (x)
- (xxxxxx x x sss 1 0 sssss 0 1 sssssss11"))
- :setup (lambda ()
- (setq context-coloring-syntactic-strings t)))
+ (xxxxxx x x sss 1 0 sssss 0 1 sssssss11")))
- (context-coloring-test-deftest-emacs-lisp-mode ignored
+ (context-coloring-test-deftest-emacs-lisp ignored
(lambda ()
(context-coloring-test-assert-coloring "
(xxxxx x ()
- (x x 1 11 11 111 11 1 111 (1 1 1)))")))
+ (x x 1 11 11 111 111 11 11 11 1 111 (1 1 1)))")))
+
+ (context-coloring-test-deftest-emacs-lisp sexp
+ (lambda ()
+ (context-coloring-test-assert-coloring "
+ (xxx ()
+ `,@sss
+ `,@11
+ `,@11)")))
- (context-coloring-test-deftest-emacs-lisp-mode let
+ (context-coloring-test-deftest-emacs-lisp let
(lambda ()
(context-coloring-test-assert-coloring "
1111 11
22 02
22 000022
2222 2 2 2 00002211
- 1111 1 1 1 000011")))
+ 1111 1 1 1 000011
+
+ 1111 cc ccccccc
+ 1sss11")))
- (context-coloring-test-deftest-emacs-lisp-mode let*
+ (context-coloring-test-deftest-emacs-lisp let*
(lambda ()
(context-coloring-test-assert-coloring "
11111 11
2222 1 1 2 2 2 000022
1111 1 1 1 0 0 000011")))
+ (context-coloring-test-deftest-emacs-lisp cond
+ (lambda ()
+ (context-coloring-test-assert-coloring "
+ (xxx (x)
+ 11111
+ 11 11
+ 10000 11
+ 1111 1 00001 11
+ 11 11111 1 000011
+ cc c
+ sss1)")))
+
+ (context-coloring-test-deftest-emacs-lisp condition-case
+ (lambda ()
+ (context-coloring-test-assert-coloring "
+ 1111111111-1111 111
+ 111111 000 00001
+ 111111 111 00001
+ 1111111 111111 111 000011
+
+ (111111111-1111-111111-11111 111
+ cc c
+ (xxx () 222)
+ (11111 (xxx () 222))
+ sss)")))
+
+ (context-coloring-test-deftest-emacs-lisp dolist
+ (lambda ()
+ (context-coloring-test-assert-coloring "
+ 1111111 111111
+ 2222222 2222 1111 2222222
+ 3333333 33 33 222 1111 2222223321")))
+
(defun context-coloring-test-insert-unread-space ()
+ "Simulate the insertion of a space as if by a user."
(setq unread-command-events (cons '(t . 32)
unread-command-events)))
(defun context-coloring-test-remove-faces ()
+ "Remove all faces in the current buffer."
(remove-text-properties (point-min) (point-max) '(face nil)))
- (context-coloring-test-deftest-emacs-lisp-mode iteration
+ (context-coloring-test-deftest-emacs-lisp iteration
(lambda ()
- (let ((context-coloring-emacs-lisp-iterations-per-pause 1))
+ (let ((context-coloring-elisp-sexps-per-pause 2))
(context-coloring-colorize)
(context-coloring-test-assert-coloring "
- ;; `cc' `cc'
+ cc `CC' `CC'
(xxxxx x ())")
(context-coloring-test-remove-faces)
(context-coloring-test-insert-unread-space)
(context-coloring-colorize)
- ;; The first iteration will color the first part of the comment, but
- ;; that's it. Then it will be interrupted.
+ ;; Coloring is interrupted after the first "sexp" (the comment in this
+ ;; case).
(context-coloring-test-assert-coloring "
- ;; nnnn nnnn
- nnnnnn n nnn")))
- :setup (lambda ()
- (setq context-coloring-syntactic-comments t)
- (setq context-coloring-syntactic-strings t)))
+ cc `CC' `CC'
+ nnnnnn n nnn"))))
+
+ (context-coloring-test-deftest-emacs-lisp changed
+ (lambda ()
+ (context-coloring-test-remove-faces)
+ ;; Goto line 3.
+ (goto-char (point-min))
+ (forward-line (1- 3))
+ (insert " ")
+ ;; Mock `pos-visible-in-window-p' because in batch mode `get-buffer-window'
+ ;; returns nil. Emacs must not have a window in that environment.
+ (cl-letf (((symbol-function 'pos-visible-in-window-p)
+ (let ((calls 0))
+ (lambda ()
+ (prog1
+ ;; First and third calls start from center. Second and
+ ;; fourth calls are made immediately after moving past
+ ;; the first defun in either direction "off screen".
+ (cond
+ ((= calls 0) t)
+ ((= calls 1) nil)
+ ((= calls 2) t)
+ ((= calls 4) nil))
+ (setq calls (1+ calls)))))))
+ (context-coloring-colorize))
+ (context-coloring-test-assert-coloring "
+ nnnn n nnn nnnnnnnn
+ 0000
+
+ 0000
+ nnnnn n nnn nnnnnnnn")))
+
+ (context-coloring-test-deftest-emacs-lisp unbalanced-parenthesis
+ (lambda ()
+ (context-coloring-test-assert-coloring "
+ 1111 111
+ nnnn nn")))
(provide 'context-coloring-test)
--- /dev/null
+ (l1) ; Not colored.
+ (l2)
+
+ (l4)
+ (l5) ; Not colored.
--- /dev/null
+ (let (a)
+ (cond
+ (a t)
+ (free t)
+ ((eq a free) t)
+ (t (list a free))
+ ;; c
+ "s"))
--- /dev/null
+ (condition-case err
+ (progn err free)
+ (error err free)
+ ((debug error) err free))
+
+ (condition-case-unless-debug nil
+ ;; c
+ (let () nil)
+ (error (let () nil))
+ "s")
--- /dev/null
+ (defadvice a (before advice first (b) activate)
+ (let ((c b))
+ (+ b c)))
(defun a)
(defun ())
+ (defun b ("a"))
--- /dev/null
+ (lambda (list)
+ (dolist (var list result)
+ (lambda () (+ var list result))))
(defun a ()
- (+ a 1 +1 -1 1.0 :a t nil (0 . 0)))
+ (+ a 1 +1 -1 1.0 #x0 ,a \a :a t nil (0 . 0)))
(c free))
(and a b c free))))
(and a b c free))
+
+ (let ;; comment
+ ("s"))
+ (quote (lambda () free))
+ (let () (backquote (,free)))
+
(defun a (a)
(or (eq a 'b)
(equal a '(a b))
- (equal a `(,(append () `(a b ,(+ 1 free) ,free b) free) b ,free))))
+ (equal a `(,(append () `(a b ,(+ 1 free) ,free b) free) b ,free
+ "s" ; c
+ ))))
+
+ (append '("a" ; b
+ "b" ; a
+ ))
+
+ (lambda () '((?\" ?\")))
--- /dev/null
+ (let ()
+ `,@"a"
+ `,@'b
+ `,@\c)
--- /dev/null
+ (lambda ()
+ `(,@(a free) ,free))
--- /dev/null
+ (let ())
+ (let ()