comparison lisp/jit-lock.el @ 41336:36e754afaf7a

(jit-lock-defer-time): New var. (jit-lock-defer-timer, jit-lock-buffers): New vars. (jit-lock-mode): Initialize them. Cancel the timers more carefully. (jit-lock-function): Defer fontification if requested. (jit-lock-stealth-chunk-start): Pay attention to the new non-nil value. (jit-lock-stealth-fontify): Check the new `jit-lock-defer-multiline' text property. (jit-lock-deferred-fontify): New fun.

41335:b300e8b6992e

  :type '(choice (const :tag "never" nil)
		 (const :tag "always" t)
		 (other :tag "syntax-driven" syntax-driven))
  :group 'jit-lock)



;;; Variables that are not customizable.

(defvar jit-lock-mode nil
  "Non-nil means Just-in-time Lock mode is active.")

(make-variable-buffer-local 'jit-lock-first-unfontify-pos)


(defvar jit-lock-stealth-timer nil
  "Timer for stealth fontification in Just-in-time Lock mode.")

;;; JIT lock mode

(defun jit-lock-mode (arg)
  "Toggle Just-in-time Lock mode.

the variable `jit-lock-stealth-nice'."
  (setq jit-lock-mode arg)
  (cond (;; Turn Just-in-time Lock mode on.
	 jit-lock-mode

 	 ;; Mark the buffer for refontification
	 (jit-lock-refontify)

	 ;; Install an idle timer for stealth fontification.
	 (when (and jit-lock-stealth-time (null jit-lock-stealth-timer))
	   (setq jit-lock-stealth-timer
		 (run-with-idle-timer jit-lock-stealth-time
				      jit-lock-stealth-time
				      'jit-lock-stealth-fontify)))

	 ;; Initialize deferred contextual fontification if requested.
	 (when (eq jit-lock-defer-contextually t)
	   (setq jit-lock-first-unfontify-pos
		 (or jit-lock-first-unfontify-pos (point-max))))

	 (add-hook 'after-change-functions 'jit-lock-after-change nil t)
	 (add-hook 'fontification-functions 'jit-lock-function))

	;; Turn Just-in-time Lock mode off.
	(t
	 ;; Cancel our idle timer.
	 (when jit-lock-stealth-timer
	   (cancel-timer jit-lock-stealth-timer)
	   (setq jit-lock-stealth-timer nil))

	 ;; Remove hooks.
	 (remove-hook 'after-change-functions 'jit-lock-after-change t)
	 (remove-hook 'fontification-functions 'jit-lock-function))))

(defun jit-lock-refontify (&optional beg end)
  "Force refontification of the region BEG..END (default whole buffer)."
  (with-buffer-prepared-for-jit-lock
   (save-restriction
     (widen)
     (add-text-properties (or beg (point-min)) (or end (point-max))
			  '(fontified nil)))))

;;; On demand fontification.

(defun jit-lock-function (start)
  "Fontify current buffer starting at position START.
This function is added to `fontification-functions' when `jit-lock-mode'
is active."
  (when jit-lock-mode
    (jit-lock-fontify-now start (+ start jit-lock-chunk-size))))
     

(defun jit-lock-fontify-now (&optional start end)
  "Fontify current buffer from START to END.
Defaults to the whole buffer.  END can be out of bounds."
  (with-buffer-prepared-for-jit-lock

	     (goto-char start) (setq start (line-beginning-position))
	     
	     ;; Fontify the chunk, and mark it as fontified.
	     ;; We mark it first, to make sure that we don't indefinitely
	     ;; re-execute this fontification if an error occurs.
	     (add-text-properties start next '(fontified t))
	     (run-hook-with-args 'jit-lock-functions start next)
		   
	     ;; Find the start of the next chunk, if any.
	     (setq start (text-property-any next end 'fontified nil)))))))))


;;; Stealth fontification.

Value is nil if there is nothing more to fontify."
  (if (zerop (buffer-size))
      nil
    (save-restriction
      (widen)
      (let* ((next (text-property-any around (point-max) 'fontified nil))
	     (prev (previous-single-property-change around 'fontified))
	     (prop (get-text-property (max (point-min) (1- around))
				      'fontified))
	     (start (cond
		     ((null prev)
		      ;; There is no property change between AROUND
		      ;; and the start of the buffer.  If PROP is
		      ;; non-nil, everything in front of AROUND is
		      ;; fontified, otherwise nothing is fontified.
		      (if prop
			  nil
			(max (point-min)
			     (- around (/ jit-lock-chunk-size 2)))))
		     (prop
		      ;; PREV is the start of a region of fontified
		      ;; text containing AROUND.  Start fontifying a
		      ;; chunk size before the end of the unfontified
		      ;; region in front of that.
		      (max (or (previous-single-property-change prev 'fontified)

(defun jit-lock-stealth-fontify ()
  "Fontify buffers stealthily.
This functions is called after Emacs has been idle for
`jit-lock-stealth-time' seconds."
  (unless (or executing-kbd-macro
	      (window-minibuffer-p (selected-window)))
    (let ((buffers (buffer-list))
	  minibuffer-auto-raise
	  message-log-max)

		(when jit-lock-first-unfontify-pos
		  (save-restriction
		    (widen)
		    (when (and (>= jit-lock-first-unfontify-pos (point-min))
			       (< jit-lock-first-unfontify-pos (point-max)))
		      (with-buffer-prepared-for-jit-lock
		       (put-text-property jit-lock-first-unfontify-pos
					  (point-max) 'fontified nil))
		      (setq jit-lock-first-unfontify-pos (point-max)))))

		;; In the following code, the `sit-for' calls cause a
		;; redisplay, so it's required that the
		;; buffer-modified flag of a buffer that is displayed
		;; has the right value---otherwise the mode line of
		;; an unmodified buffer would show a `*'.
		(let (start
		      (nice (or jit-lock-stealth-nice 0))
		      (point (point)))
		  (while (and (setq start
				    (jit-lock-stealth-chunk-start point))
			      (sit-for nice))
		    
		    ;; Wait a little if load is too high.
		    (when (and jit-lock-stealth-load
			       (> (car (load-average)) jit-lock-stealth-load))
		      (sit-for (or jit-lock-stealth-time 30)))
		    
		    ;; Unless there's input pending now, fontify.
		    (unless (input-pending-p)
		      (jit-lock-fontify-now
		       start (+ start jit-lock-chunk-size)))))))))))))



;;; Deferred fontification.

(defun jit-lock-after-change (start end old-len)
  "Mark the rest of the buffer as not fontified after a change.
Installed on `after-change-functions'.
START and END are the start and end of the changed text.  OLD-LEN

       (goto-char start)
       (setq start (line-beginning-position))
       
       ;; If we're in text that matches a multi-line font-lock pattern,
       ;; make sure the whole text will be redisplayed.
       (when (get-text-property start 'font-lock-multiline)
	 (setq start (or (previous-single-property-change
			  start 'font-lock-multiline)
			 (point-min))))
       

41336:36e754afaf7a

  :type '(choice (const :tag "never" nil)
		 (const :tag "always" t)
		 (other :tag "syntax-driven" syntax-driven))
  :group 'jit-lock)

(defcustom jit-lock-defer-time nil ;; 0.5
  "Idle time after which deferred fontification should take place.
If nil, fontification is not deferred."
  :group 'jit-lock
  :type '(choice (const :tag "never" nil)
	         (number :tag "seconds")))

;;; Variables that are not customizable.

(defvar jit-lock-mode nil
  "Non-nil means Just-in-time Lock mode is active.")

(make-variable-buffer-local 'jit-lock-first-unfontify-pos)


(defvar jit-lock-stealth-timer nil
  "Timer for stealth fontification in Just-in-time Lock mode.")

(defvar jit-lock-defer-timer nil
  "Timer for deferred fontification in Just-in-time Lock mode.")

(defvar jit-lock-buffers nil
  "List of buffers with pending deferred fontification.")

;;; JIT lock mode

(defun jit-lock-mode (arg)
  "Toggle Just-in-time Lock mode.

the variable `jit-lock-stealth-nice'."
  (setq jit-lock-mode arg)
  (cond (;; Turn Just-in-time Lock mode on.
	 jit-lock-mode

 	 ;; Mark the buffer for refontification.
	 (jit-lock-refontify)

	 ;; Install an idle timer for stealth fontification.
	 (when (and jit-lock-stealth-time (null jit-lock-stealth-timer))
	   (setq jit-lock-stealth-timer
		 (run-with-idle-timer jit-lock-stealth-time t
				      'jit-lock-stealth-fontify)))

	 ;; Init deferred fontification timer.
	 (when (and jit-lock-defer-time (null jit-lock-defer-timer))
	   (setq jit-lock-defer-timer
		 (run-with-idle-timer jit-lock-defer-time t
				      'jit-lock-deferred-fontify)))

	 ;; Initialize deferred contextual fontification if requested.
	 (when (eq jit-lock-defer-contextually t)
	   (setq jit-lock-first-unfontify-pos
		 (or jit-lock-first-unfontify-pos (point-max))))

	 (add-hook 'after-change-functions 'jit-lock-after-change nil t)
	 (add-hook 'fontification-functions 'jit-lock-function))

	;; Turn Just-in-time Lock mode off.
	(t
	 ;; Cancel our idle timers.
	 (when (and (or jit-lock-stealth-timer jit-lock-defer-timer)
		    ;; Only if there's no other buffer using them.
		    (not (catch 'found
			   (dolist (buf (buffer-list))
			     (with-current-buffer buf
			       (when jit-lock-mode (throw 'found t)))))))
	   (when jit-lock-stealth-timer
	     (cancel-timer jit-lock-stealth-timer)
	     (setq jit-lock-stealth-timer nil))
	   (when jit-lock-defer-timer
	     (cancel-timer jit-lock-defer-timer)
	     (setq jit-lock-defer-timer nil)))

	 ;; Remove hooks.
	 (remove-hook 'after-change-functions 'jit-lock-after-change t)
	 (remove-hook 'fontification-functions 'jit-lock-function))))

(defun jit-lock-refontify (&optional beg end)
  "Force refontification of the region BEG..END (default whole buffer)."
  (with-buffer-prepared-for-jit-lock
   (save-restriction
     (widen)
     (put-text-property (or beg (point-min)) (or end (point-max))
			'fontified nil))))

;;; On demand fontification.

(defun jit-lock-function (start)
  "Fontify current buffer starting at position START.
This function is added to `fontification-functions' when `jit-lock-mode'
is active."
  (when jit-lock-mode
    (if (null jit-lock-defer-time)
	;; No deferral.
	(jit-lock-fontify-now start (+ start jit-lock-chunk-size))
      ;; Record the buffer for later fontification.
      (unless (memq (current-buffer) jit-lock-buffers)
	(push (current-buffer) jit-lock-buffers))
      ;; Mark the area as defer-fontified so that the redisplay engine
      ;; is happy and so that the idle timer can find the places to fontify.
      (with-buffer-prepared-for-jit-lock
       (put-text-property start
			  (next-single-property-change
			   start 'fontified nil
			   (min (point-max) (+ start jit-lock-chunk-size)))
			  'fontified 'defer)))))

(defun jit-lock-fontify-now (&optional start end)
  "Fontify current buffer from START to END.
Defaults to the whole buffer.  END can be out of bounds."
  (with-buffer-prepared-for-jit-lock

	     (goto-char start) (setq start (line-beginning-position))
	     
	     ;; Fontify the chunk, and mark it as fontified.
	     ;; We mark it first, to make sure that we don't indefinitely
	     ;; re-execute this fontification if an error occurs.
	     (put-text-property start next 'fontified t)
	     (run-hook-with-args 'jit-lock-functions start next)

	     ;; Find the start of the next chunk, if any.
	     (setq start (text-property-any next end 'fontified nil)))))))))


;;; Stealth fontification.

Value is nil if there is nothing more to fontify."
  (if (zerop (buffer-size))
      nil
    (save-restriction
      (widen)
      (let* ((next (text-property-not-all around (point-max) 'fontified t))
	     (prev (previous-single-property-change around 'fontified))
	     (prop (get-text-property (max (point-min) (1- around))
				      'fontified))
	     (start (cond
		     ((null prev)
		      ;; There is no property change between AROUND
		      ;; and the start of the buffer.  If PROP is
		      ;; non-nil, everything in front of AROUND is
		      ;; fontified, otherwise nothing is fontified.
		      (if (eq prop t)
			  nil
			(max (point-min)
			     (- around (/ jit-lock-chunk-size 2)))))
		     ((eq prop t)
		      ;; PREV is the start of a region of fontified
		      ;; text containing AROUND.  Start fontifying a
		      ;; chunk size before the end of the unfontified
		      ;; region in front of that.
		      (max (or (previous-single-property-change prev 'fontified)

(defun jit-lock-stealth-fontify ()
  "Fontify buffers stealthily.
This functions is called after Emacs has been idle for
`jit-lock-stealth-time' seconds."
  ;; I used to check `inhibit-read-only' here, but I can't remember why.  -stef
  (unless (or executing-kbd-macro
	      (window-minibuffer-p (selected-window)))
    (let ((buffers (buffer-list))
	  minibuffer-auto-raise
	  message-log-max)

		(when jit-lock-first-unfontify-pos
		  (save-restriction
		    (widen)
		    (when (and (>= jit-lock-first-unfontify-pos (point-min))
			       (< jit-lock-first-unfontify-pos (point-max)))
		      ;; If we're in text that matches a complex multi-line
		      ;; font-lock pattern, make sure the whole text will be
		      ;; redisplayed eventually.
		      (when (get-text-property jit-lock-first-unfontify-pos
					       'jit-lock-defer-multiline)
			(setq jit-lock-first-unfontify-pos
			      (or (previous-single-property-change
				   jit-lock-first-unfontify-pos
				   'jit-lock-defer-multiline)
				  (point-min))))
		      (with-buffer-prepared-for-jit-lock
			(remove-text-properties
			 jit-lock-first-unfontify-pos (point-max)
			 '(fontified nil jit-lock-defer-multiline nil)))
		      (setq jit-lock-first-unfontify-pos (point-max)))))

		;; In the following code, the `sit-for' calls cause a
		;; redisplay, so it's required that the
		;; buffer-modified flag of a buffer that is displayed
		;; has the right value---otherwise the mode line of
		;; an unmodified buffer would show a `*'.
		(let (start
		      (nice (or jit-lock-stealth-nice 0))
		      (point (point-min)))
		  (while (and (setq start
				    (jit-lock-stealth-chunk-start point))
			      (sit-for nice))
		    
		    ;; fontify a block.
		    (jit-lock-fontify-now start (+ start jit-lock-chunk-size))
		    ;; If stealth jit-locking is done backwards, this leads to
		    ;; excessive O(n^2) refontification.   -stef
		    ;; (when (>= jit-lock-first-unfontify-pos start)
		    ;;   (setq jit-lock-first-unfontify-pos end))
		    
		    ;; Wait a little if load is too high.
		    (when (and jit-lock-stealth-load
			       (> (car (load-average)) jit-lock-stealth-load))
		      (sit-for (or jit-lock-stealth-time 30)))))))))))))



;;; Deferred fontification.

(defun jit-lock-deferred-fontify ()
  "Fontify what was deferred."
  (when jit-lock-buffers
    ;; Mark the deferred regions back to `fontified = nil'
    (dolist (buffer jit-lock-buffers)
      (when (buffer-live-p buffer)
	(with-current-buffer buffer
	  ;; (message "Jit-Defer %s" (buffer-name))
	  (with-buffer-prepared-for-jit-lock
	   (let ((pos (point-min)))
	     (while
		 (progn
		   (when (eq (get-text-property pos 'fontified) 'defer)
		     (put-text-property
		      pos (setq pos (next-single-property-change
				     pos 'fontified nil (point-max)))
		      'fontified nil))
		   (setq pos (next-single-property-change pos 'fontified)))))))))
    (setq jit-lock-buffers nil)
    ;; Force fontification of the visible parts.
    (let ((jit-lock-defer-time nil))
      ;; (message "Jit-Defer Now")
      (sit-for 0)
      ;; (message "Jit-Defer Done")
      )))
      

(defun jit-lock-after-change (start end old-len)
  "Mark the rest of the buffer as not fontified after a change.
Installed on `after-change-functions'.
START and END are the start and end of the changed text.  OLD-LEN

       (goto-char start)
       (setq start (line-beginning-position))
       
       ;; If we're in text that matches a multi-line font-lock pattern,
       ;; make sure the whole text will be redisplayed.
       ;; I'm not sure this is ever necessary and/or sufficient.  -stef
       (when (get-text-property start 'font-lock-multiline)
	 (setq start (or (previous-single-property-change
			  start 'font-lock-multiline)
			 (point-min))))