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      (save-excursion
 246        (save-restriction
 247          (widen)
 248          (let ((end (min (point-max) (+ start jit-lock-chunk-size)))
 249                (parse-sexp-lookup-properties font-lock-syntactic-keywords)
 250                (font-lock-beginning-of-syntax-function nil)
 251                (old-syntax-table (syntax-table))
 252                next font-lock-start font-lock-end)
 253            (when font-lock-syntax-table
 254              (set-syntax-table font-lock-syntax-table))
 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   (if (zerop (buffer-size))
 311       nil
 312     (save-restriction
 313       (widen)
 314       (let* ((next (text-property-any around (point-max) 'fontified nil))
 315              (prev (previous-single-property-change around 'fontified))
 316              (prop (get-text-property (max (point-min) (1- around))
 317                                       'fontified))
 318              (start (cond
 319                      ((null prev)
 320                       ;; There is no property change between AROUND
 321                       ;; and the start of the buffer.  If PROP is
 322                       ;; non-nil, everything in front of AROUND is
 323                       ;; fontified, otherwise nothing is fontified.
 324                       (if prop
 325                           nil
 326                         (max (point-min)
 327                              (- around (/ jit-lock-chunk-size 2)))))
 328                      (prop
 329                       ;; PREV is the start of a region of fontified
 330                       ;; text containing AROUND.  Start fontfifying a
 331                       ;; chunk size before the end of the unfontified
 332                       ;; region in front of that.
 333                       (max (or (previous-single-property-change prev 'fontified)
 334                                (point-min))
 335                            (- prev jit-lock-chunk-size)))
 336                      (t
 337                       ;; PREV is the start of a region of unfontified
 338                       ;; text containing AROUND.  Start at PREV or
 339                       ;; chunk size in front of AROUND, whichever is
 340                       ;; nearer.
 341                       (max prev (- around jit-lock-chunk-size)))))
 342              (result (cond ((null start) next)
 343                            ((null next) start)
 344                            ((< (- around start) (- next around)) start)
 345                            (t next))))
 346         result))))
 347
 348
 349 (defun jit-lock-stealth-fontify ()
 350   "Fontify buffers stealthily.
 351 This functions is called after Emacs has been idle for
 352 `jit-lock-stealth-time' seconds."
 353   (unless (or executing-kbd-macro
 354               (window-minibuffer-p (selected-window)))
 355     (let ((buffers (buffer-list))
 356           minibuffer-auto-raise
 357           message-log-max)
 358       (while (and buffers (not (input-pending-p)))
 359         (let ((buffer (car buffers)))
 360           (setq buffers (cdr buffers))
 361
 362           (with-current-buffer buffer
 363             (when jit-lock-mode
 364               ;; This is funny.  Calling sit-for with 3rd arg non-nil
 365               ;; so that it doesn't redisplay, internally calls
 366               ;; wait_reading_process_input also with a parameter
 367               ;; saying "don't redisplay."  Since this function here
 368               ;; is called periodically, this effectively leads to
 369               ;; process output not being redisplayed at all because
 370               ;; redisplay_internal is never called.  (That didn't
 371               ;; work in the old redisplay either.)  So, we learn that
 372               ;; we mustn't call sit-for that way here.  But then, we
 373               ;; have to be cautious not to call sit-for in a widened
 374               ;; buffer, since this could display hidden parts of that
 375               ;; buffer.  This explains the seemingly weird use of
 376               ;; save-restriction/widen here.
 377
 378               (with-temp-message (if jit-lock-stealth-verbose
 379                                      (concat "JIT stealth lock "
 380                                              (buffer-name)))
 381
 382                 ;; Perform deferred unfontification, if any.
 383                 (when jit-lock-first-unfontify-pos
 384                   (save-restriction
 385                     (widen)
 386                     (when (and (>= jit-lock-first-unfontify-pos (point-min))
 387                                (< jit-lock-first-unfontify-pos (point-max)))
 388                       (with-buffer-prepared-for-font-lock
 389                        (put-text-property jit-lock-first-unfontify-pos
 390                                           (point-max) 'fontified nil))
 391                       (setq jit-lock-first-unfontify-pos nil))))
 392
 393                 (let (start
 394                       (nice (or jit-lock-stealth-nice 0))
 395                       (point (point)))
 396                   (while (and (setq start (jit-lock-stealth-chunk-start point))
 397                               (sit-for nice))
 398
 399                     ;; Wait a little if load is too high.
 400                     (when (and jit-lock-stealth-load
 401                                (> (car (load-average)) jit-lock-stealth-load))
 402                       (sit-for (or jit-lock-stealth-time 30)))
 403
 404                     ;; Unless there's input pending now, fontify.
 405                     (unless (input-pending-p)
 406                       (jit-lock-function start))))))))))))
 407
 408
 409 \f
 410 ;;; Deferred fontification.
 411
 412 (defun jit-lock-after-change (start end old-len)
 413   "Mark the rest of the buffer as not fontified after a change.
 414 Installed on `after-change-functions'.
 415 START and END are the start and end of the changed text.  OLD-LEN
 416 is the pre-change length.
 417 This function ensures that lines following the change will be refontified
 418 in case the syntax of those lines has changed.  Refontification
 419 will take place when text is fontified stealthily."
 420   ;; Don't do much here---removing text properties is too slow for
 421   ;; fast typers, giving them the impression of Emacs not being
 422   ;; very responsive.
 423   (when jit-lock-mode
 424     (setq jit-lock-first-unfontify-pos
 425           (if jit-lock-first-unfontify-pos
 426               (min jit-lock-first-unfontify-pos start)
 427             start))))
 428
 429
 430 (provide 'jit-lock)
 431
 432 ;; jit-lock.el ends here