Mercurial > hg > xemacs-beta

comparison lisp/packages/fast-lock.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents 4103f0995bd7
children 0d2f883870bc
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;; fast-lock.el --- Automagic text properties caching for fast Font Lock mode. 1 ;;; fast-lock.el --- Automagic text properties caching for fast Font Lock mode.
2 2
3 ;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. 3 ;; Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc.
4 4
5 ;; Author: Simon Marshall <simon@gnu.ai.mit.edu> 5 ;; Author: Simon Marshall <simon@gnu.ai.mit.edu>
6 ;; Keywords: faces files 6 ;; Keywords: faces files
7 ;; Version: 3.11.01 7 ;; Version: 3.10.01
8 8
9 ;;; This file is part of GNU Emacs. 9 ;; This file is part of XEmacs.
10 10 ;;
11 ;; GNU Emacs is free software; you can redistribute it and/or modify 11 ;; XEmacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by 12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option) 13 ;; the Free Software Foundation; either version 2 of the License, or
14 ;; any later version. 14 ;; (at your option) any later version.
15 15 ;;
16 ;; GNU Emacs is distributed in the hope that it will be useful, 16 ;; XEmacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details. 19 ;; GNU General Public License for more details.
20 20 ;;
21 ;; You should have received a copy of the GNU General Public License 21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the 22 ;; along with XEmacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA. 24 ;; Boston, MA 02111-1307, USA.
25 25
26 ;;; Synched up with: FSF 19.34.
27
26 ;;; Commentary: 28 ;;; Commentary:
27 29
28 ;; Lazy Lock mode is a Font Lock support mode. 30 ;; Purpose:
29 ;; It makes visiting a file in Font Lock mode faster by restoring its face text 31 ;;
30 ;; properties from automatically saved associated Font Lock cache files. 32 ;; To make visiting a file in `font-lock-mode' faster by restoring its face
33 ;; text properties from automatically saved associated Font Lock cache files.
31 ;; 34 ;;
32 ;; See caveats and feedback below. 35 ;; See caveats and feedback below.
33 ;; See also the lazy-lock package. (But don't use the two at the same time!) 36 ;; See also the lazy-lock package. (But don't use the two at the same time!)
34 37
35 ;; Installation: 38 ;; Installation:
50 ;; A cache will be saved when visiting a compressed file using crypt++, but not 53 ;; A cache will be saved when visiting a compressed file using crypt++, but not
51 ;; be read. This is a "feature"/"consequence"/"bug" of crypt++. 54 ;; be read. This is a "feature"/"consequence"/"bug" of crypt++.
52 ;; 55 ;;
53 ;; Version control packages are likely to stamp all over file modification 56 ;; Version control packages are likely to stamp all over file modification
54 ;; times. Therefore the act of checking out may invalidate a cache. 57 ;; times. Therefore the act of checking out may invalidate a cache.
58
59 ;; Feedback:
60 ;;
61 ;; Feedback is welcome.
62 ;; To submit a bug report (or make comments) please use the mechanism provided:
63 ;;
64 ;; M-x fast-lock-submit-bug-report RET
55 65
56 ;; History: 66 ;; History:
57 ;; 67 ;;
58 ;; 0.02--1.00: 68 ;; 0.02--1.00:
59 ;; - Changed name from turbo-prop to fast-lock. Automagic for font-lock only 69 ;; - Changed name from turbo-prop to fast-lock. Automagic for font-lock only
154 ;; - XEmacs: Made `fast-lock-save-faces' default to `font-lock-face-list' 164 ;; - XEmacs: Made `fast-lock-save-faces' default to `font-lock-face-list'
155 ;; - Made `fast-lock-save-cache' use `font-lock-value-in-major-mode' 165 ;; - Made `fast-lock-save-cache' use `font-lock-value-in-major-mode'
156 ;; - Wrap with `save-buffer-state' (Ray Van Tassle report) 166 ;; - Wrap with `save-buffer-state' (Ray Van Tassle report)
157 ;; - Made `fast-lock-mode' wrap `font-lock-support-mode' 167 ;; - Made `fast-lock-mode' wrap `font-lock-support-mode'
158 ;; 3.10--3.11: 168 ;; 3.10--3.11:
159 ;; - Made `fast-lock-get-face-properties' cope with face lists 169
160 ;; - Added `fast-lock-verbose'
161 ;; - XEmacs: Add `font-lock-value-in-major-mode' if necessary
162 ;; - Removed `fast-lock-submit-bug-report' and bade farewell
163 ;; 3.10--3.11:
164
165 ;;; Code:
166
167 (require 'font-lock) 170 (require 'font-lock)
168 171
169 ;; Make sure fast-lock.el is supported. 172 ;; Make sure fast-lock.el is supported.
170 (if (and (eq system-type 'ms-dos) (not (msdos-long-file-names))) 173 (if (and (eq system-type 'ms-dos) (not (msdos-long-file-names)))
171 (error "`fast-lock' was written for long file name systems")) 174 (error "`fast-lock' was written for long file name systems"))
189 before-change-functions after-change-functions 192 before-change-functions after-change-functions
190 deactivate-mark buffer-file-name buffer-file-truename)))) 193 deactivate-mark buffer-file-name buffer-file-truename))))
191 (,@ body) 194 (,@ body)
192 (when (and (not modified) (buffer-modified-p)) 195 (when (and (not modified) (buffer-modified-p))
193 (set-buffer-modified-p nil))))) 196 (set-buffer-modified-p nil)))))
194 (put 'save-buffer-state 'lisp-indent-function 1) 197 (put 'save-buffer-state 'lisp-indent-function 1))
195 ;; 198
196 ;; We use this to verify that a face should be saved. 199 (defun fast-lock-submit-bug-report ()
197 (defmacro fast-lock-save-facep (face) 200 "Submit via mail a bug report on fast-lock.el."
198 "Return non-nil if FACE is one of `fast-lock-save-faces'." 201 (interactive)
199 (` (or (null fast-lock-save-faces) 202 (let ((reporter-prompt-for-summary-p t))
200 (if (symbolp (, face)) 203 (reporter-submit-bug-report "simon@gnu.ai.mit.edu" "fast-lock 3.10.01"
201 (memq (, face) fast-lock-save-faces) 204 '(fast-lock-cache-directories fast-lock-minimum-size
202 (let ((faces (, face))) 205 fast-lock-save-others fast-lock-save-events fast-lock-save-faces)
203 (while (unless (memq (car faces) fast-lock-save-faces) 206 nil nil
204 (setq faces (cdr faces)))) 207 (concat "Hi Si.,
205 faces)))))) 208
206 209 I want to report a bug. I've read the `Bugs' section of `Info' on Emacs, so I
207 ;(defun fast-lock-submit-bug-report () 210 know how to make a clear and unambiguous report. To reproduce the bug:
208 ; "Submit via mail a bug report on fast-lock.el." 211
209 ; (interactive) 212 Start a fresh editor via `" invocation-name " -no-init-file -no-site-file'.
210 ; (let ((reporter-prompt-for-summary-p t)) 213 In the `*scratch*' buffer, evaluate:"))))
211 ; (reporter-submit-bug-report "simon@gnu.ai.mit.edu" "fast-lock 3.11.01" 214
212 ; '(fast-lock-cache-directories fast-lock-minimum-size 215 ;;;###autoload
213 ; fast-lock-save-others fast-lock-save-events fast-lock-save-faces 216 (defvar fast-lock-mode nil)
214 ; fast-lock-verbose) 217 (defvar fast-lock-cache-timestamp nil) ; for saving/reading
215 ; nil nil 218 (defvar fast-lock-cache-filename nil) ; for deleting
216 ; (concat "Hi Si.,
217 ;
218 ;I want to report a bug. I've read the `Bugs' section of `Info' on Emacs, so I
219 ;know how to make a clear and unambiguous report. To reproduce the bug:
220 ;
221 ;Start a fresh editor via `" invocation-name " -no-init-file -no-site-file'.
222 ;In the `*scratch*' buffer, evaluate:"))))
223
224 (defvar fast-lock-mode nil) ; Whether we are turned on.
225 (defvar fast-lock-cache-timestamp nil) ; For saving/reading.
226 (defvar fast-lock-cache-filename nil) ; For deleting.
227 219
228 ;; User Variables: 220 ;; User Variables:
229 221
230 (defvar fast-lock-cache-directories '("." "~/.emacs-flc") 222 (defvar fast-lock-cache-directories '("." "~/.emacs-flc")
231 ; - `internal', keep each file's Font Lock cache file in the same file. 223 ; - `internal', keep each file's Font Lock cache file in the same file.
272 (when (save-match-data (string-match "XEmacs" (emacs-version))) 264 (when (save-match-data (string-match "XEmacs" (emacs-version)))
273 ;; XEmacs uses extents for everything, so we have to pick the right ones. 265 ;; XEmacs uses extents for everything, so we have to pick the right ones.
274 font-lock-face-list) 266 font-lock-face-list)
275 "Faces that will be saved in a Font Lock cache file. 267 "Faces that will be saved in a Font Lock cache file.
276 If nil, means information for all faces will be saved.") 268 If nil, means information for all faces will be saved.")
277
278 (defvar fast-lock-verbose font-lock-verbose
279 "*If non-nil, means show status messages for cache processing.
280 If a number, only buffers greater than this size have processing messages.")
281 269
282 ;; User Functions: 270 ;; User Functions:
283 271
284 ;;;###autoload 272 ;;;###autoload
285 (defun fast-lock-mode (&optional arg) 273 (defun fast-lock-mode (&optional arg)
292 If Fast Lock mode is enabled, and the current buffer does not contain any text 280 If Fast Lock mode is enabled, and the current buffer does not contain any text
293 properties, any associated Font Lock cache is used if its timestamp matches the 281 properties, any associated Font Lock cache is used if its timestamp matches the
294 buffer's file, and its `font-lock-keywords' match those that you are using. 282 buffer's file, and its `font-lock-keywords' match those that you are using.
295 283
296 Font Lock caches may be saved: 284 Font Lock caches may be saved:
297 - When you save the file's buffer. 285 - When you save the file's buffer.
298 - When you kill an unmodified file's buffer. 286 - When you kill an unmodified file's buffer.
299 - When you exit Emacs, for all unmodified or saved buffers. 287 - When you exit Emacs, for all unmodified or saved buffers.
300 Depending on the value of `fast-lock-save-events'. 288 Depending on the value of `fast-lock-save-events'.
301 See also the commands `fast-lock-read-cache' and `fast-lock-save-cache'. 289 See also the commands `fast-lock-read-cache' and `fast-lock-save-cache'.
302 290
303 Use \\[font-lock-fontify-buffer] to fontify the buffer if the cache is bad. 291 Use \\[font-lock-fontify-buffer] to fontify the buffer if the cache is bad.
304 292
305 Various methods of control are provided for the Font Lock cache. In general, 293 Various methods of control are provided for the Font Lock cache. In general,
306 see variable `fast-lock-cache-directories' and function `fast-lock-cache-name'. 294 see variable `fast-lock-cache-directories' and function `fast-lock-cache-name'.
307 For saving, see variables `fast-lock-minimum-size', `fast-lock-save-events', 295 For saving, see variables `fast-lock-minimum-size', `fast-lock-save-events',
308 `fast-lock-save-others' and `fast-lock-save-faces'." 296 `fast-lock-save-others' and `fast-lock-save-faces'.
297
298 Use \\[fast-lock-submit-bug-report] to send bug reports or feedback."
309 (interactive "P") 299 (interactive "P")
310 ;; Only turn on if we are visiting a file. We could use `buffer-file-name', 300 ;; Only turn on if we are visiting a file. We could use `buffer-file-name',
311 ;; but many packages temporarily wrap that to nil when doing their own thing. 301 ;; but many packages temporarily wrap that to nil when doing their own thing.
312 (set (make-local-variable 'fast-lock-mode) 302 (set (make-local-variable 'fast-lock-mode)
313 (and buffer-file-truename 303 (and buffer-file-truename
325 315
326 (defun fast-lock-read-cache () 316 (defun fast-lock-read-cache ()
327 "Read the Font Lock cache for the current buffer. 317 "Read the Font Lock cache for the current buffer.
328 318
329 The following criteria must be met for a Font Lock cache file to be read: 319 The following criteria must be met for a Font Lock cache file to be read:
330 - Fast Lock mode must be turned on in the buffer. 320 - Fast Lock mode must be turned on in the buffer.
331 - The buffer must not be modified. 321 - The buffer must not be modified.
332 - The buffer's `font-lock-keywords' must match the cache's. 322 - The buffer's `font-lock-keywords' must match the cache's.
333 - The buffer file's timestamp must match the cache's. 323 - The buffer file's timestamp must match the cache's.
334 - Criteria imposed by `fast-lock-cache-directories'. 324 - Criteria imposed by `fast-lock-cache-directories'.
335 325
336 See `fast-lock-mode'." 326 See `fast-lock-mode'."
337 (interactive) 327 (interactive)
338 (let ((directories fast-lock-cache-directories) 328 (let ((directories fast-lock-cache-directories)
339 (modified (buffer-modified-p)) (inhibit-read-only t) 329 (modified (buffer-modified-p)) (inhibit-read-only t)
358 348
359 (defun fast-lock-save-cache (&optional buffer) 349 (defun fast-lock-save-cache (&optional buffer)
360 "Save the Font Lock cache of BUFFER or the current buffer. 350 "Save the Font Lock cache of BUFFER or the current buffer.
361 351
362 The following criteria must be met for a Font Lock cache file to be saved: 352 The following criteria must be met for a Font Lock cache file to be saved:
363 - Fast Lock mode must be turned on in the buffer. 353 - Fast Lock mode must be turned on in the buffer.
364 - The event must be one of `fast-lock-save-events'. 354 - The event must be one of `fast-lock-save-events'.
365 - The buffer must be at least `fast-lock-minimum-size' bytes long. 355 - The buffer must be at least `fast-lock-minimum-size' bytes long.
366 - The buffer file must be owned by you, or `fast-lock-save-others' must be t. 356 - The buffer file must be owned by you, or `fast-lock-save-others' must be t.
367 - The buffer must contain at least one `face' text property. 357 - The buffer must contain at least one `face' text property.
368 - The buffer must not be modified. 358 - The buffer must not be modified.
369 - The buffer file's timestamp must be the same as the file's on disk. 359 - The buffer file's timestamp must be the same as the file's on disk.
370 - The on disk file's timestamp must be different than the buffer's cache. 360 - The on disk file's timestamp must be different than the buffer's cache.
371 - Criteria imposed by `fast-lock-cache-directories'. 361 - Criteria imposed by `fast-lock-cache-directories'.
372 362
373 See `fast-lock-mode'." 363 See `fast-lock-mode'."
374 (interactive) 364 (interactive)
375 (save-excursion 365 (save-excursion
376 (when buffer 366 (when buffer
512 (defun fast-lock-save-cache-1 (file timestamp) 502 (defun fast-lock-save-cache-1 (file timestamp)
513 ;; Save the FILE with the TIMESTAMP as: 503 ;; Save the FILE with the TIMESTAMP as:
514 ;; (fast-lock-cache-data Version=2 TIMESTAMP font-lock-keywords PROPERTIES). 504 ;; (fast-lock-cache-data Version=2 TIMESTAMP font-lock-keywords PROPERTIES).
515 ;; Returns non-nil if a save was attempted to a writable cache file. 505 ;; Returns non-nil if a save was attempted to a writable cache file.
516 (let ((tpbuf (generate-new-buffer " *fast-lock*")) 506 (let ((tpbuf (generate-new-buffer " *fast-lock*"))
517 (verbose (if (numberp fast-lock-verbose) 507 (buname (buffer-name)) (saved t))
518 (> (buffer-size) fast-lock-verbose) 508 (message "Saving %s font lock cache..." buname)
519 fast-lock-verbose))
520 (saved t))
521 (if verbose (message "Saving %s font lock cache..." (buffer-name)))
522 (condition-case nil 509 (condition-case nil
523 (save-excursion 510 (save-excursion
524 (print (list 'fast-lock-cache-data 2 511 (print (list 'fast-lock-cache-data 2
525 (list 'quote timestamp) 512 (list 'quote timestamp)
526 (list 'quote font-lock-keywords) 513 (list 'quote font-lock-keywords)
530 (write-region (point-min) (point-max) file nil 'quietly) 517 (write-region (point-min) (point-max) file nil 'quietly)
531 (setq fast-lock-cache-timestamp timestamp 518 (setq fast-lock-cache-timestamp timestamp
532 fast-lock-cache-filename file)) 519 fast-lock-cache-filename file))
533 (error (setq saved 'error)) (quit (setq saved 'quit))) 520 (error (setq saved 'error)) (quit (setq saved 'quit)))
534 (kill-buffer tpbuf) 521 (kill-buffer tpbuf)
535 (if verbose (message "Saving %s font lock cache...%s" (buffer-name) 522 (message "Saving %s font lock cache...%s" buname
536 (cond ((eq saved 'error) "failed") 523 (cond ((eq saved 'error) "failed")
537 ((eq saved 'quit) "aborted") 524 ((eq saved 'quit) "aborted")
538 (t "done")))) 525 (t "done")))
539 ;; We return non-nil regardless of whether a failure occurred. 526 ;; We return non-nil regardless of whether a failure occurred.
540 saved)) 527 saved))
541 528
542 (defun fast-lock-cache-data (version timestamp keywords properties 529 (defun fast-lock-cache-data (version timestamp keywords properties
543 &rest ignored) 530 &rest ignored)
550 font-lock-keywords (font-lock-compile-keywords current))) 537 font-lock-keywords (font-lock-compile-keywords current)))
551 ;; Use the Font Lock cache PROPERTIES if we're using cache VERSION format 2, 538 ;; Use the Font Lock cache PROPERTIES if we're using cache VERSION format 2,
552 ;; the current buffer's file timestamp matches the TIMESTAMP, and the current 539 ;; the current buffer's file timestamp matches the TIMESTAMP, and the current
553 ;; buffer's font-lock-keywords are the same as KEYWORDS. 540 ;; buffer's font-lock-keywords are the same as KEYWORDS.
554 (let ((buf-timestamp (visited-file-modtime)) 541 (let ((buf-timestamp (visited-file-modtime))
555 (verbose (if (numberp fast-lock-verbose) 542 (buname (buffer-name)) (loaded t))
556 (> (buffer-size) fast-lock-verbose)
557 fast-lock-verbose))
558 (loaded t))
559 (if (or (/= version 2) 543 (if (or (/= version 2)
560 (buffer-modified-p) 544 (buffer-modified-p)
561 (not (equal timestamp buf-timestamp)) 545 (not (equal timestamp buf-timestamp))
562 (not (equal keywords font-lock-keywords))) 546 (not (equal keywords font-lock-keywords)))
563 (setq loaded nil) 547 (setq loaded nil)
564 (if verbose (message "Loading %s font lock cache..." (buffer-name))) 548 (message "Loading %s font lock cache..." buname)
565 (condition-case nil 549 (condition-case nil
566 (fast-lock-set-face-properties properties) 550 (fast-lock-set-face-properties properties)
567 (error (setq loaded 'error)) (quit (setq loaded 'quit))) 551 (error (setq loaded 'error)) (quit (setq loaded 'quit)))
568 (if verbose (message "Loading %s font lock cache...%s" (buffer-name) 552 (message "Loading %s font lock cache...%s" buname
569 (cond ((eq loaded 'error) "failed") 553 (cond ((eq loaded 'error) "failed")
570 ((eq loaded 'quit) "aborted") 554 ((eq loaded 'quit) "aborted")
571 (t "done"))))) 555 (t "done"))))
572 (setq font-lock-fontified (eq loaded t) 556 (setq font-lock-fontified (eq loaded t)
573 fast-lock-cache-timestamp (and (eq loaded t) timestamp)))) 557 fast-lock-cache-timestamp (and (eq loaded t) timestamp))))
574 558
575 ;; Text Properties Processing Functions: 559 ;; Text Properties Processing Functions:
576 560
577 ;; This is fast, but fails if adjacent characters have different `face' text 561 ;; This is faster, but fails if adjacent characters have different `face' text
578 ;; properties. Maybe that's why I dropped it in the first place? 562 ;; properties. Maybe that's why I dropped it in the first place?
579 ;(defun fast-lock-get-face-properties () 563 ;(defun fast-lock-get-face-properties ()
580 ; "Return a list of all `face' text properties in the current buffer. 564 ; "Return a list of all `face' text properties in the current buffer.
581 ;Each element of the list is of the form (VALUE START1 END1 START2 END2 ...) 565 ;Each element of the list is of the form (VALUE START1 END1 START2 END2 ...)
582 ;where VALUE is a `face' property value and STARTx and ENDx are positions." 566 ;where VALUE is a `face' property value and STARTx and ENDx are positions."
592 ; (setcdr cell (cons start (cons end (cdr cell)))) 576 ; (setcdr cell (cons start (cons end (cdr cell))))
593 ; (setq properties (cons (list value start end) properties))) 577 ; (setq properties (cons (list value start end) properties)))
594 ; (setq start (next-single-property-change end 'face))) 578 ; (setq start (next-single-property-change end 'face)))
595 ; properties))) 579 ; properties)))
596 580
597 ;; This is slow, but copes if adjacent characters have different `face' text
598 ;; properties, but fails if they are lists.
599 ;(defun fast-lock-get-face-properties ()
600 ; "Return a list of all `face' text properties in the current buffer.
601 ;Each element of the list is of the form (VALUE START1 END1 START2 END2 ...)
602 ;where VALUE is a `face' property value and STARTx and ENDx are positions.
603 ;Only those `face' VALUEs in `fast-lock-save-faces' are returned."
604 ; (save-restriction
605 ; (widen)
606 ; (let ((faces (or fast-lock-save-faces (face-list))) (limit (point-max))
607 ; properties regions face start end)
608 ; (while faces
609 ; (setq face (car faces) faces (cdr faces) regions () end (point-min))
610 ; ;; Make a list of start/end regions with `face' property face.
611 ; (while (setq start (text-property-any end limit 'face face))
612 ; (setq end (or (text-property-not-all start limit 'face face) limit)
613 ; regions (cons start (cons end regions))))
614 ; ;; Add `face' face's regions, if any, to properties.
615 ; (when regions
616 ; (push (cons face regions) properties)))
617 ; properties)))
618
619 (defun fast-lock-get-face-properties () 581 (defun fast-lock-get-face-properties ()
620 "Return a list of all `face' text properties in the current buffer. 582 "Return a list of all `face' text properties in the current buffer.
621 Each element of the list is of the form (VALUE START1 END1 START2 END2 ...) 583 Each element of the list is of the form (VALUE START1 END1 START2 END2 ...)
622 where VALUE is a `face' property value and STARTx and ENDx are positions." 584 where VALUE is a `face' property value and STARTx and ENDx are positions.
585 Only those `face' VALUEs in `fast-lock-save-faces' are returned."
623 (save-restriction 586 (save-restriction
624 (widen) 587 (widen)
625 (let ((start (text-property-not-all (point-min) (point-max) 'face nil)) 588 (let ((faces (or fast-lock-save-faces (face-list))) (limit (point-max))
626 end properties value cell) 589 properties regions face start end)
627 (while start 590 (while faces
628 (setq end (next-single-property-change start 'face nil (point-max)) 591 (setq face (car faces) faces (cdr faces) regions () end (point-min))
629 value (get-text-property start 'face)) 592 ;; Make a list of start/end regions with `face' property face.
630 ;; Make, or add to existing, list of regions with same `face'. 593 (while (setq start (text-property-any end limit 'face face))
631 (cond ((setq cell (assoc value properties)) 594 (setq end (or (text-property-not-all start limit 'face face) limit)
632 (setcdr cell (cons start (cons end (cdr cell))))) 595 regions (cons start (cons end regions))))
633 ((fast-lock-save-facep value) 596 ;; Add `face' face's regions, if any, to properties.
634 (push (list value start end) properties))) 597 (when regions
635 (setq start (text-property-not-all end (point-max) 'face nil))) 598 (push (cons face regions) properties)))
636 properties))) 599 properties)))
637 600
638 (defun fast-lock-set-face-properties (properties) 601 (defun fast-lock-set-face-properties (properties)
639 "Set all `face' text properties to PROPERTIES in the current buffer. 602 "Set all `face' text properties to PROPERTIES in the current buffer.
640 Any existing `face' text properties are removed first. 603 Any existing `face' text properties are removed first.
668 (let ((properties ()) cell) 631 (let ((properties ()) cell)
669 (map-extents 632 (map-extents
670 (function (lambda (extent ignore) 633 (function (lambda (extent ignore)
671 (let ((value (extent-face extent))) 634 (let ((value (extent-face extent)))
672 ;; We're only interested if it's one of `fast-lock-save-faces'. 635 ;; We're only interested if it's one of `fast-lock-save-faces'.
673 (when (and value (fast-lock-save-facep value)) 636 (when (and value (or (null fast-lock-save-faces)
637 (memq value fast-lock-save-faces)))
674 (let ((start (extent-start-position extent)) 638 (let ((start (extent-start-position extent))
675 (end (extent-end-position extent))) 639 (end (extent-end-position extent)))
676 ;; Make or add to existing list of regions with the same 640 ;; Make or add to existing list of regions with the same
677 ;; `face' property value. 641 ;; `face' property value.
678 (if (setq cell (assoc value properties)) 642 (if (setq cell (assq value properties))
679 (setcdr cell (cons start (cons end (cdr cell)))) 643 (setcdr cell (cons start (cons end (cdr cell))))
680 (push (list value start end) properties)))) 644 (push (list value start end) properties))))
681 ;; Return nil to keep `map-extents' going. 645 ;; Return nil to keep `map-extents' going.
682 nil)))) 646 nil))))
683 properties))) 647 properties)))
722 (add-hook 'after-save-hook 'fast-lock-save-cache-after-save-file) 686 (add-hook 'after-save-hook 'fast-lock-save-cache-after-save-file)
723 (add-hook 'kill-buffer-hook 'fast-lock-save-cache-before-kill-buffer) 687 (add-hook 'kill-buffer-hook 'fast-lock-save-cache-before-kill-buffer)
724 (add-hook 'kill-emacs-hook 'fast-lock-save-caches-before-kill-emacs) 688 (add-hook 'kill-emacs-hook 'fast-lock-save-caches-before-kill-emacs)
725 689
726 ;;;###autoload 690 ;;;###autoload
727 (when (fboundp 'add-minor-mode) 691 (if (fboundp 'add-minor-mode) (add-minor-mode 'fast-lock-mode nil))
728 (defvar fast-lock-mode nil)
729 (add-minor-mode 'fast-lock-mode nil))
730 ;;;###dont-autoload 692 ;;;###dont-autoload
731 (unless (assq 'fast-lock-mode minor-mode-alist) 693 (unless (assq 'fast-lock-mode minor-mode-alist)
732 (setq minor-mode-alist (append minor-mode-alist '((fast-lock-mode nil))))) 694 (setq minor-mode-alist (append minor-mode-alist '((fast-lock-mode nil)))))
733 695
734 ;; Provide ourselves: 696 ;; Provide ourselves: