lisp/emacs-lisp/syntax.el

   1 ;;; syntax.el --- helper functions to find syntactic context
   2
   3 ;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006 Free Software Foundation, Inc.
   5
   6 ;; Maintainer: FSF
   7 ;; Keywords: internal
   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 ;; The main exported function is `syntax-ppss'.  You might also need
  29 ;; to call `syntax-ppss-flush-cache' or to add it to
  30 ;; before-change-functions'(although this is automatically done by
  31 ;; syntax-ppss when needed, but that might fail if syntax-ppss is
  32 ;; called in a context where before-change-functions is temporarily
  33 ;; let-bound to nil).
  34
  35 ;;; Todo:
  36
  37 ;; - do something about the case where the syntax-table is changed.
  38 ;;   This typically happens with tex-mode and its `$' operator.
  39 ;; - move font-lock-syntactic-keywords in here.  Then again, maybe not.
  40 ;; - new functions `syntax-state', ... to replace uses of parse-partial-state
  41 ;;   with something higher-level (similar to syntax-ppss-context).
  42 ;; - interaction with mmm-mode.
  43
  44 ;;; Code:
  45
  46 ;; Note: PPSS stands for `parse-partial-sexp state'
  47
  48 (eval-when-compile (require 'cl))
  49
  50 (defvar font-lock-beginning-of-syntax-function)
  51
  52 (defsubst syntax-ppss-depth (ppss)
  53   (nth 0 ppss))
  54
  55 (defsubst syntax-ppss-context (ppss)
  56   (cond
  57    ((nth 3 ppss) 'string)
  58    ((nth 4 ppss) 'comment)
  59    (t nil)))
  60
  61 (defvar syntax-ppss-max-span 20000
  62   "Threshold below which cache info is deemed unnecessary.
  63 We try to make sure that cache entries are at least this far apart
  64 from each other, to avoid keeping too much useless info.")
  65
  66 (defvar syntax-begin-function nil
  67   "Function to move back outside of any comment/string/paren.
  68 This function should move the cursor back to some syntactically safe
  69 point (where the PPSS is equivalent to nil).")
  70
  71 (defvar syntax-ppss-cache nil
  72   "List of (POS . PPSS) pairs, in decreasing POS order.")
  73 (make-variable-buffer-local 'syntax-ppss-cache)
  74 (defvar syntax-ppss-last nil
  75   "Cache of (LAST-POS . LAST-PPSS).")
  76 (make-variable-buffer-local 'syntax-ppss-last)
  77
  78 (defalias 'syntax-ppss-after-change-function 'syntax-ppss-flush-cache)
  79 (defun syntax-ppss-flush-cache (beg &rest ignored)
  80   "Flush the cache of `syntax-ppss' starting at position BEG."
  81   ;; Flush invalid cache entries.
  82   (while (and syntax-ppss-cache (> (caar syntax-ppss-cache) beg))
  83     (setq syntax-ppss-cache (cdr syntax-ppss-cache)))
  84   ;; Throw away `last' value if made invalid.
  85   (when (< beg (or (car syntax-ppss-last) 0))
  86     ;; If syntax-begin-function jumped to BEG, then the old state at BEG can
  87     ;; depend on the text after BEG (which is presumably changed).  So if
  88     ;; BEG=(car (nth 10 syntax-ppss-last)) don't reuse that data because the
  89     ;; assumed nil state at BEG may not be valid any more.
  90     (if (<= beg (or (car (nth 10 syntax-ppss-last))
  91                     (nth 9 syntax-ppss-last)
  92                     (nth 3 syntax-ppss-last)
  93                     0))
  94         (setq syntax-ppss-last nil)
  95       (setcar syntax-ppss-last nil)))
  96   ;; Unregister if there's no cache left.  Sadly this doesn't work
  97   ;; because `before-change-functions' is temporarily bound to nil here.
  98   ;; (unless syntax-ppss-cache
  99   ;;   (remove-hook 'before-change-functions 'syntax-ppss-flush-cache t))
 100   )
 101
 102 (defvar syntax-ppss-stats
 103   [(0 . 0.0) (0 . 0.0) (0 . 0.0) (0 . 0.0) (0 . 0.0) (1 . 2500.0)])
 104 (defun syntax-ppss-stats ()
 105   (mapcar (lambda (x)
 106             (condition-case nil
 107                 (cons (car x) (truncate (/ (cdr x) (car x))))
 108               (error nil)))
 109           syntax-ppss-stats))
 110
 111 (defun syntax-ppss (&optional pos)
 112   "Parse-Partial-Sexp State at POS.
 113 The returned value is the same as `parse-partial-sexp' except that
 114 the 2nd and 6th values of the returned state cannot be relied upon.
 115 Point is at POS when this function returns."
 116   ;; Default values.
 117   (unless pos (setq pos (point)))
 118   ;;
 119   (let ((old-ppss (cdr syntax-ppss-last))
 120         (old-pos (car syntax-ppss-last))
 121         (ppss nil)
 122         (pt-min (point-min)))
 123     (if (and old-pos (> old-pos pos)) (setq old-pos nil))
 124     ;; Use the OLD-POS if usable and close.  Don't update the `last' cache.
 125     (condition-case nil
 126         (if (and old-pos (< (- pos old-pos)
 127                             ;; The time to use syntax-begin-function and
 128                             ;; find PPSS is assumed to be about 2 * distance.
 129                             (* 2 (/ (cdr (aref syntax-ppss-stats 5))
 130                                     (1+ (car (aref syntax-ppss-stats 5)))))))
 131             (progn
 132               (incf (car (aref syntax-ppss-stats 0)))
 133               (incf (cdr (aref syntax-ppss-stats 0)) (- pos old-pos))
 134               (parse-partial-sexp old-pos pos nil nil old-ppss))
 135
 136           (cond
 137            ;; Use OLD-PPSS if possible and close enough.
 138            ((and (not old-pos) old-ppss
 139                  ;; BEWARE! We rely on the undocumented 9th field.  The 9th
 140                  ;; field currently contains the list of positions of
 141                  ;; open-parens of the enclosing parens.  I.e. those
 142                  ;; positions are outside of any string/comment
 143                  ;; and the first of those is outside of any paren
 144                  ;; (i.e. corresponds to a nil ppss).  If this list is empty
 145                  ;; but we are in a string or comment, then the 8th field
 146                  ;; contains a similar "toplevel" position.  If `pt-min' is
 147                  ;; too far from `pos', we could try to use other positions
 148                  ;; in (nth 9 old-ppss), but that doesn't seem to happen in
 149                  ;; practice and it would complicate this code (and the
 150                  ;; before-change-function code even more).  But maybe it
 151                  ;; would be useful in "degenerate" cases such as when the
 152                  ;; whole file is wrapped in a set of parenthesis.
 153                  (setq pt-min (or (car (nth 9 old-ppss))
 154                                   (nth 8 old-ppss)
 155                                   (nth 2 old-ppss)))
 156                  (<= pt-min pos) (< (- pos pt-min) syntax-ppss-max-span))
 157             (incf (car (aref syntax-ppss-stats 1)))
 158             (incf (cdr (aref syntax-ppss-stats 1)) (- pos pt-min))
 159             (setq ppss (parse-partial-sexp pt-min pos)))
 160            ;; The OLD-* data can't be used.  Consult the cache.
 161            (t
 162             (let ((cache-pred nil)
 163                   (cache syntax-ppss-cache)
 164                   (pt-min (point-min))
 165                   ;; I differentiate between PT-MIN and PT-BEST because
 166                   ;; I feel like it might be important to ensure that the
 167                   ;; cache is only filled with 100% sure data (whereas
 168                   ;; syntax-begin-function might return incorrect data).
 169                   ;; Maybe that's just stupid.
 170                   (pt-best (point-min))
 171                   (ppss-best nil))
 172               ;; look for a usable cache entry.
 173               (while (and cache (< pos (caar cache)))
 174                 (setq cache-pred cache)
 175                 (setq cache (cdr cache)))
 176               (if cache (setq pt-min (caar cache) ppss (cdar cache)))
 177
 178               ;; Setup the before-change function if necessary.
 179               (unless (or syntax-ppss-cache syntax-ppss-last)
 180                 (add-hook 'before-change-functions
 181                           'syntax-ppss-flush-cache t t))
 182
 183               ;; Use the best of OLD-POS and CACHE.
 184               (if (or (not old-pos) (< old-pos pt-min))
 185                   (setq pt-best pt-min ppss-best ppss)
 186                 (incf (car (aref syntax-ppss-stats 4)))
 187                 (incf (cdr (aref syntax-ppss-stats 4)) (- pos old-pos))
 188                 (setq pt-best old-pos ppss-best old-ppss))
 189
 190               ;; Use the `syntax-begin-function' if available.
 191               ;; We could try using that function earlier, but:
 192               ;; - The result might not be 100% reliable, so it's better to use
 193               ;;   the cache if available.
 194               ;; - The function might be slow.
 195               ;; - If this function almost always finds a safe nearby spot,
 196               ;;   the cache won't be populated, so consulting it is cheap.
 197               (when (and (not syntax-begin-function)
 198                          (boundp 'font-lock-beginning-of-syntax-function)
 199                          font-lock-beginning-of-syntax-function)
 200                 (set (make-local-variable 'syntax-begin-function)
 201                      font-lock-beginning-of-syntax-function))
 202               (when (and syntax-begin-function
 203                          (progn (goto-char pos)
 204                                 (funcall syntax-begin-function)
 205                                 ;; Make sure it's better.
 206                                 (> (point) pt-best))
 207                          ;; Simple sanity check.
 208                          (not (memq (get-text-property (point) 'face)
 209                                     '(font-lock-string-face font-lock-doc-face
 210                                       font-lock-comment-face))))
 211                 (incf (car (aref syntax-ppss-stats 5)))
 212                 (incf (cdr (aref syntax-ppss-stats 5)) (- pos (point)))
 213                 (setq pt-best (point) ppss-best nil))
 214
 215               (cond
 216                ;; Quick case when we found a nearby pos.
 217                ((< (- pos pt-best) syntax-ppss-max-span)
 218                 (incf (car (aref syntax-ppss-stats 2)))
 219                 (incf (cdr (aref syntax-ppss-stats 2)) (- pos pt-best))
 220                 (setq ppss (parse-partial-sexp pt-best pos nil nil ppss-best)))
 221                ;; Slow case: compute the state from some known position and
 222                ;; populate the cache so we won't need to do it again soon.
 223                (t
 224                 (incf (car (aref syntax-ppss-stats 3)))
 225                 (incf (cdr (aref syntax-ppss-stats 3)) (- pos pt-min))
 226
 227                 ;; If `pt-min' is too far, add a few intermediate entries.
 228                 (while (> (- pos pt-min) (* 2 syntax-ppss-max-span))
 229                   (setq ppss (parse-partial-sexp
 230                               pt-min (setq pt-min (/ (+ pt-min pos) 2))
 231                               nil nil ppss))
 232                   (let ((pair (cons pt-min ppss)))
 233                     (if cache-pred
 234                         (push pair (cdr cache-pred))
 235                       (push pair syntax-ppss-cache))))
 236
 237                 ;; Compute the actual return value.
 238                 (setq ppss (parse-partial-sexp pt-min pos nil nil ppss))
 239
 240                 ;; Debugging check.
 241                 ;; (let ((real-ppss (parse-partial-sexp (point-min) pos)))
 242                 ;;   (setcar (last ppss 4) 0)
 243                 ;;   (setcar (last real-ppss 4) 0)
 244                 ;;   (setcar (last ppss 8) nil)
 245                 ;;   (setcar (last real-ppss 8) nil)
 246                 ;;   (unless (equal ppss real-ppss)
 247                 ;;     (message "!!Syntax: %s != %s" ppss real-ppss)
 248                 ;;     (setq ppss real-ppss)))
 249
 250                 ;; Store it in the cache.
 251                 (let ((pair (cons pos ppss)))
 252                   (if cache-pred
 253                       (if (> (- (caar cache-pred) pos) syntax-ppss-max-span)
 254                           (push pair (cdr cache-pred))
 255                         (setcar cache-pred pair))
 256                     (if (or (null syntax-ppss-cache)
 257                             (> (- (caar syntax-ppss-cache) pos)
 258                                syntax-ppss-max-span))
 259                         (push pair syntax-ppss-cache)
 260                       (setcar syntax-ppss-cache pair)))))))))
 261
 262           (setq syntax-ppss-last (cons pos ppss))
 263           ppss)
 264       (args-out-of-range
 265        ;; If the buffer is more narrowed than when we built the cache,
 266        ;; we may end up calling parse-partial-sexp with a position before
 267        ;; point-min.  In that case, just parse from point-min assuming
 268        ;; a nil state.
 269        (parse-partial-sexp (point-min) pos)))))
 270
 271 ;; Debugging functions
 272
 273 (defun syntax-ppss-debug ()
 274   (let ((pt nil)
 275         (min-diffs nil))
 276     (dolist (x (append syntax-ppss-cache (list (cons (point-min) nil))))
 277       (when pt (push (- pt (car x)) min-diffs))
 278       (setq pt (car x)))
 279     min-diffs))
 280
 281 ;; XEmacs compatibility functions
 282
 283 ;; (defun buffer-syntactic-context (&optional buffer)
 284 ;;   "Syntactic context at point in BUFFER.
 285 ;; Either of `string', `comment' or `nil'.
 286 ;; This is an XEmacs compatibility function."
 287 ;;   (with-current-buffer (or buffer (current-buffer))
 288 ;;     (syntax-ppss-context (syntax-ppss))))
 289
 290 ;; (defun buffer-syntactic-context-depth (&optional buffer)
 291 ;;   "Syntactic parenthesis depth at point in BUFFER.
 292 ;; This is an XEmacs compatibility function."
 293 ;;   (with-current-buffer (or buffer (current-buffer))
 294 ;;     (syntax-ppss-depth (syntax-ppss))))
 295
 296 (provide 'syntax)
 297
 298 ;; arch-tag: 302f1eeb-e77c-4680-a8c5-c543e01161a5
 299 ;;; syntax.el ends here