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
|