xemacs-beta: lisp/packages/fast-lock.el comparison

comparison lisp/packages/fast-lock.el @ 22:8fc7fe29b841 r19-15b94

Import from CVS: tag r19-15b94

author	cvs
date	Mon, 13 Aug 2007 08:50:29 +0200
parents	ac2d302a0011
children	4103f0995bd7

comparison

equal deleted inserted replaced

-:b88636d63495
+:8fc7fe29b841
 ;; Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc.
 ;; Author: Simon Marshall <simon@gnu.ai.mit.edu>
 ;; Keywords: faces files
-;; Version: 3.10.01
+;; Version: 3.10.02
-;; This file is part of XEmacs.
+;;; This file is part of GNU Emacs.
-;;
-;; 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
+;; the Free Software Foundation; either version 2, or (at your option)
-;; (at your option) any later version.
+;; any later version.
-;;
-;; XEmacs is distributed in the hope that it will be useful,
+;; 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:
 ;;
 ;; A cache will be saved when visiting a compressed file using crypt++, but not
 ;; be read.  This is a "feature"/"consequence"/"bug" of crypt++.
 ;;
 ;; Version control packages are likely to stamp all over file modification
 ;; times.  Therefore the act of checking out may invalidate a cache.
+;;;;;^L
-;; 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
 ;; History:
 ;;
 ;; 0.02--1.00:
 ;; - Changed name from turbo-prop to fast-lock.  Automagic for font-lock only
 ;; - Made `fast-lock-mode' a minor mode, like G. Dinesh Dutt's fss-mode
 ;; - XEmacs: Made `fast-lock-save-faces' default to `font-lock-face-list'
 ;; - Made `fast-lock-save-cache' use `font-lock-value-in-major-mode'
 ;; - 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.
 (if (and (eq system-type 'ms-dos) (not (msdos-long-file-names)))
 (error "`fast-lock' was written for long file name systems"))
 		     before-change-functions after-change-functions
 		     deactivate-mark buffer-file-name buffer-file-truename))))
 	 (,@ 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.,
 I want to report a bug.  I've read the `Bugs' section of `Info' on Emacs, so I
 know how to make a clear and unambiguous report.  To reproduce the bug:
 ;;;###autoload
 (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")
 ; - `internal', keep each file's Font Lock cache file in the same file.
 ; - `external', keep each file's Font Lock cache file in the same directory.
 (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.")
+(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
 (defun fast-lock-mode (&optional arg)
 "Toggle Fast Lock mode.
 Use \\[font-lock-fontify-buffer] to fontify the buffer if the cache is bad.
 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'.
+`fast-lock-save-others' and `fast-lock-save-faces'."
-Use \\[fast-lock-submit-bug-report] to send bug reports or feedback."
 (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.
 (set (make-local-variable 'fast-lock-mode)
 (and buffer-file-truename
 ;;;###autoload
 (defun turn-on-fast-lock ()
 "Unconditionally turn on Fast Lock mode."
 (fast-lock-mode t))
+;;;;;^L
 ;;; API Functions:
 (defun fast-lock-after-fontify-buffer ()
 ;; Delete the Font Lock cache file used to restore fontification, if any.
 (when fast-lock-cache-filename
 ;; Flag so that a cache will be saved later even if the file is never saved.
 (setq fast-lock-cache-timestamp nil))
 (defalias 'fast-lock-after-unfontify-buffer
 'ignore)
+;;;;;^L
 ;; Miscellaneous Functions:
 (defun fast-lock-save-cache-after-save-file ()
 ;; Do `fast-lock-save-cache' if `save-buffer' is on `fast-lock-save-events'.
 (when (memq 'save-buffer fast-lock-save-events)
 	    (function (lambda (c) (or (cdr (assq c chars-alist)) (list c))))))
 (concat
 (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)
 ;; Save the FILE with the TIMESTAMP as:
 ;; (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))
+	(verbose (if (numberp fast-lock-verbose)
-(message "Saving %s font lock cache..." buname)
+		     (> (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)
 	  (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)
-(message "Saving %s font lock cache...%s" buname
+(if verbose (message "Saving %s font lock cache...%s" (buffer-name)
-	     (cond ((eq saved 'error) "failed")
+			 (cond ((eq saved 'error) "failed")
-		   ((eq saved 'quit) "aborted")
+			       ((eq saved 'quit) "aborted")
-		   (t "done")))
+			       (t "done"))))
 ;; We return non-nil regardless of whether a failure occurred.
 saved))
 (defun fast-lock-cache-data (version timestamp keywords properties
 			     &rest ignored)
 	  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.
 (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
+(if verbose (message "Loading %s font lock cache...%s" (buffer-name)
-	       (cond ((eq loaded 'error) "failed")
+			   (cond ((eq loaded 'error) "failed")
-		     ((eq loaded 'quit) "aborted")
+				 ((eq loaded 'quit) "aborted")
-		     (t "done"))))
+				 (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
 ;; properties.  Maybe that's why I dropped it in the first place?
 ;(defun fast-lock-get-face-properties ()
 ;	    (setcdr cell (cons start (cons end (cdr cell))))
 ;	  (setq properties (cons (list value start end) properties)))
 ;	(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.
+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))
+(let ((start (text-property-not-all (point-min) (point-max) 'face nil))
-	  properties regions face start end)
+	  (limit (point-max)) end properties value cell)
-(while faces
+(while start
-	(setq face (car faces) faces (cdr faces) regions () end (point-min))
+	(setq end (next-single-property-change start 'face nil limit)
-	;; Make a list of start/end regions with `face' property face.
+	      value (get-text-property start 'face))
-	(while (setq start (text-property-any end limit 'face face))
+	;; Make, or add to existing, list of regions with same `face'.
-	  (setq end (or (text-property-not-all start limit 'face face) limit)
+	(cond ((setq cell (assoc value properties))
-		regions (cons start (cons end regions))))
+	       (setcdr cell (cons start (cons end (cdr cell)))))
-	;; Add `face' face's regions, if any, to properties.
+	      ((fast-lock-save-facep value)
-	(when regions
+	       (push (list value start end) properties)))
-	  (push (cons face regions) properties)))
+	(setq start (if (get-text-property end 'face)
+			end
+		      (next-single-property-change end 'face))))
 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.
 	      properties (cdr properties))
 	;; Set the `face' property for each start/end region.
 	(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)))
 ;;
 ;; It would be better to use XEmacs' `map-extents' over extents with a
 (let ((properties ()) cell)
 	(map-extents
 	 (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)
+	      (when (and value (fast-lock-save-facep value))
-				   (memq value fast-lock-save-faces)))
 		(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.
 	      nil))))
 	properties)))
 	(cdr (or (assq major-mode alist) (assq t alist)))
 alist)))
 (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)
 (add-hook 'kill-buffer-hook 'fast-lock-save-cache-before-kill-buffer)
 (add-hook 'kill-emacs-hook 'fast-lock-save-caches-before-kill-emacs)

Mercurial > hg > xemacs-beta

comparison lisp/packages/fast-lock.el @ 22:8fc7fe29b841 r19-15b94