LCOV - code coverage report
Current view: top level - lisp/emacs-lisp - syntax.el (source / functions) Hit Total Coverage
Test: tramp-tests-after.info Lines: 0 231 0.0 %
Date: 2017-08-30 10:12:24 Functions: 0 20 0.0 %

          Line data    Source code
       1             : ;;; syntax.el --- helper functions to find syntactic context  -*- lexical-binding: t -*-
       2             : 
       3             : ;; Copyright (C) 2000-2017 Free Software Foundation, Inc.
       4             : 
       5             : ;; Maintainer: emacs-devel@gnu.org
       6             : ;; Keywords: internal
       7             : 
       8             : ;; This file is part of GNU Emacs.
       9             : 
      10             : ;; GNU Emacs is free software: you can redistribute it and/or modify
      11             : ;; it under the terms of the GNU General Public License as published by
      12             : ;; the Free Software Foundation, either version 3 of the License, or
      13             : ;; (at your option) any later version.
      14             : 
      15             : ;; GNU Emacs is distributed in the hope that it will be useful,
      16             : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
      17             : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
      18             : ;; GNU General Public License for more details.
      19             : 
      20             : ;; You should have received a copy of the GNU General Public License
      21             : ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
      22             : 
      23             : ;;; Commentary:
      24             : 
      25             : ;; The main exported function is `syntax-ppss'.  You might also need
      26             : ;; to call `syntax-ppss-flush-cache' or to add it to
      27             : ;; before-change-functions'(although this is automatically done by
      28             : ;; syntax-ppss when needed, but that might fail if syntax-ppss is
      29             : ;; called in a context where before-change-functions is temporarily
      30             : ;; let-bound to nil).
      31             : 
      32             : ;;; Todo:
      33             : 
      34             : ;; - do something about the case where the syntax-table is changed.
      35             : ;;   This typically happens with tex-mode and its `$' operator.
      36             : ;; - new functions `syntax-state', ... to replace uses of parse-partial-state
      37             : ;;   with something higher-level (similar to syntax-ppss-context).
      38             : ;; - interaction with mmm-mode.
      39             : 
      40             : ;;; Code:
      41             : 
      42             : ;; Note: PPSS stands for `parse-partial-sexp state'
      43             : 
      44             : (eval-when-compile (require 'cl-lib))
      45             : 
      46             : ;;; Applying syntax-table properties where needed.
      47             : 
      48             : (defvar syntax-propertize-function nil
      49             :   ;; Rather than a -functions hook, this is a -function because it's easier
      50             :   ;; to do a single scan than several scans: with multiple scans, one cannot
      51             :   ;; assume that the text before point has been propertized, so syntax-ppss
      52             :   ;; gives unreliable results (and stores them in its cache to boot, so we'd
      53             :   ;; have to flush that cache between each function, and we couldn't use
      54             :   ;; syntax-ppss-flush-cache since that would not only flush the cache but also
      55             :   ;; reset syntax-propertize--done which should not be done in this case).
      56             :   "Mode-specific function to apply `syntax-table' text properties.
      57             : It is the work horse of `syntax-propertize', which is called by things like
      58             : Font-Lock and indentation.
      59             : 
      60             : It is given two arguments, START and END: the start and end of the text to
      61             : which `syntax-table' might need to be applied.  Major modes can use this to
      62             : override the buffer's syntax table for special syntactic constructs that
      63             : cannot be handled just by the buffer's syntax-table.
      64             : 
      65             : The specified function may call `syntax-ppss' on any position
      66             : before END, but it should not call `syntax-ppss-flush-cache',
      67             : which means that it should not call `syntax-ppss' on some
      68             : position and later modify the buffer on some earlier position.")
      69             : 
      70             : (defvar syntax-propertize-chunk-size 500)
      71             : 
      72             : (defvar syntax-propertize-extend-region-functions
      73             :   '(syntax-propertize-wholelines)
      74             :   "Special hook run just before proceeding to propertize a region.
      75             : This is used to allow major modes to help `syntax-propertize' find safe buffer
      76             : positions as beginning and end of the propertized region.  Its most common use
      77             : is to solve the problem of /identification/ of multiline elements by providing
      78             : a function that tries to find such elements and move the boundaries such that
      79             : they do not fall in the middle of one.
      80             : Each function is called with two arguments (START and END) and it should return
      81             : either a cons (NEW-START . NEW-END) or nil if no adjustment should be made.
      82             : These functions are run in turn repeatedly until they all return nil.
      83             : Put first the functions more likely to cause a change and cheaper to compute.")
      84             : ;; Mark it as a special hook which doesn't use any global setting
      85             : ;; (i.e. doesn't obey the element t in the buffer-local value).
      86             : (make-variable-buffer-local 'syntax-propertize-extend-region-functions)
      87             : 
      88             : (defun syntax-propertize-wholelines (start end)
      89           0 :   (goto-char start)
      90           0 :   (cons (line-beginning-position)
      91           0 :         (progn (goto-char end)
      92           0 :                (if (bolp) (point) (line-beginning-position 2)))))
      93             : 
      94             : (defun syntax-propertize-multiline (beg end)
      95             :   "Let `syntax-propertize' pay attention to the syntax-multiline property."
      96           0 :   (when (and (> beg (point-min))
      97           0 :              (get-text-property (1- beg) 'syntax-multiline))
      98           0 :     (setq beg (or (previous-single-property-change beg 'syntax-multiline)
      99           0 :                   (point-min))))
     100             :   ;;
     101           0 :   (when (get-text-property end 'syntax-multiline)
     102           0 :     (setq end (or (text-property-any end (point-max)
     103           0 :                                      'syntax-multiline nil)
     104           0 :                   (point-max))))
     105           0 :   (cons beg end))
     106             : 
     107             : (defun syntax-propertize--shift-groups (re n)
     108           0 :   (replace-regexp-in-string
     109             :    "\\\\(\\?\\([0-9]+\\):"
     110             :    (lambda (s)
     111           0 :      (replace-match
     112           0 :       (number-to-string (+ n (string-to-number (match-string 1 s))))
     113           0 :       t t s 1))
     114           0 :    re t t))
     115             : 
     116             : (defmacro syntax-propertize-precompile-rules (&rest rules)
     117             :   "Return a precompiled form of RULES to pass to `syntax-propertize-rules'.
     118             : The arg RULES can be of the same form as in `syntax-propertize-rules'.
     119             : The return value is an object that can be passed as a rule to
     120             : `syntax-propertize-rules'.
     121             : I.e. this is useful only when you want to share rules among several
     122             : `syntax-propertize-function's."
     123             :   (declare (debug syntax-propertize-rules))
     124             :   ;; Precompile?  Yeah, right!
     125             :   ;; Seriously, tho, this is a macro for 2 reasons:
     126             :   ;; - we could indeed do some pre-compilation at some point in the future,
     127             :   ;;   e.g. fi/when we switch to a DFA-based implementation of
     128             :   ;;   syntax-propertize-rules.
     129             :   ;; - this lets Edebug properly annotate the expressions inside RULES.
     130           0 :   `',rules)
     131             : 
     132             : (defmacro syntax-propertize-rules (&rest rules)
     133             :   "Make a function that applies RULES for use in `syntax-propertize-function'.
     134             : The function will scan the buffer, applying the rules where they match.
     135             : The buffer is scanned a single time, like \"lex\" would, rather than once
     136             : per rule.
     137             : 
     138             : Each RULE can be a symbol, in which case that symbol's value should be,
     139             : at macro-expansion time, a precompiled set of rules, as returned
     140             : by `syntax-propertize-precompile-rules'.
     141             : 
     142             : Otherwise, RULE should have the form (REGEXP HIGHLIGHT1 ... HIGHLIGHTn), where
     143             : REGEXP is an expression (evaluated at time of macro-expansion) that returns
     144             : a regexp, and where HIGHLIGHTs have the form (NUMBER SYNTAX) which means to
     145             : apply the property SYNTAX to the chars matched by the subgroup NUMBER
     146             : of the regular expression, if NUMBER did match.
     147             : SYNTAX is an expression that returns a value to apply as `syntax-table'
     148             : property.  Some expressions are handled specially:
     149             : - if SYNTAX is a string, then it is converted with `string-to-syntax';
     150             : - if SYNTAX has the form (prog1 EXP . EXPS) then the value returned by EXP
     151             :   will be applied to the buffer before running EXPS and if EXP is a string it
     152             :   is also converted with `string-to-syntax'.
     153             : The SYNTAX expression is responsible to save the `match-data' if needed
     154             : for subsequent HIGHLIGHTs.
     155             : Also SYNTAX is free to move point, in which case RULES may not be applied to
     156             : some parts of the text or may be applied several times to other parts.
     157             : 
     158             : Note: back-references in REGEXPs do not work."
     159             :   (declare (debug (&rest &or symbolp    ;FIXME: edebug this eval step.
     160             :                          (form &rest
     161             :                                (numberp
     162             :                                 [&or stringp ;FIXME: Use &wrap
     163             :                                      ("prog1" [&or stringp def-form] def-body)
     164             :                                      def-form])))))
     165           0 :   (let ((newrules nil))
     166           0 :     (while rules
     167           0 :       (if (symbolp (car rules))
     168           0 :           (setq rules (append (symbol-value (pop rules)) rules))
     169           0 :         (push (pop rules) newrules)))
     170           0 :     (setq rules (nreverse newrules)))
     171           0 :   (let* ((offset 0)
     172             :          (branches '())
     173             :          ;; We'd like to use a real DFA-based lexer, usually, but since Emacs
     174             :          ;; doesn't have one yet, we fallback on building one large regexp
     175             :          ;; and use groups to determine which branch of the regexp matched.
     176             :          (re
     177           0 :           (mapconcat
     178             :            (lambda (rule)
     179           0 :              (let* ((orig-re (eval (car rule)))
     180           0 :                     (re orig-re))
     181           0 :                (when (and (assq 0 rule) (cdr rules))
     182             :                  ;; If there's more than 1 rule, and the rule want to apply
     183             :                  ;; highlight to match 0, create an extra group to be able to
     184             :                  ;; tell when *this* match 0 has succeeded.
     185           0 :                  (cl-incf offset)
     186           0 :                  (setq re (concat "\\(" re "\\)")))
     187           0 :                (setq re (syntax-propertize--shift-groups re offset))
     188           0 :                (let ((code '())
     189             :                      (condition
     190           0 :                       (cond
     191           0 :                        ((assq 0 rule) (if (zerop offset) t
     192           0 :                                         `(match-beginning ,offset)))
     193           0 :                        ((null (cddr rule))
     194           0 :                         `(match-beginning ,(+ offset (car (cadr rule)))))
     195             :                        (t
     196           0 :                         `(or ,@(mapcar
     197             :                                 (lambda (case)
     198           0 :                                   `(match-beginning ,(+ offset (car case))))
     199           0 :                                 (cdr rule))))))
     200             :                      (nocode t)
     201           0 :                      (offset offset))
     202             :                  ;; If some of the subgroup rules include Elisp code, then we
     203             :                  ;; need to set the match-data so it's consistent with what the
     204             :                  ;; code expects.  If not, then we can simply use shifted
     205             :                  ;; offset in our own code.
     206           0 :                  (unless (zerop offset)
     207           0 :                    (dolist (case (cdr rule))
     208           0 :                      (unless (stringp (cadr case))
     209           0 :                        (setq nocode nil)))
     210           0 :                    (unless nocode
     211           0 :                      (push `(let ((md (match-data 'ints)))
     212             :                               ;; Keep match 0 as is, but shift everything else.
     213           0 :                               (setcdr (cdr md) (nthcdr ,(* (1+ offset) 2) md))
     214           0 :                               (set-match-data md))
     215           0 :                            code)
     216           0 :                      (setq offset 0)))
     217             :                  ;; Now construct the code for each subgroup rules.
     218           0 :                  (dolist (case (cdr rule))
     219           0 :                    (cl-assert (null (cddr case)))
     220           0 :                    (let* ((gn (+ offset (car case)))
     221           0 :                           (action (nth 1 case))
     222             :                           (thiscode
     223           0 :                            (cond
     224           0 :                             ((stringp action)
     225           0 :                              `((put-text-property
     226           0 :                                 (match-beginning ,gn) (match-end ,gn)
     227             :                                 'syntax-table
     228           0 :                                 ',(string-to-syntax action))))
     229           0 :                             ((eq (car-safe action) 'ignore)
     230           0 :                              (cdr action))
     231           0 :                             ((eq (car-safe action) 'prog1)
     232           0 :                              (if (stringp (nth 1 action))
     233           0 :                                  `((put-text-property
     234           0 :                                     (match-beginning ,gn) (match-end ,gn)
     235             :                                     'syntax-table
     236           0 :                                     ',(string-to-syntax (nth 1 action)))
     237           0 :                                    ,@(nthcdr 2 action))
     238           0 :                                `((let ((mb (match-beginning ,gn))
     239           0 :                                        (me (match-end ,gn))
     240           0 :                                        (syntax ,(nth 1 action)))
     241             :                                    (if syntax
     242             :                                        (put-text-property
     243             :                                         mb me 'syntax-table syntax))
     244           0 :                                    ,@(nthcdr 2 action)))))
     245             :                             (t
     246           0 :                              `((let ((mb (match-beginning ,gn))
     247           0 :                                      (me (match-end ,gn))
     248           0 :                                      (syntax ,action))
     249             :                                  (if syntax
     250             :                                      (put-text-property
     251           0 :                                       mb me 'syntax-table syntax))))))))
     252             : 
     253           0 :                      (if (or (not (cddr rule)) (zerop gn))
     254           0 :                          (setq code (nconc (nreverse thiscode) code))
     255           0 :                        (push `(if (match-beginning ,gn)
     256             :                                   ;; Try and generate clean code with no
     257             :                                   ;; extraneous progn.
     258           0 :                                   ,(if (null (cdr thiscode))
     259           0 :                                        (car thiscode)
     260           0 :                                      `(progn ,@thiscode)))
     261           0 :                              code))))
     262           0 :                  (push (cons condition (nreverse code))
     263           0 :                        branches))
     264           0 :                (cl-incf offset (regexp-opt-depth orig-re))
     265           0 :                re))
     266           0 :            rules
     267           0 :            "\\|")))
     268           0 :     `(lambda (start end)
     269             :        (goto-char start)
     270             :        (while (and (< (point) end)
     271           0 :                    (re-search-forward ,re end t))
     272           0 :          (cond ,@(nreverse branches))))))
     273             : 
     274             : (defun syntax-propertize-via-font-lock (keywords)
     275             :   "Propertize for syntax using font-lock syntax.
     276             : KEYWORDS obeys the format used in `font-lock-syntactic-keywords'.
     277             : The return value is a function (with two parameters, START and
     278             : END) suitable for `syntax-propertize-function'."
     279             :   (lambda (start end)
     280           0 :     (with-no-warnings
     281           0 :       (let ((font-lock-syntactic-keywords keywords))
     282           0 :         (font-lock-fontify-syntactic-keywords-region start end)
     283             :         ;; In case it was eval'd/compiled.
     284           0 :         (setq keywords font-lock-syntactic-keywords)))))
     285             : 
     286             : (defun syntax-propertize (pos)
     287             :   "Ensure that syntax-table properties are set until POS (a buffer point)."
     288           0 :   (when (< syntax-propertize--done pos)
     289           0 :     (if (null syntax-propertize-function)
     290           0 :         (setq syntax-propertize--done (max (point-max) pos))
     291             :       ;; (message "Needs to syntax-propertize from %s to %s"
     292             :       ;;          syntax-propertize--done pos)
     293           0 :       (set (make-local-variable 'parse-sexp-lookup-properties) t)
     294           0 :       (save-excursion
     295           0 :         (with-silent-modifications
     296           0 :           (make-local-variable 'syntax-propertize--done) ;Just in case!
     297           0 :           (let* ((start (max (min syntax-propertize--done (point-max))
     298           0 :                              (point-min)))
     299           0 :                  (end (max pos
     300           0 :                            (min (point-max)
     301           0 :                                 (+ start syntax-propertize-chunk-size))))
     302           0 :                  (funs syntax-propertize-extend-region-functions))
     303           0 :             (while funs
     304           0 :               (let ((new (funcall (pop funs) start end))
     305             :                     ;; Avoid recursion!
     306           0 :                     (syntax-propertize--done most-positive-fixnum))
     307           0 :                 (if (or (null new)
     308           0 :                         (and (>= (car new) start) (<= (cdr new) end)))
     309             :                     nil
     310           0 :                   (setq start (car new))
     311           0 :                   (setq end (cdr new))
     312             :                   ;; If there's been a change, we should go through the
     313             :                   ;; list again since this new position may
     314             :                   ;; warrant a different answer from one of the funs we've
     315             :                   ;; already seen.
     316           0 :                   (unless (eq funs
     317           0 :                               (cdr syntax-propertize-extend-region-functions))
     318           0 :                     (setq funs syntax-propertize-extend-region-functions)))))
     319             :             ;; Flush ppss cache between the original value of `start' and that
     320             :             ;; set above by syntax-propertize-extend-region-functions.
     321           0 :             (syntax-ppss-flush-cache start)
     322             :             ;; Move the limit before calling the function, so the function
     323             :             ;; can use syntax-ppss.
     324           0 :             (setq syntax-propertize--done end)
     325             :             ;; (message "syntax-propertizing from %s to %s" start end)
     326           0 :             (remove-text-properties start end
     327           0 :                                     '(syntax-table nil syntax-multiline nil))
     328             :             ;; Avoid recursion!
     329           0 :             (let ((syntax-propertize--done most-positive-fixnum))
     330           0 :               (funcall syntax-propertize-function start end))))))))
     331             : 
     332             : ;;; Link syntax-propertize with syntax.c.
     333             : 
     334             : (defvar syntax-propertize-chunks
     335             :   ;; We're not sure how far we'll go.  In my tests, using chunks of 2000
     336             :   ;; brings to overhead to something negligible.  Passing ‘charpos’ directly
     337             :   ;; also works (basically works line-by-line) but results in an overhead which
     338             :   ;; I thought was a bit too high (like around 50%).
     339             :   2000)
     340             : 
     341             : (defun internal--syntax-propertize (charpos)
     342             :   ;; FIXME: Called directly from C.
     343           0 :   (save-match-data
     344           0 :     (syntax-propertize (min (+ syntax-propertize-chunks charpos) (point-max)))))
     345             : 
     346             : ;;; Incrementally compute and memoize parser state.
     347             : 
     348             : (defsubst syntax-ppss-depth (ppss)
     349           0 :   (nth 0 ppss))
     350             : 
     351             : (defun syntax-ppss-toplevel-pos (ppss)
     352             :   "Get the latest syntactically outermost position found in a syntactic scan.
     353             : PPSS is a scan state, as returned by `parse-partial-sexp' or `syntax-ppss'.
     354             : An \"outermost position\" means one that it is outside of any syntactic entity:
     355             : outside of any parentheses, comments, or strings encountered in the scan.
     356             : If no such position is recorded in PPSS (because the end of the scan was
     357             : itself at the outermost level), return nil."
     358             :   ;; BEWARE! We rely on the undocumented 9th field.  The 9th field currently
     359             :   ;; contains the list of positions of the enclosing open-parens.
     360             :   ;; I.e. those positions are outside of any string/comment and the first of
     361             :   ;; those is outside of any paren (i.e. corresponds to a nil ppss).
     362             :   ;; If this list is empty but we are in a string or comment, then the 8th
     363             :   ;; field contains a similar "toplevel" position.
     364           0 :   (or (car (nth 9 ppss))
     365           0 :       (nth 8 ppss)))
     366             : 
     367             : (defsubst syntax-ppss-context (ppss)
     368           0 :   (cond
     369           0 :    ((nth 3 ppss) 'string)
     370           0 :    ((nth 4 ppss) 'comment)
     371           0 :    (t nil)))
     372             : 
     373             : (defvar syntax-ppss-max-span 20000
     374             :   "Threshold below which cache info is deemed unnecessary.
     375             : We try to make sure that cache entries are at least this far apart
     376             : from each other, to avoid keeping too much useless info.")
     377             : 
     378             : (defvar syntax-begin-function nil
     379             :   "Function to move back outside of any comment/string/paren.
     380             : This function should move the cursor back to some syntactically safe
     381             : point (where the PPSS is equivalent to nil).")
     382             : (make-obsolete-variable 'syntax-begin-function nil "25.1")
     383             : 
     384             : (defvar-local syntax-ppss-cache nil
     385             :   "List of (POS . PPSS) pairs, in decreasing POS order.")
     386             : (defvar-local syntax-ppss-last nil
     387             :   "Cache of (LAST-POS . LAST-PPSS).")
     388             : 
     389             : (defalias 'syntax-ppss-after-change-function 'syntax-ppss-flush-cache)
     390             : (defun syntax-ppss-flush-cache (beg &rest ignored)
     391             :   "Flush the cache of `syntax-ppss' starting at position BEG."
     392             :   ;; Set syntax-propertize to refontify anything past beg.
     393           0 :   (setq syntax-propertize--done (min beg syntax-propertize--done))
     394             :   ;; Flush invalid cache entries.
     395           0 :   (while (and syntax-ppss-cache (> (caar syntax-ppss-cache) beg))
     396           0 :     (setq syntax-ppss-cache (cdr syntax-ppss-cache)))
     397             :   ;; Throw away `last' value if made invalid.
     398           0 :   (when (< beg (or (car syntax-ppss-last) 0))
     399             :     ;; If syntax-begin-function jumped to BEG, then the old state at BEG can
     400             :     ;; depend on the text after BEG (which is presumably changed).  So if
     401             :     ;; BEG=(car (nth 10 syntax-ppss-last)) don't reuse that data because the
     402             :     ;; assumed nil state at BEG may not be valid any more.
     403           0 :     (if (<= beg (or (syntax-ppss-toplevel-pos (cdr syntax-ppss-last))
     404           0 :                     (nth 3 syntax-ppss-last)
     405           0 :                     0))
     406           0 :         (setq syntax-ppss-last nil)
     407           0 :       (setcar syntax-ppss-last nil)))
     408             :   ;; Unregister if there's no cache left.  Sadly this doesn't work
     409             :   ;; because `before-change-functions' is temporarily bound to nil here.
     410             :   ;; (unless syntax-ppss-cache
     411             :   ;;   (remove-hook 'before-change-functions 'syntax-ppss-flush-cache t))
     412             :   )
     413             : 
     414             : (defvar syntax-ppss-stats
     415             :   [(0 . 0.0) (0 . 0.0) (0 . 0.0) (0 . 0.0) (0 . 0.0) (1 . 2500.0)])
     416             : (defun syntax-ppss-stats ()
     417           0 :   (mapcar (lambda (x)
     418           0 :             (condition-case nil
     419           0 :                 (cons (car x) (truncate (/ (cdr x) (car x))))
     420           0 :               (error nil)))
     421           0 :           syntax-ppss-stats))
     422             : 
     423             : (defvar-local syntax-ppss-table nil
     424             :   "Syntax-table to use during `syntax-ppss', if any.")
     425             : 
     426             : (defun syntax-ppss (&optional pos)
     427             :   "Parse-Partial-Sexp State at POS, defaulting to point.
     428             : The returned value is the same as that of `parse-partial-sexp'
     429             : run from `point-min' to POS except that values at positions 2 and 6
     430             : in the returned list (counting from 0) cannot be relied upon.
     431             : Point is at POS when this function returns.
     432             : 
     433             : It is necessary to call `syntax-ppss-flush-cache' explicitly if
     434             : this function is called while `before-change-functions' is
     435             : temporarily let-bound, or if the buffer is modified without
     436             : running the hook."
     437             :   ;; Default values.
     438           0 :   (unless pos (setq pos (point)))
     439           0 :   (syntax-propertize pos)
     440             :   ;;
     441           0 :   (with-syntax-table (or syntax-ppss-table (syntax-table))
     442           0 :   (let ((old-ppss (cdr syntax-ppss-last))
     443           0 :         (old-pos (car syntax-ppss-last))
     444             :         (ppss nil)
     445           0 :         (pt-min (point-min)))
     446           0 :     (if (and old-pos (> old-pos pos)) (setq old-pos nil))
     447             :     ;; Use the OLD-POS if usable and close.  Don't update the `last' cache.
     448           0 :     (condition-case nil
     449           0 :         (if (and old-pos (< (- pos old-pos)
     450             :                             ;; The time to use syntax-begin-function and
     451             :                             ;; find PPSS is assumed to be about 2 * distance.
     452           0 :                             (* 2 (/ (cdr (aref syntax-ppss-stats 5))
     453           0 :                                     (1+ (car (aref syntax-ppss-stats 5)))))))
     454           0 :             (progn
     455           0 :               (cl-incf (car (aref syntax-ppss-stats 0)))
     456           0 :               (cl-incf (cdr (aref syntax-ppss-stats 0)) (- pos old-pos))
     457           0 :               (parse-partial-sexp old-pos pos nil nil old-ppss))
     458             : 
     459           0 :           (cond
     460             :            ;; Use OLD-PPSS if possible and close enough.
     461           0 :            ((and (not old-pos) old-ppss
     462             :                  ;; If `pt-min' is too far from `pos', we could try to use
     463             :                  ;; other positions in (nth 9 old-ppss), but that doesn't
     464             :                  ;; seem to happen in practice and it would complicate this
     465             :                  ;; code (and the before-change-function code even more).
     466             :                  ;; But maybe it would be useful in "degenerate" cases such
     467             :                  ;; as when the whole file is wrapped in a set
     468             :                  ;; of parentheses.
     469           0 :                  (setq pt-min (or (syntax-ppss-toplevel-pos old-ppss)
     470           0 :                                   (nth 2 old-ppss)))
     471           0 :                  (<= pt-min pos) (< (- pos pt-min) syntax-ppss-max-span))
     472           0 :             (cl-incf (car (aref syntax-ppss-stats 1)))
     473           0 :             (cl-incf (cdr (aref syntax-ppss-stats 1)) (- pos pt-min))
     474           0 :             (setq ppss (parse-partial-sexp pt-min pos)))
     475             :            ;; The OLD-* data can't be used.  Consult the cache.
     476             :            (t
     477           0 :             (let ((cache-pred nil)
     478           0 :                   (cache syntax-ppss-cache)
     479           0 :                   (pt-min (point-min))
     480             :                   ;; I differentiate between PT-MIN and PT-BEST because
     481             :                   ;; I feel like it might be important to ensure that the
     482             :                   ;; cache is only filled with 100% sure data (whereas
     483             :                   ;; syntax-begin-function might return incorrect data).
     484             :                   ;; Maybe that's just stupid.
     485           0 :                   (pt-best (point-min))
     486             :                   (ppss-best nil))
     487             :               ;; look for a usable cache entry.
     488           0 :               (while (and cache (< pos (caar cache)))
     489           0 :                 (setq cache-pred cache)
     490           0 :                 (setq cache (cdr cache)))
     491           0 :               (if cache (setq pt-min (caar cache) ppss (cdar cache)))
     492             : 
     493             :               ;; Setup the before-change function if necessary.
     494           0 :               (unless (or syntax-ppss-cache syntax-ppss-last)
     495           0 :                 (add-hook 'before-change-functions
     496           0 :                           'syntax-ppss-flush-cache t t))
     497             : 
     498             :               ;; Use the best of OLD-POS and CACHE.
     499           0 :               (if (or (not old-pos) (< old-pos pt-min))
     500           0 :                   (setq pt-best pt-min ppss-best ppss)
     501           0 :                 (cl-incf (car (aref syntax-ppss-stats 4)))
     502           0 :                 (cl-incf (cdr (aref syntax-ppss-stats 4)) (- pos old-pos))
     503           0 :                 (setq pt-best old-pos ppss-best old-ppss))
     504             : 
     505             :               ;; Use the `syntax-begin-function' if available.
     506             :               ;; We could try using that function earlier, but:
     507             :               ;; - The result might not be 100% reliable, so it's better to use
     508             :               ;;   the cache if available.
     509             :               ;; - The function might be slow.
     510             :               ;; - If this function almost always finds a safe nearby spot,
     511             :               ;;   the cache won't be populated, so consulting it is cheap.
     512           0 :               (when (and syntax-begin-function
     513           0 :                          (progn (goto-char pos)
     514           0 :                                 (funcall syntax-begin-function)
     515             :                                 ;; Make sure it's better.
     516           0 :                                 (> (point) pt-best))
     517             :                          ;; Simple sanity checks.
     518           0 :                          (< (point) pos) ; backward-paragraph can fail here.
     519           0 :                          (not (memq (get-text-property (point) 'face)
     520             :                                     '(font-lock-string-face font-lock-doc-face
     521           0 :                                       font-lock-comment-face))))
     522           0 :                 (cl-incf (car (aref syntax-ppss-stats 5)))
     523           0 :                 (cl-incf (cdr (aref syntax-ppss-stats 5)) (- pos (point)))
     524           0 :                 (setq pt-best (point) ppss-best nil))
     525             : 
     526           0 :               (cond
     527             :                ;; Quick case when we found a nearby pos.
     528           0 :                ((< (- pos pt-best) syntax-ppss-max-span)
     529           0 :                 (cl-incf (car (aref syntax-ppss-stats 2)))
     530           0 :                 (cl-incf (cdr (aref syntax-ppss-stats 2)) (- pos pt-best))
     531           0 :                 (setq ppss (parse-partial-sexp pt-best pos nil nil ppss-best)))
     532             :                ;; Slow case: compute the state from some known position and
     533             :                ;; populate the cache so we won't need to do it again soon.
     534             :                (t
     535           0 :                 (cl-incf (car (aref syntax-ppss-stats 3)))
     536           0 :                 (cl-incf (cdr (aref syntax-ppss-stats 3)) (- pos pt-min))
     537             : 
     538             :                 ;; If `pt-min' is too far, add a few intermediate entries.
     539           0 :                 (while (> (- pos pt-min) (* 2 syntax-ppss-max-span))
     540           0 :                   (setq ppss (parse-partial-sexp
     541           0 :                               pt-min (setq pt-min (/ (+ pt-min pos) 2))
     542           0 :                               nil nil ppss))
     543           0 :                   (push (cons pt-min ppss)
     544           0 :                         (if cache-pred (cdr cache-pred) syntax-ppss-cache)))
     545             : 
     546             :                 ;; Compute the actual return value.
     547           0 :                 (setq ppss (parse-partial-sexp pt-min pos nil nil ppss))
     548             : 
     549             :                 ;; Debugging check.
     550             :                 ;; (let ((real-ppss (parse-partial-sexp (point-min) pos)))
     551             :                 ;;   (setcar (last ppss 4) 0)
     552             :                 ;;   (setcar (last real-ppss 4) 0)
     553             :                 ;;   (setcar (last ppss 8) nil)
     554             :                 ;;   (setcar (last real-ppss 8) nil)
     555             :                 ;;   (unless (equal ppss real-ppss)
     556             :                 ;;     (message "!!Syntax: %s != %s" ppss real-ppss)
     557             :                 ;;     (setq ppss real-ppss)))
     558             : 
     559             :                 ;; Store it in the cache.
     560           0 :                 (let ((pair (cons pos ppss)))
     561           0 :                   (if cache-pred
     562           0 :                       (if (> (- (caar cache-pred) pos) syntax-ppss-max-span)
     563           0 :                           (push pair (cdr cache-pred))
     564           0 :                         (setcar cache-pred pair))
     565           0 :                     (if (or (null syntax-ppss-cache)
     566           0 :                             (> (- (caar syntax-ppss-cache) pos)
     567           0 :                                syntax-ppss-max-span))
     568           0 :                         (push pair syntax-ppss-cache)
     569           0 :                       (setcar syntax-ppss-cache pair)))))))))
     570             : 
     571           0 :           (setq syntax-ppss-last (cons pos ppss))
     572           0 :           ppss)
     573             :       (args-out-of-range
     574             :        ;; If the buffer is more narrowed than when we built the cache,
     575             :        ;; we may end up calling parse-partial-sexp with a position before
     576             :        ;; point-min.  In that case, just parse from point-min assuming
     577             :        ;; a nil state.
     578           0 :        (parse-partial-sexp (point-min) pos))))))
     579             : 
     580             : ;; Debugging functions
     581             : 
     582             : (defun syntax-ppss-debug ()
     583           0 :   (let ((pt nil)
     584             :         (min-diffs nil))
     585           0 :     (dolist (x (append syntax-ppss-cache (list (cons (point-min) nil))))
     586           0 :       (when pt (push (- pt (car x)) min-diffs))
     587           0 :       (setq pt (car x)))
     588           0 :     min-diffs))
     589             : 
     590             : ;; XEmacs compatibility functions
     591             : 
     592             : ;; (defun buffer-syntactic-context (&optional buffer)
     593             : ;;   "Syntactic context at point in BUFFER.
     594             : ;; Either of `string', `comment' or nil.
     595             : ;; This is an XEmacs compatibility function."
     596             : ;;   (with-current-buffer (or buffer (current-buffer))
     597             : ;;     (syntax-ppss-context (syntax-ppss))))
     598             : 
     599             : ;; (defun buffer-syntactic-context-depth (&optional buffer)
     600             : ;;   "Syntactic parenthesis depth at point in BUFFER.
     601             : ;; This is an XEmacs compatibility function."
     602             : ;;   (with-current-buffer (or buffer (current-buffer))
     603             : ;;     (syntax-ppss-depth (syntax-ppss))))
     604             : 
     605             : (provide 'syntax)
     606             : 
     607             : ;;; syntax.el ends here

Generated by: LCOV version 1.12