]> code.delx.au - gnu-emacs/blob - lisp/jit-lock.el
(font-lock-keyword-face, font-lock-set-defaults, font-lock-string-face):
[gnu-emacs] / lisp / jit-lock.el
1 ;;; jit-lock.el --- just-in-time fontification
2
3 ;; Copyright (C) 1998, 2000, 2001, 2002, 2003, 2004,
4 ;; 2005 Free Software Foundation, Inc.
5
6 ;; Author: Gerd Moellmann <gerd@gnu.org>
7 ;; Keywords: faces files
8
9 ;; This file is part of GNU Emacs.
10
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
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)
14 ;; any later version.
15
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
20
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
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02110-1301, USA.
25
26 ;;; Commentary:
27
28 ;; Just-in-time fontification, triggered by C redisplay code.
29
30 ;;; Code:
31
32
33 (eval-when-compile
34 (defmacro with-buffer-unmodified (&rest body)
35 "Eval BODY, preserving the current buffer's modified state."
36 (declare (debug t))
37 (let ((modified (make-symbol "modified")))
38 `(let ((,modified (buffer-modified-p)))
39 (unwind-protect
40 (progn ,@body)
41 (unless ,modified
42 (restore-buffer-modified-p nil))))))
43
44 (defmacro with-buffer-prepared-for-jit-lock (&rest body)
45 "Execute BODY in current buffer, overriding several variables.
46 Preserves the `buffer-modified-p' state of the current buffer."
47 (declare (debug t))
48 `(with-buffer-unmodified
49 (let ((buffer-undo-list t)
50 (inhibit-read-only t)
51 (inhibit-point-motion-hooks t)
52 (inhibit-modification-hooks t)
53 deactivate-mark
54 buffer-file-name
55 buffer-file-truename)
56 ,@body))))
57
58
59 \f
60 ;;; Customization.
61
62 (defgroup jit-lock nil
63 "Font Lock support mode to fontify just-in-time."
64 :version "21.1"
65 :group 'font-lock)
66
67 (defcustom jit-lock-chunk-size 500
68 "*Jit-lock chunks of this many characters, or smaller."
69 :type 'integer
70 :group 'jit-lock)
71
72
73 (defcustom jit-lock-stealth-time 16
74 "*Time in seconds to wait before beginning stealth fontification.
75 Stealth fontification occurs if there is no input within this time.
76 If nil, stealth fontification is never performed.
77
78 The value of this variable is used when JIT Lock mode is turned on."
79 :type '(choice (const :tag "never" nil)
80 (number :tag "seconds"))
81 :group 'jit-lock)
82
83
84 (defcustom jit-lock-stealth-nice 0.5
85 "*Time in seconds to pause between chunks of stealth fontification.
86 Each iteration of stealth fontification is separated by this amount of time,
87 thus reducing the demand that stealth fontification makes on the system.
88 If nil, means stealth fontification is never paused.
89 To reduce machine load during stealth fontification, at the cost of stealth
90 taking longer to fontify, you could increase the value of this variable.
91 See also `jit-lock-stealth-load'."
92 :type '(choice (const :tag "never" nil)
93 (number :tag "seconds"))
94 :group 'jit-lock)
95
96
97 (defcustom jit-lock-stealth-load
98 (if (condition-case nil (load-average) (error)) 200)
99 "*Load in percentage above which stealth fontification is suspended.
100 Stealth fontification pauses when the system short-term load average (as
101 returned by the function `load-average' if supported) goes above this level,
102 thus reducing the demand that stealth fontification makes on the system.
103 If nil, means stealth fontification is never suspended.
104 To reduce machine load during stealth fontification, at the cost of stealth
105 taking longer to fontify, you could reduce the value of this variable.
106 See also `jit-lock-stealth-nice'."
107 :type (if (condition-case nil (load-average) (error))
108 '(choice (const :tag "never" nil)
109 (integer :tag "load"))
110 '(const :format "%t: unsupported\n" nil))
111 :group 'jit-lock)
112
113
114 (defcustom jit-lock-stealth-verbose nil
115 "*If non-nil, means stealth fontification should show status messages."
116 :type 'boolean
117 :group 'jit-lock)
118
119
120 (defvaralias 'jit-lock-defer-contextually 'jit-lock-contextually)
121 (defcustom jit-lock-contextually 'syntax-driven
122 "*If non-nil, means fontification should be syntactically true.
123 If nil, means fontification occurs only on those lines modified. This
124 means where modification on a line causes syntactic change on subsequent lines,
125 those subsequent lines are not refontified to reflect their new context.
126 If t, means fontification occurs on those lines modified and all
127 subsequent lines. This means those subsequent lines are refontified to reflect
128 their new syntactic context, after `jit-lock-context-time' seconds.
129 If any other value, e.g., `syntax-driven', means syntactically true
130 fontification occurs only if syntactic fontification is performed using the
131 buffer mode's syntax table, i.e., only if `font-lock-keywords-only' is nil.
132
133 The value of this variable is used when JIT Lock mode is turned on."
134 :type '(choice (const :tag "never" nil)
135 (const :tag "always" t)
136 (other :tag "syntax-driven" syntax-driven))
137 :group 'jit-lock)
138
139 (defcustom jit-lock-context-time 0.5
140 "Idle time after which text is contextually refontified, if applicable."
141 :type '(number :tag "seconds")
142 :group 'jit-lock)
143
144 (defcustom jit-lock-defer-time nil ;; 0.25
145 "Idle time after which deferred fontification should take place.
146 If nil, fontification is not deferred."
147 :group 'jit-lock
148 :type '(choice (const :tag "never" nil)
149 (number :tag "seconds")))
150 \f
151 ;;; Variables that are not customizable.
152
153 (defvar jit-lock-mode nil
154 "Non-nil means Just-in-time Lock mode is active.")
155 (make-variable-buffer-local 'jit-lock-mode)
156
157 (defvar jit-lock-functions nil
158 "Functions to do the actual fontification.
159 They are called with two arguments: the START and END of the region to fontify.")
160 (make-variable-buffer-local 'jit-lock-functions)
161
162 (defvar jit-lock-context-unfontify-pos nil
163 "Consider text after this position as contextually unfontified.
164 If nil, contextual fontification is disabled.")
165 (make-variable-buffer-local 'jit-lock-context-unfontify-pos)
166
167
168 (defvar jit-lock-stealth-timer nil
169 "Timer for stealth fontification in Just-in-time Lock mode.")
170 (defvar jit-lock-context-timer nil
171 "Timer for context fontification in Just-in-time Lock mode.")
172 (defvar jit-lock-defer-timer nil
173 "Timer for deferred fontification in Just-in-time Lock mode.")
174
175 (defvar jit-lock-defer-buffers nil
176 "List of buffers with pending deferred fontification.")
177 \f
178 ;;; JIT lock mode
179
180 (defun jit-lock-mode (arg)
181 "Toggle Just-in-time Lock mode.
182 Turn Just-in-time Lock mode on if and only if ARG is non-nil.
183 Enable it automatically by customizing group `font-lock'.
184
185 When Just-in-time Lock mode is enabled, fontification is different in the
186 following ways:
187
188 - Demand-driven buffer fontification triggered by Emacs C code.
189 This means initial fontification of the whole buffer does not occur.
190 Instead, fontification occurs when necessary, such as when scrolling
191 through the buffer would otherwise reveal unfontified areas. This is
192 useful if buffer fontification is too slow for large buffers.
193
194 - Stealthy buffer fontification if `jit-lock-stealth-time' is non-nil.
195 This means remaining unfontified areas of buffers are fontified if Emacs has
196 been idle for `jit-lock-stealth-time' seconds, while Emacs remains idle.
197 This is useful if any buffer has any deferred fontification.
198
199 - Deferred context fontification if `jit-lock-contextually' is
200 non-nil. This means fontification updates the buffer corresponding to
201 true syntactic context, after `jit-lock-context-time' seconds of Emacs
202 idle time, while Emacs remains idle. Otherwise, fontification occurs
203 on modified lines only, and subsequent lines can remain fontified
204 corresponding to previous syntactic contexts. This is useful where
205 strings or comments span lines.
206
207 Stealth fontification only occurs while the system remains unloaded.
208 If the system load rises above `jit-lock-stealth-load' percent, stealth
209 fontification is suspended. Stealth fontification intensity is controlled via
210 the variable `jit-lock-stealth-nice'."
211 (setq jit-lock-mode arg)
212 (cond (;; Turn Just-in-time Lock mode on.
213 jit-lock-mode
214
215 ;; Mark the buffer for refontification.
216 (jit-lock-refontify)
217
218 ;; Install an idle timer for stealth fontification.
219 (when (and jit-lock-stealth-time (null jit-lock-stealth-timer))
220 (setq jit-lock-stealth-timer
221 (run-with-idle-timer jit-lock-stealth-time t
222 'jit-lock-stealth-fontify)))
223
224 ;; Init deferred fontification timer.
225 (when (and jit-lock-defer-time (null jit-lock-defer-timer))
226 (setq jit-lock-defer-timer
227 (run-with-idle-timer jit-lock-defer-time t
228 'jit-lock-deferred-fontify)))
229
230 ;; Initialize contextual fontification if requested.
231 (when (eq jit-lock-contextually t)
232 (unless jit-lock-context-timer
233 (setq jit-lock-context-timer
234 (run-with-idle-timer jit-lock-context-time t
235 'jit-lock-context-fontify)))
236 (setq jit-lock-context-unfontify-pos
237 (or jit-lock-context-unfontify-pos (point-max))))
238
239 ;; Setup our hooks.
240 (add-hook 'after-change-functions 'jit-lock-after-change nil t)
241 (add-hook 'fontification-functions 'jit-lock-function))
242
243 ;; Turn Just-in-time Lock mode off.
244 (t
245 ;; Cancel our idle timers.
246 (when (and (or jit-lock-stealth-timer jit-lock-defer-timer
247 jit-lock-context-timer)
248 ;; Only if there's no other buffer using them.
249 (not (catch 'found
250 (dolist (buf (buffer-list))
251 (with-current-buffer buf
252 (when jit-lock-mode (throw 'found t)))))))
253 (when jit-lock-stealth-timer
254 (cancel-timer jit-lock-stealth-timer)
255 (setq jit-lock-stealth-timer nil))
256 (when jit-lock-context-timer
257 (cancel-timer jit-lock-context-timer)
258 (setq jit-lock-context-timer nil))
259 (when jit-lock-defer-timer
260 (cancel-timer jit-lock-defer-timer)
261 (setq jit-lock-defer-timer nil)))
262
263 ;; Remove hooks.
264 (remove-hook 'after-change-functions 'jit-lock-after-change t)
265 (remove-hook 'fontification-functions 'jit-lock-function))))
266
267 ;;;###autoload
268 (defun jit-lock-register (fun &optional contextual)
269 "Register FUN as a fontification function to be called in this buffer.
270 FUN will be called with two arguments START and END indicating the region
271 that needs to be (re)fontified.
272 If non-nil, CONTEXTUAL means that a contextual fontification would be useful."
273 (add-hook 'jit-lock-functions fun nil t)
274 (when (and contextual jit-lock-contextually)
275 (set (make-local-variable 'jit-lock-contextually) t))
276 (jit-lock-mode t))
277
278 (defun jit-lock-unregister (fun)
279 "Unregister FUN as a fontification function.
280 Only applies to the current buffer."
281 (remove-hook 'jit-lock-functions fun t)
282 (unless jit-lock-functions (jit-lock-mode nil)))
283
284 ;; This function is used to prevent font-lock-fontify-buffer from
285 ;; fontifying eagerly the whole buffer. This is important for
286 ;; things like CWarn mode which adds/removes a few keywords and
287 ;; does a refontify (which takes ages on large files).
288 (defun jit-lock-refontify (&optional beg end)
289 "Force refontification of the region BEG..END (default whole buffer)."
290 (with-buffer-prepared-for-jit-lock
291 (save-restriction
292 (widen)
293 (put-text-property (or beg (point-min)) (or end (point-max))
294 'fontified nil))))
295 \f
296 ;;; On demand fontification.
297
298 (defun jit-lock-function (start)
299 "Fontify current buffer starting at position START.
300 This function is added to `fontification-functions' when `jit-lock-mode'
301 is active."
302 (when (and jit-lock-mode (not (memory-full-p)))
303 (if (null jit-lock-defer-time)
304 ;; No deferral.
305 (jit-lock-fontify-now start (+ start jit-lock-chunk-size))
306 ;; Record the buffer for later fontification.
307 (unless (memq (current-buffer) jit-lock-defer-buffers)
308 (push (current-buffer) jit-lock-defer-buffers))
309 ;; Mark the area as defer-fontified so that the redisplay engine
310 ;; is happy and so that the idle timer can find the places to fontify.
311 (with-buffer-prepared-for-jit-lock
312 (put-text-property start
313 (next-single-property-change
314 start 'fontified nil
315 (min (point-max) (+ start jit-lock-chunk-size)))
316 'fontified 'defer)))))
317
318 (defun jit-lock-fontify-now (&optional start end)
319 "Fontify current buffer from START to END.
320 Defaults to the whole buffer. END can be out of bounds."
321 (with-buffer-prepared-for-jit-lock
322 (save-excursion
323 (unless start (setq start (point-min)))
324 (setq end (if end (min end (point-max)) (point-max)))
325 ;; This did bind `font-lock-beginning-of-syntax-function' to
326 ;; nil at some point, for an unknown reason. Don't do this; it
327 ;; can make highlighting slow due to expensive calls to
328 ;; `parse-partial-sexp' in function
329 ;; `font-lock-fontify-syntactically-region'. Example: paging
330 ;; from the end of a buffer to its start, can do repeated
331 ;; `parse-partial-sexp' starting from `point-min', which can
332 ;; take a long time in a large buffer.
333 (let (next)
334 (save-match-data
335 ;; Fontify chunks beginning at START. The end of a
336 ;; chunk is either `end', or the start of a region
337 ;; before `end' that has already been fontified.
338 (while start
339 ;; Determine the end of this chunk.
340 (setq next (or (text-property-any start end 'fontified t)
341 end))
342
343 ;; Decide which range of text should be fontified.
344 ;; The problem is that START and NEXT may be in the
345 ;; middle of something matched by a font-lock regexp.
346 ;; Until someone has a better idea, let's start
347 ;; at the start of the line containing START and
348 ;; stop at the start of the line following NEXT.
349 (goto-char next) (setq next (line-beginning-position 2))
350 (goto-char start) (setq start (line-beginning-position))
351
352 ;; Fontify the chunk, and mark it as fontified.
353 ;; We mark it first, to make sure that we don't indefinitely
354 ;; re-execute this fontification if an error occurs.
355 (put-text-property start next 'fontified t)
356 (condition-case err
357 (run-hook-with-args 'jit-lock-functions start next)
358 ;; If the user quits (which shouldn't happen in normal on-the-fly
359 ;; jit-locking), make sure the fontification will be performed
360 ;; before displaying the block again.
361 (quit (put-text-property start next 'fontified nil)
362 (funcall 'signal (car err) (cdr err))))
363
364 ;; Find the start of the next chunk, if any.
365 (setq start (text-property-any next end 'fontified nil))))))))
366
367 \f
368 ;;; Stealth fontification.
369
370 (defsubst jit-lock-stealth-chunk-start (around)
371 "Return the start of the next chunk to fontify around position AROUND..
372 Value is nil if there is nothing more to fontify."
373 (if (zerop (buffer-size))
374 nil
375 (save-restriction
376 (widen)
377 (let* ((next (text-property-not-all around (point-max) 'fontified t))
378 (prev (previous-single-property-change around 'fontified))
379 (prop (get-text-property (max (point-min) (1- around))
380 'fontified))
381 (start (cond
382 ((null prev)
383 ;; There is no property change between AROUND
384 ;; and the start of the buffer. If PROP is
385 ;; non-nil, everything in front of AROUND is
386 ;; fontified, otherwise nothing is fontified.
387 (if (eq prop t)
388 nil
389 (max (point-min)
390 (- around (/ jit-lock-chunk-size 2)))))
391 ((eq prop t)
392 ;; PREV is the start of a region of fontified
393 ;; text containing AROUND. Start fontifying a
394 ;; chunk size before the end of the unfontified
395 ;; region in front of that.
396 (max (or (previous-single-property-change prev 'fontified)
397 (point-min))
398 (- prev jit-lock-chunk-size)))
399 (t
400 ;; PREV is the start of a region of unfontified
401 ;; text containing AROUND. Start at PREV or
402 ;; chunk size in front of AROUND, whichever is
403 ;; nearer.
404 (max prev (- around jit-lock-chunk-size)))))
405 (result (cond ((null start) next)
406 ((null next) start)
407 ((< (- around start) (- next around)) start)
408 (t next))))
409 result))))
410
411
412 (defun jit-lock-stealth-fontify ()
413 "Fontify buffers stealthily.
414 This functions is called after Emacs has been idle for
415 `jit-lock-stealth-time' seconds."
416 ;; I used to check `inhibit-read-only' here, but I can't remember why. -stef
417 (unless (or executing-kbd-macro
418 (window-minibuffer-p (selected-window)))
419 (let ((buffers (buffer-list))
420 (outer-buffer (current-buffer))
421 minibuffer-auto-raise
422 message-log-max)
423 (with-local-quit
424 (while (and buffers (not (input-pending-p)))
425 (with-current-buffer (pop buffers)
426 (when jit-lock-mode
427 ;; This is funny. Calling sit-for with 3rd arg non-nil
428 ;; so that it doesn't redisplay, internally calls
429 ;; wait_reading_process_input also with a parameter
430 ;; saying "don't redisplay." Since this function here
431 ;; is called periodically, this effectively leads to
432 ;; process output not being redisplayed at all because
433 ;; redisplay_internal is never called. (That didn't
434 ;; work in the old redisplay either.) So, we learn that
435 ;; we mustn't call sit-for that way here. But then, we
436 ;; have to be cautious not to call sit-for in a widened
437 ;; buffer, since this could display hidden parts of that
438 ;; buffer. This explains the seemingly weird use of
439 ;; save-restriction/widen here.
440
441 (with-temp-message (if jit-lock-stealth-verbose
442 (concat "JIT stealth lock "
443 (buffer-name)))
444
445 ;; In the following code, the `sit-for' calls cause a
446 ;; redisplay, so it's required that the
447 ;; buffer-modified flag of a buffer that is displayed
448 ;; has the right value---otherwise the mode line of
449 ;; an unmodified buffer would show a `*'.
450 (let (start
451 (nice (or jit-lock-stealth-nice 0))
452 (point (point-min)))
453 (while (and (setq start
454 (jit-lock-stealth-chunk-start point))
455 ;; In case sit-for runs any timers,
456 ;; give them the expected current buffer.
457 (with-current-buffer outer-buffer
458 (sit-for nice)))
459
460 ;; fontify a block.
461 (jit-lock-fontify-now start (+ start jit-lock-chunk-size))
462 ;; If stealth jit-locking is done backwards, this leads to
463 ;; excessive O(n^2) refontification. -stef
464 ;; (when (>= jit-lock-context-unfontify-pos start)
465 ;; (setq jit-lock-context-unfontify-pos end))
466
467 ;; Wait a little if load is too high.
468 (when (and jit-lock-stealth-load
469 (> (car (load-average)) jit-lock-stealth-load))
470 ;; In case sit-for runs any timers,
471 ;; give them the expected current buffer.
472 (with-current-buffer outer-buffer
473 (sit-for (or jit-lock-stealth-time 30))))))))))))))
474
475
476 \f
477 ;;; Deferred fontification.
478
479 (defun jit-lock-deferred-fontify ()
480 "Fontify what was deferred."
481 (when jit-lock-defer-buffers
482 ;; Mark the deferred regions back to `fontified = nil'
483 (dolist (buffer jit-lock-defer-buffers)
484 (when (buffer-live-p buffer)
485 (with-current-buffer buffer
486 ;; (message "Jit-Defer %s" (buffer-name))
487 (with-buffer-prepared-for-jit-lock
488 (let ((pos (point-min)))
489 (while
490 (progn
491 (when (eq (get-text-property pos 'fontified) 'defer)
492 (put-text-property
493 pos (setq pos (next-single-property-change
494 pos 'fontified nil (point-max)))
495 'fontified nil))
496 (setq pos (next-single-property-change pos 'fontified)))))))))
497 (setq jit-lock-defer-buffers nil)
498 ;; Force fontification of the visible parts.
499 (let ((jit-lock-defer-time nil))
500 ;; (message "Jit-Defer Now")
501 (sit-for 0)
502 ;; (message "Jit-Defer Done")
503 )))
504
505
506 (defun jit-lock-context-fontify ()
507 "Refresh fontification to take new context into account."
508 (dolist (buffer (buffer-list))
509 (with-current-buffer buffer
510 (when jit-lock-context-unfontify-pos
511 ;; (message "Jit-Context %s" (buffer-name))
512 (save-restriction
513 (widen)
514 (when (and (>= jit-lock-context-unfontify-pos (point-min))
515 (< jit-lock-context-unfontify-pos (point-max)))
516 ;; If we're in text that matches a complex multi-line
517 ;; font-lock pattern, make sure the whole text will be
518 ;; redisplayed eventually.
519 ;; Despite its name, we treat jit-lock-defer-multiline here
520 ;; rather than in jit-lock-defer since it has to do with multiple
521 ;; lines, i.e. with context.
522 (when (get-text-property jit-lock-context-unfontify-pos
523 'jit-lock-defer-multiline)
524 (setq jit-lock-context-unfontify-pos
525 (or (previous-single-property-change
526 jit-lock-context-unfontify-pos
527 'jit-lock-defer-multiline)
528 (point-min))))
529 (with-buffer-prepared-for-jit-lock
530 ;; Force contextual refontification.
531 (remove-text-properties
532 jit-lock-context-unfontify-pos (point-max)
533 '(fontified nil jit-lock-defer-multiline nil)))
534 (setq jit-lock-context-unfontify-pos (point-max))))))))
535
536 (defun jit-lock-after-change (start end old-len)
537 "Mark the rest of the buffer as not fontified after a change.
538 Installed on `after-change-functions'.
539 START and END are the start and end of the changed text. OLD-LEN
540 is the pre-change length.
541 This function ensures that lines following the change will be refontified
542 in case the syntax of those lines has changed. Refontification
543 will take place when text is fontified stealthily."
544 (when (and jit-lock-mode (not (memory-full-p)))
545 (save-excursion
546 (with-buffer-prepared-for-jit-lock
547 ;; It's important that the `fontified' property be set from the
548 ;; beginning of the line, else font-lock will properly change the
549 ;; text's face, but the display will have been done already and will
550 ;; be inconsistent with the buffer's content.
551 (goto-char start)
552 (setq start (line-beginning-position))
553
554 ;; If we're in text that matches a multi-line font-lock pattern,
555 ;; make sure the whole text will be redisplayed.
556 ;; I'm not sure this is ever necessary and/or sufficient. -stef
557 (when (get-text-property start 'font-lock-multiline)
558 (setq start (or (previous-single-property-change
559 start 'font-lock-multiline)
560 (point-min))))
561
562 ;; Make sure we change at least one char (in case of deletions).
563 (setq end (min (max end (1+ start)) (point-max)))
564 ;; Request refontification.
565 (put-text-property start end 'fontified nil))
566 ;; Mark the change for deferred contextual refontification.
567 (when jit-lock-context-unfontify-pos
568 (setq jit-lock-context-unfontify-pos
569 (min jit-lock-context-unfontify-pos start))))))
570
571 (provide 'jit-lock)
572
573 ;;; arch-tag: 56b5de6e-f581-453b-bb97-49c39372ff9e
574 ;;; jit-lock.el ends here