X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/ded3e3d8164880c92301010fce1426ae20fb8d12..6a70ef0d8173b57817bcc8a013eb86c8583e74fc:/lisp/fast-lock.el diff --git a/lisp/fast-lock.el b/lisp/fast-lock.el index 566b75b6ca..68b6683305 100644 --- a/lisp/fast-lock.el +++ b/lisp/fast-lock.el @@ -1,10 +1,11 @@ ;;; fast-lock.el --- Automagic text properties caching for fast Font Lock mode. -;; Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. +;; Copyright (C) 1994, 1995, 1996, 1997, 1998 Free Software Foundation, Inc. -;; Author: Simon Marshall +;; Author: Simon Marshall +;; Maintainer: FSF ;; Keywords: faces files -;; Version: 3.11 +;; Version: 3.14 ;;; This file is part of GNU Emacs. @@ -160,6 +161,22 @@ ;; - Added `fast-lock-verbose' ;; - XEmacs: Add `font-lock-value-in-major-mode' if necessary ;; - Removed `fast-lock-submit-bug-report' and bade farewell +;; 3.11--3.12: +;; - Added Custom support (Hrvoje Niksic help) +;; - Made `save-buffer-state' wrap `inhibit-point-motion-hooks' +;; - Made `fast-lock-cache-data' simplify calls of `font-lock-compile-keywords' +;; 3.12--3.13: +;; - Removed `byte-*' variables from `eval-when-compile' (Erik Naggum hint) +;; - Changed structure of cache to include `font-lock-syntactic-keywords' +;; - Made `fast-lock-save-cache-1' save syntactic fontification data +;; - Made `fast-lock-cache-data' take syntactic fontification data +;; - Added `fast-lock-get-syntactic-properties' +;; - Renamed `fast-lock-set-face-properties' to `fast-lock-add-properties' +;; - Made `fast-lock-add-properties' add syntactic and face fontification data +;; 3.13--3.14: +;; - Made `fast-lock-cache-name' cope with `windowsnt' (Geoff Voelker fix) +;; - Made `fast-lock-verbose' use `other' widget (Andreas Schwab fix) +;; - Used `with-temp-message' where possible to make messages temporary. ;;; Code: @@ -174,17 +191,12 @@ ;; We don't do this at the top-level as we only use non-autoloaded macros. (require 'cl) ;; - ;; I prefer lazy code---and lazy mode. - (setq byte-compile-dynamic t byte-compile-dynamic-docstrings t) - ;; But, we make sure that the code is as zippy as can be. - (setq byte-optimize t) - ;; ;; We use this to preserve or protect things when modifying text properties. (defmacro save-buffer-state (varlist &rest body) "Bind variables according to VARLIST and eval BODY restoring buffer state." (` (let* ((,@ (append varlist - '((modified (buffer-modified-p)) - (inhibit-read-only t) (buffer-undo-list t) + '((modified (buffer-modified-p)) (buffer-undo-list t) + (inhibit-read-only t) (inhibit-point-motion-hooks t) before-change-functions after-change-functions deactivate-mark buffer-file-name buffer-file-truename)))) (,@ body) @@ -201,13 +213,31 @@ (let ((faces (, face))) (while (unless (memq (car faces) fast-lock-save-faces) (setq faces (cdr faces)))) - faces)))))) + faces))))) + ;; + ;; We use this for compatibility with a future Emacs. + (or (fboundp 'with-temp-message) + (defmacro with-temp-message (message &rest body) + (` (let ((temp-message (, message)) current-message) + (unwind-protect + (progn + (when temp-message + (setq current-message (current-message)) + (message temp-message)) + (,@ body)) + (when temp-message + (message current-message))))))) + ;; + ;; We use this for compatibility with a future Emacs. + (or (fboundp 'defcustom) + (defmacro defcustom (symbol value doc &rest args) + (` (defvar (, symbol) (, value) (, doc)))))) ;(defun fast-lock-submit-bug-report () ; "Submit via mail a bug report on fast-lock.el." ; (interactive) ; (let ((reporter-prompt-for-summary-p t)) -; (reporter-submit-bug-report "simon@gnu.ai.mit.edu" "fast-lock 3.11" +; (reporter-submit-bug-report "simon@gnu.org" "fast-lock 3.14" ; '(fast-lock-cache-directories fast-lock-minimum-size ; fast-lock-save-others fast-lock-save-events fast-lock-save-faces ; fast-lock-verbose) @@ -220,16 +250,33 @@ ;Start a fresh editor via `" invocation-name " -no-init-file -no-site-file'. ;In the `*scratch*' buffer, evaluate:")))) -(defvar fast-lock-mode nil) -(defvar fast-lock-cache-timestamp nil) ; for saving/reading -(defvar fast-lock-cache-filename nil) ; for deleting +(defvar fast-lock-mode nil) ; Whether we are turned on. +(defvar fast-lock-cache-timestamp nil) ; For saving/reading. +(defvar fast-lock-cache-filename nil) ; For deleting. ;; User Variables: -(defgroup fast-lock nil - "Automagic text properties caching for fast Font Lock mode" - :group 'faces) - +(defcustom fast-lock-minimum-size 25600 + "*Minimum size of a buffer for cached fontification. +Only buffers more than this can have associated Font Lock cache files saved. +If nil, means cache files are never created. +If a list, each element should be a cons pair of the form (MAJOR-MODE . SIZE), +where MAJOR-MODE is a symbol or t (meaning the default). For example: + ((c-mode . 25600) (c++-mode . 25600) (rmail-mode . 1048576)) +means that the minimum size is 25K for buffers in C or C++ modes, one megabyte +for buffers in Rmail mode, and size is irrelevant otherwise." + :type '(choice (const :tag "none" nil) + (integer :tag "size") + (repeat :menu-tag "mode specific" :tag "mode specific" + :value ((t . nil)) + (cons :tag "Instance" + (radio :tag "Mode" + (const :tag "all" t) + (symbol :tag "name")) + (radio :tag "Size" + (const :tag "none" nil) + (integer :tag "size"))))) + :group 'fast-lock) (defcustom fast-lock-cache-directories '("." "~/.emacs-flc") ; - `internal', keep each file's Font Lock cache file in the same file. @@ -250,20 +297,10 @@ For example: would cause a file's current directory to be used if the file is under your home directory hierarchy, or otherwise the absolute directory `~/.emacs-flc'." - :type '(repeat (choice (cons regexp directory) directory)) - :group 'fast-lock) - -(defcustom fast-lock-minimum-size (* 25 1024) - "*Minimum size of a buffer for cached fontification. -Only buffers more than this can have associated Font Lock cache files saved. -If nil, means cache files are never created. -If a list, each element should be a cons pair of the form (MAJOR-MODE . SIZE), -where MAJOR-MODE is a symbol or t (meaning the default). For example: - ((c-mode . 25600) (c++-mode . 25600) (rmail-mode . 1048576)) -means that the minimum size is 25K for buffers in C or C++ modes, one megabyte -for buffers in Rmail mode, and size is irrelevant otherwise." - :type '(choice (integer :tag "Size") (repeat (cons (symbol :tag "Major Mode") - (integer :tag "Size")))) + :type '(repeat (radio (directory :tag "directory") + (cons :tag "Matching" + (regexp :tag "regexp") + (directory :tag "directory")))) :group 'fast-lock) (defcustom fast-lock-save-events '(kill-buffer kill-emacs) @@ -271,7 +308,9 @@ for buffers in Rmail mode, and size is irrelevant otherwise." Valid events are `save-buffer', `kill-buffer' and `kill-emacs'. If concurrent editing sessions use the same associated cache file for a file's buffer, then you should add `save-buffer' to this list." - :type '(set (const kill-buffer) (const save-buffer) (const kill-emacs)) + :type '(set (const :tag "buffer saving" save-buffer) + (const :tag "buffer killing" kill-buffer) + (const :tag "emacs killing" kill-emacs)) :group 'fast-lock) (defcustom fast-lock-save-others t @@ -281,18 +320,20 @@ Font Lock cache files saved. Ownership may be unknown for networked files." :type 'boolean :group 'fast-lock) +(defcustom fast-lock-verbose font-lock-verbose + "*If non-nil, means show status messages for cache processing. +If a number, only buffers greater than this size have processing messages." + :type '(choice (const :tag "never" nil) + (other :tag "always" t) + (integer :tag "size")) + :group 'fast-lock) + (defvar fast-lock-save-faces (when (save-match-data (string-match "XEmacs" (emacs-version))) ;; XEmacs uses extents for everything, so we have to pick the right ones. font-lock-face-list) "Faces that will be saved in a Font Lock cache file. If nil, means information for all faces will be saved.") - -(defcustom fast-lock-verbose font-lock-verbose - "*If non-nil, means show status messages for cache processing. -If a number, only buffers greater than this size have processing messages." - :type '(choice integer boolean) - :group 'fast-lock) ;; User Functions: @@ -512,7 +553,7 @@ See `fast-lock-cache-directory'." (concat buffer-file-name ".flc") (let* ((bufile (expand-file-name buffer-file-truename)) (chars-alist - (if (eq system-type 'emx) + (if (memq system-type '(emx windows-nt)) '((?/ . (?#)) (?# . (?# ?#)) (?: . (?\;)) (?\; . (?\; ?\;))) '((?/ . (?#)) (?# . (?# ?#))))) (mapchars @@ -524,66 +565,86 @@ See `fast-lock-cache-directory'." ;; Font Lock Cache Processing Functions: +;; The version 3 format of the cache is: +;; +;; (fast-lock-cache-data VERSION TIMESTAMP +;; font-lock-syntactic-keywords SYNTACTIC-PROPERTIES +;; font-lock-keywords FACE-PROPERTIES) + (defun fast-lock-save-cache-1 (file timestamp) - ;; Save the FILE with the TIMESTAMP as: - ;; (fast-lock-cache-data Version=2 TIMESTAMP font-lock-keywords PROPERTIES). + ;; Save the FILE with the TIMESTAMP plus fontification data. ;; Returns non-nil if a save was attempted to a writable cache file. (let ((tpbuf (generate-new-buffer " *fast-lock*")) (verbose (if (numberp fast-lock-verbose) (> (buffer-size) fast-lock-verbose) fast-lock-verbose)) (saved t)) - (if verbose (message "Saving %s font lock cache..." (buffer-name))) - (condition-case nil - (save-excursion - (print (list 'fast-lock-cache-data 2 - (list 'quote timestamp) - (list 'quote font-lock-keywords) - (list 'quote (fast-lock-get-face-properties))) - tpbuf) - (set-buffer tpbuf) - (write-region (point-min) (point-max) file nil 'quietly) - (setq fast-lock-cache-timestamp timestamp - fast-lock-cache-filename file)) - (error (setq saved 'error)) (quit (setq saved 'quit))) - (kill-buffer tpbuf) - (if verbose (message "Saving %s font lock cache...%s" (buffer-name) - (cond ((eq saved 'error) "failed") - ((eq saved 'quit) "aborted") - (t "done")))) + (with-temp-message + (when verbose + (format "Saving %s font lock cache..." (buffer-name))) + (condition-case nil + (save-excursion + (print (list 'fast-lock-cache-data 3 + (list 'quote timestamp) + (list 'quote font-lock-syntactic-keywords) + (list 'quote (fast-lock-get-syntactic-properties)) + (list 'quote font-lock-keywords) + (list 'quote (fast-lock-get-face-properties))) + tpbuf) + (set-buffer tpbuf) + (write-region (point-min) (point-max) file nil 'quietly) + (setq fast-lock-cache-timestamp timestamp + fast-lock-cache-filename file)) + (error (setq saved 'error)) (quit (setq saved 'quit))) + (kill-buffer tpbuf)) + (cond ((eq saved 'quit) + (message "Saving %s font lock cache...quit" (buffer-name))) + ((eq saved 'error) + (message "Saving %s font lock cache...failed" (buffer-name)))) ;; We return non-nil regardless of whether a failure occurred. saved)) -(defun fast-lock-cache-data (version timestamp keywords properties +(defun fast-lock-cache-data (version timestamp + syntactic-keywords syntactic-properties + keywords face-properties &rest ignored) - ;; Change from (HIGH LOW) for back compatibility. Remove for version 3! - (when (consp (cdr-safe timestamp)) - (setcdr timestamp (nth 1 timestamp))) - ;; Compile KEYWORDS and `font-lock-keywords' in case one is and one isn't. - (let ((current font-lock-keywords)) - (setq keywords (font-lock-compile-keywords keywords) - font-lock-keywords (font-lock-compile-keywords current))) - ;; Use the Font Lock cache PROPERTIES if we're using cache VERSION format 2, - ;; the current buffer's file timestamp matches the TIMESTAMP, and the current - ;; buffer's font-lock-keywords are the same as KEYWORDS. + ;; Find value of syntactic keywords in case it is a symbol. + (setq font-lock-syntactic-keywords (font-lock-eval-keywords + font-lock-syntactic-keywords)) + ;; Compile all keywords in case some are and some aren't. + (when font-lock-syntactic-keywords + (setq font-lock-syntactic-keywords (font-lock-compile-keywords + font-lock-syntactic-keywords))) + (when syntactic-keywords + (setq syntactic-keywords (font-lock-compile-keywords syntactic-keywords))) + (setq font-lock-keywords (font-lock-compile-keywords font-lock-keywords) + keywords (font-lock-compile-keywords keywords)) + ;; Use the Font Lock cache SYNTACTIC-PROPERTIES and FACE-PROPERTIES if we're + ;; using cache VERSION format 3, the current buffer's file timestamp matches + ;; the TIMESTAMP, the current buffer's `font-lock-syntactic-keywords' are the + ;; same as SYNTACTIC-KEYWORDS, and the current buffer's `font-lock-keywords' + ;; are the same as KEYWORDS. (let ((buf-timestamp (visited-file-modtime)) (verbose (if (numberp fast-lock-verbose) (> (buffer-size) fast-lock-verbose) fast-lock-verbose)) (loaded t)) - (if (or (/= version 2) + (if (or (/= version 3) (buffer-modified-p) (not (equal timestamp buf-timestamp)) + (not (equal syntactic-keywords font-lock-syntactic-keywords)) (not (equal keywords font-lock-keywords))) (setq loaded nil) - (if verbose (message "Loading %s font lock cache..." (buffer-name))) - (condition-case nil - (fast-lock-set-face-properties properties) - (error (setq loaded 'error)) (quit (setq loaded 'quit))) - (if verbose (message "Loading %s font lock cache...%s" (buffer-name) - (cond ((eq loaded 'error) "failed") - ((eq loaded 'quit) "aborted") - (t "done"))))) + (with-temp-message + (when verbose + (format "Loading %s font lock cache..." (buffer-name))) + (condition-case nil + (fast-lock-add-properties syntactic-properties face-properties) + (error (setq loaded 'error)) (quit (setq loaded 'quit)))) + (cond ((eq loaded 'quit) + (message "Loading %s font lock cache...quit" (buffer-name))) + ((eq loaded 'error) + (message "Loading %s font lock cache...failed" (buffer-name))))) (setq font-lock-fontified (eq loaded t) fast-lock-cache-timestamp (and (eq loaded t) timestamp)))) @@ -592,7 +653,7 @@ See `fast-lock-cache-directory'." ;; This is fast, but fails if adjacent characters have different `face' text ;; properties. Maybe that's why I dropped it in the first place? ;(defun fast-lock-get-face-properties () -; "Return a list of all `face' text properties in the current buffer. +; "Return a list of `face' text properties in the current buffer. ;Each element of the list is of the form (VALUE START1 END1 START2 END2 ...) ;where VALUE is a `face' property value and STARTx and ENDx are positions." ; (save-restriction @@ -612,7 +673,7 @@ See `fast-lock-cache-directory'." ;; This is slow, but copes if adjacent characters have different `face' text ;; properties, but fails if they are lists. ;(defun fast-lock-get-face-properties () -; "Return a list of all `face' text properties in the current buffer. +; "Return a list of `face' text properties in the current buffer. ;Each element of the list is of the form (VALUE START1 END1 START2 END2 ...) ;where VALUE is a `face' property value and STARTx and ENDx are positions. ;Only those `face' VALUEs in `fast-lock-save-faces' are returned." @@ -632,7 +693,7 @@ See `fast-lock-cache-directory'." ; properties))) (defun fast-lock-get-face-properties () - "Return a list of all `face' text properties in the current buffer. + "Return a list of `face' text properties in the current buffer. Each element of the list is of the form (VALUE START1 END1 START2 END2 ...) where VALUE is a `face' property value and STARTx and ENDx are positions." (save-restriction @@ -650,21 +711,50 @@ where VALUE is a `face' property value and STARTx and ENDx are positions." (setq start (text-property-not-all end (point-max) 'face nil))) properties))) -(defun fast-lock-set-face-properties (properties) - "Set all `face' text properties to PROPERTIES in the current buffer. -Any existing `face' text properties are removed first. -See `fast-lock-get-face-properties' for the format of PROPERTIES." +(defun fast-lock-get-syntactic-properties () + "Return a list of `syntax-table' text properties in the current buffer. +See `fast-lock-get-face-properties'." + (save-restriction + (widen) + (let ((start (text-property-not-all (point-min) (point-max) 'syntax-table + nil)) + end properties value cell) + (while start + (setq end (next-single-property-change start 'syntax-table nil + (point-max)) + value (get-text-property start 'syntax-table)) + ;; Make, or add to existing, list of regions with same `syntax-table'. + (if (setq cell (assoc value properties)) + (setcdr cell (cons start (cons end (cdr cell)))) + (push (list value start end) properties)) + (setq start (text-property-not-all end (point-max) 'syntax-table nil))) + properties))) + +(defun fast-lock-add-properties (syntactic-properties face-properties) + "Add `syntax-table' and `face' text properties to the current buffer. +Any existing `syntax-table' and `face' text properties are removed first. +See `fast-lock-get-face-properties'." (save-buffer-state (plist regions) (save-restriction (widen) (font-lock-unfontify-region (point-min) (point-max)) - (while properties - (setq plist (list 'face (car (car properties))) - regions (cdr (car properties)) - properties (cdr properties)) - ;; Set the `face' property for each start/end region. + ;; + ;; Set the `syntax-table' property for each start/end region. + (while syntactic-properties + (setq plist (list 'syntax-table (car (car syntactic-properties))) + regions (cdr (car syntactic-properties)) + syntactic-properties (cdr syntactic-properties)) (while regions - (set-text-properties (nth 0 regions) (nth 1 regions) plist) + (add-text-properties (nth 0 regions) (nth 1 regions) plist) + (setq regions (nthcdr 2 regions)))) + ;; + ;; Set the `face' property for each start/end region. + (while face-properties + (setq plist (list 'face (car (car face-properties))) + regions (cdr (car face-properties)) + face-properties (cdr face-properties)) + (while regions + (add-text-properties (nth 0 regions) (nth 1 regions) plist) (setq regions (nthcdr 2 regions))))))) ;; Functions for XEmacs: @@ -674,7 +764,7 @@ See `fast-lock-get-face-properties' for the format of PROPERTIES." ;; It would be better to use XEmacs' `map-extents' over extents with a ;; `font-lock' property, but `face' properties are on different extents. (defun fast-lock-get-face-properties () - "Return a list of all `face' text properties in the current buffer. + "Return a list of `face' text properties in the current buffer. Each element of the list is of the form (VALUE START1 END1 START2 END2 ...) where VALUE is a `face' property value and STARTx and ENDx are positions. Only those `face' VALUEs in `fast-lock-save-faces' are returned." @@ -697,40 +787,59 @@ Only those `face' VALUEs in `fast-lock-save-faces' are returned." nil)))) properties))) ;; + ;; XEmacs does not support the `syntax-table' text property. + (defalias 'fast-lock-get-syntactic-properties + 'ignore) + ;; ;; Make extents just like XEmacs' font-lock.el does. - (defun fast-lock-set-face-properties (properties) - "Set all `face' text properties to PROPERTIES in the current buffer. + (defun fast-lock-add-properties (syntactic-properties face-properties) + "Set `face' text properties in the current buffer. Any existing `face' text properties are removed first. -See `fast-lock-get-face-properties' for the format of PROPERTIES." +See `fast-lock-get-face-properties'." (save-restriction (widen) (font-lock-unfontify-region (point-min) (point-max)) - (while properties - (let ((face (car (car properties))) - (regions (cdr (car properties)))) - ;; Set the `face' property, etc., for each start/end region. + ;; Set the `face' property, etc., for each start/end region. + (while face-properties + (let ((face (car (car face-properties))) + (regions (cdr (car face-properties)))) (while regions (font-lock-set-face (nth 0 regions) (nth 1 regions) face) (setq regions (nthcdr 2 regions))) - (setq properties (cdr properties)))))) + (setq face-properties (cdr face-properties)))) + ;; XEmacs does not support the `syntax-table' text property. + )) ;; ;; XEmacs 19.12 font-lock.el's `font-lock-fontify-buffer' runs a hook. (add-hook 'font-lock-after-fontify-buffer-hook 'fast-lock-after-fontify-buffer)) +(unless (boundp 'font-lock-syntactic-keywords) + (defvar font-lock-syntactic-keywords nil)) + (unless (boundp 'font-lock-inhibit-thing-lock) - (defvar font-lock-inhibit-thing-lock nil - "List of Font Lock mode related modes that should not be turned on.")) + (defvar font-lock-inhibit-thing-lock nil)) + +(unless (fboundp 'font-lock-compile-keywords) + (defalias 'font-lock-compile-keywords 'identity)) + +(unless (fboundp 'font-lock-eval-keywords) + (defun font-lock-eval-keywords (keywords) + (if (symbolp keywords) + (font-lock-eval-keywords (if (fboundp keywords) + (funcall keywords) + (eval keywords))) + keywords))) (unless (fboundp 'font-lock-value-in-major-mode) (defun font-lock-value-in-major-mode (alist) - ;; Return value in ALIST for `major-mode'. (if (consp alist) (cdr (or (assq major-mode alist) (assq t alist))) alist))) -(unless (fboundp 'font-lock-compile-keywords) - (defalias 'font-lock-compile-keywords 'identity)) +(unless (fboundp 'current-message) + (defun current-message () + "")) ;; Install ourselves: @@ -739,7 +848,9 @@ See `fast-lock-get-face-properties' for the format of PROPERTIES." (add-hook 'kill-emacs-hook 'fast-lock-save-caches-before-kill-emacs) ;;;###autoload -(if (fboundp 'add-minor-mode) (add-minor-mode 'fast-lock-mode nil)) +(when (fboundp 'add-minor-mode) + (defvar fast-lock-mode nil) + (add-minor-mode 'fast-lock-mode nil)) ;;;###dont-autoload (unless (assq 'fast-lock-mode minor-mode-alist) (setq minor-mode-alist (append minor-mode-alist '((fast-lock-mode nil)))))