lisp/jit-lock.el

   1 ;;; jit-lock.el --- just-in-time fontification.
   2
   3 ;; Copyright (C) 1998 Free Software Foundation, Inc.
   4
   5 ;; Author: Gerd Moellmann <gerd@gnu.org>
   6 ;; Keywords: faces files
   7 ;; Version: 1.0
   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., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; Just-in-time fontification, triggered by C redisplay code.
  29
  30 ;;; Code:
  31
  32
  33 (require 'font-lock)
  34
  35 (eval-when-compile
  36   (defmacro with-buffer-prepared-for-font-lock (&rest body)
  37     "Execute BODY in current buffer, overriding several variables.
  38 Preserves the `buffer-modified-p' state of the current buffer."
  39     `(let ((modified (buffer-modified-p))
  40            (buffer-undo-list t)
  41            (inhibit-read-only t)
  42            (inhibit-point-motion-hooks t)
  43            before-change-functions
  44            after-change-functions
  45            deactivate-mark
  46            buffer-file-name
  47            buffer-file-truename)
  48        ,@body
  49        (set-buffer-modified-p modified))))
  50
  51
  52 \f
  53 ;;; Customization.
  54
  55 (defcustom jit-lock-chunk-size 500
  56   "*Font-lock chunks of this many characters, or smaller."
  57   :type 'integer
  58   :group 'jit-lock)
  59
  60
  61 (defcustom jit-lock-stealth-time 3
  62   "*Time in seconds to wait before beginning stealth fontification.
  63 Stealth fontification occurs if there is no input within this time.
  64 If nil, means stealth fontification is never performed.
  65
  66 The value of this variable is used when JIT Lock mode is turned on."
  67   :type '(choice (const :tag "never" nil)
  68                  (number :tag "seconds"))
  69   :group 'jit-lock)
  70
  71
  72 (defcustom jit-lock-stealth-nice 0.125
  73   "*Time in seconds to pause between chunks of stealth fontification.
  74 Each iteration of stealth fontification is separated by this amount of time,
  75 thus reducing the demand that stealth fontification makes on the system.
  76 If nil, means stealth fontification is never paused.
  77 To reduce machine load during stealth fontification, at the cost of stealth
  78 taking longer to fontify, you could increase the value of this variable.
  79 See also `jit-lock-stealth-load'."
  80   :type '(choice (const :tag "never" nil)
  81                  (number :tag "seconds"))
  82   :group 'jit-lock)
  83
  84
  85 (defcustom jit-lock-stealth-load
  86   (if (condition-case nil (load-average) (error)) 200)
  87   "*Load in percentage above which stealth fontification is suspended.
  88 Stealth fontification pauses when the system short-term load average (as
  89 returned by the function `load-average' if supported) goes above this level,
  90 thus reducing the demand that stealth fontification makes on the system.
  91 If nil, means stealth fontification is never suspended.
  92 To reduce machine load during stealth fontification, at the cost of stealth
  93 taking longer to fontify, you could reduce the value of this variable.
  94 See also `jit-lock-stealth-nice'."
  95   :type (if (condition-case nil (load-average) (error))
  96             '(choice (const :tag "never" nil)
  97                      (integer :tag "load"))
  98           '(const :format "%t: unsupported\n" nil))
  99   :group 'jit-lock)
 100
 101
 102 (defcustom jit-lock-stealth-verbose nil
 103   "*If non-nil, means stealth fontification should show status messages."
 104   :type 'boolean
 105   :group 'jit-lock)
 106
 107
 108 (defcustom jit-lock-defer-contextually 'syntax-driven
 109   "*If non-nil, means deferred fontification should be syntactically true.
 110 If nil, means deferred fontification occurs only on those lines modified.  This
 111 means where modification on a line causes syntactic change on subsequent lines,
 112 those subsequent lines are not refontified to reflect their new context.
 113 If t, means deferred fontification occurs on those lines modified and all
 114 subsequent lines.  This means those subsequent lines are refontified to reflect
 115 their new syntactic context, either immediately or when scrolling into them.
 116 If any other value, e.g., `syntax-driven', means deferred syntactically true
 117 fontification occurs only if syntactic fontification is performed using the
 118 buffer mode's syntax table, i.e., only if `font-lock-keywords-only' is nil.
 119
 120 The value of this variable is used when JIT Lock mode is turned on."
 121   :type '(choice (const :tag "never" nil)
 122                  (const :tag "always" t)
 123                  (other :tag "syntax-driven" syntax-driven))
 124   :group 'jit-lock)
 125
 126
 127 \f
 128 ;;; Variables that are not customizable.
 129
 130 (defvar jit-lock-mode nil
 131   "Non-nil means Just-in-time Lock mode is active.")
 132 (make-variable-buffer-local 'jit-lock-mode)
 133
 134
 135 (defvar jit-lock-first-unfontify-pos nil
 136   "Consider text after this position as unfontified.")
 137 (make-variable-buffer-local 'jit-lock-first-unfontify-pos)
 138
 139
 140 (defvar jit-lock-stealth-timer nil
 141   "Timer for stealth fontification in Just-in-time Lock mode.")
 142
 143
 144 \f
 145 ;;; JIT lock mode
 146
 147 ;;;###autoload
 148 (defun jit-lock-mode (arg)
 149   "Toggle Just-in-time Lock mode.
 150 With arg, turn Just-in-time Lock mode on if and only if arg is positive.
 151 Enable it automatically by customizing group `font-lock'.
 152
 153 When Just-in-time Lock mode is enabled, fontification is different in the
 154 following ways:
 155
 156 - Demand-driven buffer fontification triggered by Emacs C code.
 157   This means initial fontification of the whole buffer does not occur.
 158   Instead, fontification occurs when necessary, such as when scrolling
 159   through the buffer would otherwise reveal unfontified areas.  This is
 160   useful if buffer fontification is too slow for large buffers.
 161
 162 - Stealthy buffer fontification if `jit-lock-stealth-time' is non-nil.
 163   This means remaining unfontified areas of buffers are fontified if Emacs has
 164   been idle for `jit-lock-stealth-time' seconds, while Emacs remains idle.
 165   This is useful if any buffer has any deferred fontification.
 166
 167 - Deferred context fontification if `jit-lock-defer-contextually' is
 168   non-nil.  This means fontification updates the buffer corresponding to
 169   true syntactic context, after `jit-lock-stealth-time' seconds of Emacs
 170   idle time, while Emacs remains idle.  Otherwise, fontification occurs
 171   on modified lines only, and subsequent lines can remain fontified
 172   corresponding to previous syntactic contexts.  This is useful where
 173   strings or comments span lines.
 174
 175 Stealth fontification only occurs while the system remains unloaded.
 176 If the system load rises above `jit-lock-stealth-load' percent, stealth
 177 fontification is suspended.  Stealth fontification intensity is controlled via
 178 the variable `jit-lock-stealth-nice' and `jit-lock-stealth-lines'."
 179   (interactive "P")
 180   (setq jit-lock-mode (if arg
 181                           (> (prefix-numeric-value arg) 0)
 182                         (not jit-lock-mode)))
 183   (cond ((and jit-lock-mode
 184               (or (not (boundp 'font-lock-mode))
 185                   (not font-lock-mode)))
 186          ;; If font-lock is not on, turn it on, with Just-in-time
 187          ;; Lock mode as support mode; font-lock will call us again.
 188          (let ((font-lock-support-mode 'jit-lock-mode))
 189            (font-lock-mode t)))
 190
 191         ;; Turn Just-in-time Lock mode on.
 192         (jit-lock-mode
 193          ;; Setting `font-lock-fontified' makes font-lock believe the
 194          ;; buffer is already fontified, so that it won't highlight
 195          ;; the whole buffer.
 196          (make-local-variable 'font-lock-fontified)
 197          (setq font-lock-fontified t)
 198
 199          (setq jit-lock-first-unfontify-pos nil)
 200
 201          ;; Install an idle timer for stealth fontification.
 202          (when (and jit-lock-stealth-time
 203                     (null jit-lock-stealth-timer))
 204            (setq jit-lock-stealth-timer
 205                  (run-with-idle-timer jit-lock-stealth-time
 206                                       jit-lock-stealth-time
 207                                       'jit-lock-stealth-fontify)))
 208
 209          ;; Add a hook for deferred contectual fontification.
 210          (when (or (eq jit-lock-defer-contextually 'always)
 211                    (and (not (eq jit-lock-defer-contextually 'never))
 212                         (null font-lock-keywords-only)))
 213            (add-hook 'after-change-functions 'jit-lock-after-change))
 214
 215          ;; Install the fontification hook.
 216          (add-hook 'fontification-functions 'jit-lock-function))
 217
 218         ;; Turn Just-in-time Lock mode off.
 219         (t
 220          ;; Cancel our idle timer.
 221          (when jit-lock-stealth-timer
 222            (cancel-timer jit-lock-stealth-timer)
 223            (setq jit-lock-stealth-timer nil))
 224
 225          ;; Remove hooks.
 226          (remove-hook 'after-change-functions 'jit-lock-after-change)
 227          (remove-hook 'fontification-functions 'jit-lock-function))))
 228
 229
 230 ;;;###autoload
 231 (defun turn-on-jit-lock ()
 232   "Unconditionally turn on Just-in-time Lock mode."
 233   (jit-lock-mode 1))
 234
 235
 236 \f
 237 ;;; On demand fontification.
 238
 239 (defun jit-lock-function (start)
 240   "Fontify current buffer starting at position START.
 241 This function is added to `fontification-functions' when `jit-lock-mode'
 242 is active."
 243   (when jit-lock-mode
 244     (with-buffer-prepared-for-font-lock
 245      (let ((end (min (point-max) (+ start jit-lock-chunk-size)))
 246            (parse-sexp-lookup-properties font-lock-syntactic-keywords)
 247            (old-syntax-table (syntax-table))
 248            (font-lock-beginning-of-syntax-function nil)
 249            next font-lock-start font-lock-end)
 250        (when font-lock-syntax-table
 251          (set-syntax-table font-lock-syntax-table))
 252        (save-excursion
 253          (save-restriction
 254            (widen)
 255            (save-match-data
 256              (condition-case error
 257                  ;; Fontify chunks beginning at START.  The end of a
 258                  ;; chunk is either `end', or the start of a region
 259                  ;; before `end' that has already been fontified.
 260                  (while start
 261                    ;; Determine the end of this chunk.
 262                    (setq next (or (text-property-any start end 'fontified t)
 263                                   end))
 264
 265                    ;; Decide which range of text should be fontified.
 266                    ;; The problem is that START and NEXT may be in the
 267                    ;; middle of something matched by a font-lock regexp.
 268                    ;; Until someone has a better idea, let's start
 269                    ;; at the start of the line containing START and
 270                    ;; stop at the start of the line following NEXT.
 271                    (goto-char next)
 272                    (setq font-lock-end (line-beginning-position 2))
 273                    (goto-char start)
 274                    (setq font-lock-start (line-beginning-position))
 275
 276                    ;; Fontify the chunk, and mark it as fontified.
 277                    (font-lock-fontify-region font-lock-start font-lock-end nil)
 278                    (add-text-properties start next '(fontified t))
 279
 280                    ;; Find the start of the next chunk, if any.
 281                    (setq start (text-property-any next end 'fontified nil)))
 282
 283                ((error quit)
 284                 (message "Fontifying region...%s" error))))))
 285
 286        ;; Restore previous buffer settings.
 287        (set-syntax-table old-syntax-table)))))
 288
 289
 290 (defun jit-lock-after-fontify-buffer ()
 291   "Mark the current buffer as fontified.
 292 Called from `font-lock-after-fontify-buffer."
 293   (with-buffer-prepared-for-font-lock
 294    (add-text-properties (point-min) (point-max) '(fontified t))))
 295
 296
 297 (defun jit-lock-after-unfontify-buffer ()
 298   "Mark the current buffer as unfontified.
 299 Called from `font-lock-after-fontify-buffer."
 300   (with-buffer-prepared-for-font-lock
 301    (remove-text-properties (point-min) (point-max) '(fontified nil))))
 302
 303
 304 \f
 305 ;;; Stealth fontification.
 306
 307 (defsubst jit-lock-stealth-chunk-start (around)
 308   "Return the start of the next chunk to fontify around position AROUND..
 309 Value is nil if there is nothing more to fontify."
 310   (save-restriction
 311     (widen)
 312     (let ((prev (previous-single-property-change around 'fontified))
 313           (next (text-property-any around (point-max) 'fontified nil))
 314           (prop (get-text-property around 'fontified)))
 315       (cond ((and (null prop)
 316                   (< around (point-max)))
 317              ;; Text at position AROUND is not fontified.  The value of
 318              ;; prev, if non-nil, is the start of the region of
 319              ;; unfontified text.  As a special case, prop will always
 320              ;; be nil at point-max.  So don't handle that case here.
 321              (max (or prev (point-min))
 322                   (- around jit-lock-chunk-size)))
 323
 324             ((null prev)
 325              ;; Text at AROUND is fontified, and everything up to
 326              ;; point-min is.  Return the value of next.  If that is
 327              ;; nil, there is nothing left to fontify.
 328              next)
 329
 330             ((or (null next)
 331                  (< (- around prev) (- next around)))
 332              ;; We either have no unfontified text following AROUND, or
 333              ;; the unfontified text in front of AROUND is nearer.  The
 334              ;; value of prev is the end of the region of unfontified
 335              ;; text in front of AROUND.
 336              (let ((start (previous-single-property-change prev 'fontified)))
 337                (max (or start (point-min))
 338                     (- prev jit-lock-chunk-size))))
 339
 340             (t
 341              next)))))
 342
 343
 344 (defun jit-lock-stealth-fontify ()
 345   "Fontify buffers stealthily.
 346 This functions is called after Emacs has been idle for
 347 `jit-lock-stealth-time' seconds."
 348   (unless (or executing-kbd-macro
 349               (window-minibuffer-p (selected-window)))
 350     (let ((buffers (buffer-list))
 351           minibuffer-auto-raise
 352           message-log-max)
 353       (while (and buffers
 354                   (not (input-pending-p)))
 355         (let ((buffer (car buffers)))
 356           (setq buffers (cdr buffers))
 357           (with-current-buffer buffer
 358             (when jit-lock-mode
 359               ;; This is funny.  Calling sit-for with 3rd arg non-nil
 360               ;; so that it doesn't redisplay, internally calls
 361               ;; wait_reading_process_input also with a parameter
 362               ;; saying "don't redisplay."  Since this function here
 363               ;; is called periodically, this effectively leads to
 364               ;; process output not being redisplayed at all because
 365               ;; redisplay_internal is never called.  (That didn't
 366               ;; work in the old redisplay either.)  So, we learn that
 367               ;; we mustn't call sit-for that way here.  But then, we
 368               ;; have to be cautious not to call sit-for in a widened
 369               ;; buffer, since this could display hidden parts of that
 370               ;; buffer.  This explains the seemingly weird use of
 371               ;; save-restriction/widen here.
 372
 373               (with-temp-message (if jit-lock-stealth-verbose
 374                                      (concat "JIT stealth lock "
 375                                              (buffer-name)))
 376
 377                 ;; Perform deferred unfontification, if any.
 378                 (when jit-lock-first-unfontify-pos
 379                   (save-restriction
 380                     (widen)
 381                     (when (and (>= jit-lock-first-unfontify-pos (point-min))
 382                                (< jit-lock-first-unfontify-pos (point-max)))
 383                       (with-buffer-prepared-for-font-lock
 384                        (put-text-property jit-lock-first-unfontify-pos
 385                                           (point-max) 'fontified nil))
 386                       (setq jit-lock-first-unfontify-pos nil))))
 387
 388                 (let (start
 389                       (nice (or jit-lock-stealth-nice 0))
 390                       (point (point)))
 391                   (while (and (setq start
 392                                     (jit-lock-stealth-chunk-start point))
 393                               (sit-for nice))
 394
 395                     ;; Wait a little if load is too high.
 396                     (when (and jit-lock-stealth-load
 397                                (> (car (load-average)) jit-lock-stealth-load))
 398                       (sit-for (or jit-lock-stealth-time 30)))
 399
 400                     ;; Unless there's input pending now, fontify.
 401                     (unless (input-pending-p)
 402                       (jit-lock-function start))))))))))))
 403
 404
 405 \f
 406 ;;; Deferred fontification.
 407
 408 (defun jit-lock-after-change (start end old-len)
 409   "Mark the rest of the buffer as not fontified after a change.
 410 Installed on `after-change-functions'.
 411 START and END are the start and end of the changed text.  OLD-LEN
 412 is the pre-change length.
 413 This function ensures that lines following the change will be refontified
 414 in case the syntax of those lines has changed.  Refontification
 415 will take place when text is fontified stealthily."
 416   ;; Don't do much here---removing text properties is too slow for
 417   ;; fast typers, giving them the impression of Emacs not being
 418   ;; very responsive.
 419   (when jit-lock-mode
 420     (setq jit-lock-first-unfontify-pos
 421           (if jit-lock-first-unfontify-pos
 422               (min jit-lock-first-unfontify-pos start)
 423             start))))
 424
 425
 426 (provide 'jit-lock)
 427
 428 ;; jit-lock.el ends here