--- a/lisp/packages/fast-lock.el	Mon Aug 13 08:50:06 2007 +0200
+++ b/lisp/packages/fast-lock.el	Mon Aug 13 08:50:29 2007 +0200
@@ -4,27 +4,25 @@
 
 ;; Author: Simon Marshall <simon@gnu.ai.mit.edu>
 ;; Keywords: faces files
-;; Version: 3.10.01
+;; Version: 3.10.02
+
+;;; This file is part of GNU Emacs.
 
-;; This file is part of XEmacs.
-;; 
-;; XEmacs is free software; you can redistribute it and/or modify
+;; 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 2 of the License, or
-;; (at your option) any later version.
-;; 
-;; XEmacs is distributed in the hope that it will be useful,
+;; the Free Software Foundation; either version 2, 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 XEmacs; see the file COPYING.  If not, write to the
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 ;; Boston, MA 02111-1307, USA.
 
-;;; Synched up with: FSF 19.34.
-
 ;;; Commentary:
 
 ;; Purpose:
@@ -55,14 +53,7 @@
 ;;
 ;; Version control packages are likely to stamp all over file modification
 ;; times.  Therefore the act of checking out may invalidate a cache.
-
-;; Feedback:
-;;
-;; Feedback is welcome.
-;; To submit a bug report (or make comments) please use the mechanism provided:
-;;
-;; M-x fast-lock-submit-bug-report RET
-
+;;;;;^L
 ;; History:
 ;;
 ;; 0.02--1.00:
@@ -166,7 +157,10 @@
 ;; - Wrap with `save-buffer-state' (Ray Van Tassle report)
 ;; - Made `fast-lock-mode' wrap `font-lock-support-mode'
 ;; 3.10--3.11:
-
+;; - Made `fast-lock-get-face-properties' cope with face lists
+;; - Added `fast-lock-verbose'
+;; - XEmacs: Add `font-lock-value-in-major-mode' if necessary
+;;;;;^L
 (require 'font-lock)
 
 ;; Make sure fast-lock.el is supported.
@@ -194,15 +188,29 @@
 	 (,@ body)
 	 (when (and (not modified) (buffer-modified-p))
 	   (set-buffer-modified-p nil)))))
-  (put 'save-buffer-state 'lisp-indent-function 1))
+  (put 'save-buffer-state 'lisp-indent-function 1)
+  ;;
+  ;; We use this to verify that a face should be saved.
+  (defmacro fast-lock-save-facep (face)
+    "Return non-nil if FACE matches `fast-lock-save-faces'."
+    (` (or (null fast-lock-save-faces)
+	   (if (symbolp (, face))
+	       (memq (, face) fast-lock-save-faces)
+	     (let ((list (, face)) found)
+	       (while list
+		 (if (memq (car list) fast-lock-save-faces)
+		     (setq list nil found t)
+		   (setq list (cdr list))))
+	       found))))))
 
 (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.10.01"
+    (reporter-submit-bug-report "simon@gnu.ai.mit.edu" "fast-lock 3.10.02"
      '(fast-lock-cache-directories fast-lock-minimum-size
-       fast-lock-save-others fast-lock-save-events fast-lock-save-faces)
+       fast-lock-save-others fast-lock-save-events fast-lock-save-faces
+       fast-lock-verbose)
      nil nil
      (concat "Hi Si.,
 
@@ -216,7 +224,7 @@
 (defvar fast-lock-mode nil)
 (defvar fast-lock-cache-timestamp nil)	; for saving/reading
 (defvar fast-lock-cache-filename nil)	; for deleting
-
+;;;;;^L
 ;; User Variables:
 
 (defvar fast-lock-cache-directories '("." "~/.emacs-flc")
@@ -266,7 +274,11 @@
     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.")
-
+
+(defvar 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.")
+;;;;;^L
 ;; User Functions:
 
 ;;;###autoload
@@ -293,9 +305,7 @@
 Various methods of control are provided for the Font Lock cache.  In general,
 see variable `fast-lock-cache-directories' and function `fast-lock-cache-name'.
 For saving, see variables `fast-lock-minimum-size', `fast-lock-save-events',
-`fast-lock-save-others' and `fast-lock-save-faces'.
-
-Use \\[fast-lock-submit-bug-report] to send bug reports or feedback."
+`fast-lock-save-others' and `fast-lock-save-faces'."
   (interactive "P")
   ;; Only turn on if we are visiting a file.  We could use `buffer-file-name',
   ;; but many packages temporarily wrap that to nil when doing their own thing.
@@ -403,7 +413,7 @@
 (defun turn-on-fast-lock ()
   "Unconditionally turn on Fast Lock mode."
   (fast-lock-mode t))
-
+;;;;;^L
 ;;; API Functions:
 
 (defun fast-lock-after-fontify-buffer ()
@@ -417,7 +427,7 @@
 
 (defalias 'fast-lock-after-unfontify-buffer
   'ignore)
-
+;;;;;^L
 ;; Miscellaneous Functions:
 
 (defun fast-lock-save-cache-after-save-file ()
@@ -496,7 +506,7 @@
        (file-name-as-directory (expand-file-name directory))
        (mapconcat 'char-to-string (apply 'append (mapcar mapchars bufile)) "")
        ".flc"))))
-
+;;;;;^L
 ;; Font Lock Cache Processing Functions:
 
 (defun fast-lock-save-cache-1 (file timestamp)
@@ -504,8 +514,11 @@
   ;; (fast-lock-cache-data Version=2 TIMESTAMP font-lock-keywords PROPERTIES).
   ;; Returns non-nil if a save was attempted to a writable cache file.
   (let ((tpbuf (generate-new-buffer " *fast-lock*"))
-	(buname (buffer-name)) (saved t))
-    (message "Saving %s font lock cache..." buname)
+	(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
@@ -519,10 +532,10 @@
 		fast-lock-cache-filename file))
       (error (setq saved 'error)) (quit (setq saved 'quit)))
     (kill-buffer tpbuf)
-    (message "Saving %s font lock cache...%s" buname
-	     (cond ((eq saved 'error) "failed")
-		   ((eq saved 'quit) "aborted")
-		   (t "done")))
+    (if verbose (message "Saving %s font lock cache...%s" (buffer-name)
+			 (cond ((eq saved 'error) "failed")
+			       ((eq saved 'quit) "aborted")
+			       (t "done"))))
     ;; We return non-nil regardless of whether a failure occurred.
     saved))
 
@@ -539,23 +552,26 @@
   ;; the current buffer's file timestamp matches the TIMESTAMP, and the current
   ;; buffer's font-lock-keywords are the same as KEYWORDS.
   (let ((buf-timestamp (visited-file-modtime))
-	(buname (buffer-name)) (loaded t))
+	(verbose (if (numberp fast-lock-verbose)
+		     (> (buffer-size) fast-lock-verbose)
+		   fast-lock-verbose))
+	(loaded t))
     (if (or (/= version 2)
 	    (buffer-modified-p)
 	    (not (equal timestamp buf-timestamp))
 	    (not (equal keywords font-lock-keywords)))
 	(setq loaded nil)
-      (message "Loading %s font lock cache..." buname)
+      (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)))
-      (message "Loading %s font lock cache...%s" buname
-	       (cond ((eq loaded 'error) "failed")
-		     ((eq loaded 'quit) "aborted")
-		     (t "done"))))
+      (if verbose (message "Loading %s font lock cache...%s" (buffer-name)
+			   (cond ((eq loaded 'error) "failed")
+				 ((eq loaded 'quit) "aborted")
+				 (t "done")))))
     (setq font-lock-fontified (eq loaded t)
 	  fast-lock-cache-timestamp (and (eq loaded t) timestamp))))
-
+;;;;;^L
 ;; Text Properties Processing Functions:
 
 ;; This is faster, but fails if adjacent characters have different `face' text
@@ -578,24 +594,47 @@
 ;	(setq start (next-single-property-change end 'face)))
 ;      properties)))
 
+;; This 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.
+;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."
+;  (save-restriction
+;    (widen)
+;    (let ((faces (or fast-lock-save-faces (face-list))) (limit (point-max))
+;	  properties regions face start end)
+;      (while faces
+;	(setq face (car faces) faces (cdr faces) regions () end (point-min))
+;	;; Make a list of start/end regions with `face' property face.
+;	(while (setq start (text-property-any end limit 'face face))
+;	  (setq end (or (text-property-not-all start limit 'face face) limit)
+;		regions (cons start (cons end regions))))
+;	;; Add `face' face's regions, if any, to properties.
+;	(when regions
+;	  (push (cons face regions) properties)))
+;      properties)))
+
 (defun fast-lock-get-face-properties ()
   "Return a list of all `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."
+where VALUE is a `face' property value and STARTx and ENDx are positions."
   (save-restriction
     (widen)
-    (let ((faces (or fast-lock-save-faces (face-list))) (limit (point-max))
-	  properties regions face start end)
-      (while faces
-	(setq face (car faces) faces (cdr faces) regions () end (point-min))
-	;; Make a list of start/end regions with `face' property face.
-	(while (setq start (text-property-any end limit 'face face))
-	  (setq end (or (text-property-not-all start limit 'face face) limit)
-		regions (cons start (cons end regions))))
-	;; Add `face' face's regions, if any, to properties.
-	(when regions
-	  (push (cons face regions) properties)))
+    (let ((start (text-property-not-all (point-min) (point-max) 'face nil))
+	  (limit (point-max)) end properties value cell)
+      (while start
+	(setq end (next-single-property-change start 'face nil limit)
+	      value (get-text-property start 'face))
+	;; Make, or add to existing, list of regions with same `face'.
+	(cond ((setq cell (assoc value properties))
+	       (setcdr cell (cons start (cons end (cdr cell)))))
+	      ((fast-lock-save-facep value)
+	       (push (list value start end) properties)))
+	(setq start (if (get-text-property end 'face)
+			end
+		      (next-single-property-change end 'face))))
       properties)))
 
 (defun fast-lock-set-face-properties (properties)
@@ -614,7 +653,7 @@
 	(while regions
 	  (set-text-properties (nth 0 regions) (nth 1 regions) plist)
 	  (setq regions (nthcdr 2 regions)))))))
-
+;;;;;^L
 ;; Functions for XEmacs:
 
 (when (save-match-data (string-match "XEmacs" (emacs-version)))
@@ -633,13 +672,12 @@
 	 (function (lambda (extent ignore)
 	    (let ((value (extent-face extent)))
 	      ;; We're only interested if it's one of `fast-lock-save-faces'.
-	      (when (and value (or (null fast-lock-save-faces)
-				   (memq value fast-lock-save-faces)))
+	      (when (and value (fast-lock-save-facep value))
 		(let ((start (extent-start-position extent))
 		      (end (extent-end-position extent)))
 		  ;; Make or add to existing list of regions with the same
 		  ;; `face' property value.
-		  (if (setq cell (assq value properties))
+		  (if (setq cell (assoc value properties))
 		      (setcdr cell (cons start (cons end (cdr cell))))
 		    (push (list value start end) properties))))
 	      ;; Return nil to keep `map-extents' going.
@@ -680,7 +718,7 @@
 
 (unless (fboundp 'font-lock-compile-keywords)
   (defalias 'font-lock-compile-keywords 'identity))
-
+;;;;;^L
 ;; Install ourselves:
 
 (add-hook 'after-save-hook 'fast-lock-save-cache-after-save-file)