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