Update copyright year to 2014 by running admin/update-copyright.
[emacs.git] / lisp / cedet / semantic / edit.el
blob7b148743fcb501e8d7c46a9700ccca3b6acd2143
1 ;;; semantic/edit.el --- Edit Management for Semantic
3 ;; Copyright (C) 1999-2014 Free Software Foundation, Inc.
5 ;; Author: Eric M. Ludlam <zappo@gnu.org>
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software: you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation, either version 3 of the License, or
12 ;; (at your option) any later version.
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
22 ;;; Commentary:
24 ;; In Semantic 1.x, changes were handled in a simplistic manner, where
25 ;; tags that changed were reparsed one at a time. Any other form of
26 ;; edit were managed through a full reparse.
28 ;; This code attempts to minimize the number of times a full reparse
29 ;; needs to occur. While overlays and tags will continue to be
30 ;; recycled in the simple case, new cases where tags are inserted
31 ;; or old tags removed from the original list are handled.
34 ;;; NOTES FOR IMPROVEMENT
36 ;; Work done by the incremental parser could be improved by the
37 ;; following:
39 ;; 1. Tags created could have as a property an overlay marking a region
40 ;; of themselves that can be edited w/out affecting the definition of
41 ;; that tag.
43 ;; 2. Tags w/ positioned children could have a property of an
44 ;; overlay marking the region in themselves that contain the
45 ;; children. This could be used to better improve splicing near
46 ;; the beginning and end of the child lists.
49 ;;; BUGS IN INCREMENTAL PARSER
51 ;; 1. Changes in the whitespace between tags could extend a
52 ;; following tag. These will be marked as merely unmatched
53 ;; syntax instead.
55 ;; 2. Incremental parsing while a new function is being typed in
56 ;; sometimes gets a chance only when lists are incomplete,
57 ;; preventing correct context identification.
60 (require 'semantic)
62 ;;; Code:
63 (defvar semantic-after-partial-cache-change-hook nil
64 "Normal hook run after the buffer cache has been updated.
66 This hook will run when the cache has been partially reparsed.
67 Partial reparses are incurred when a user edits a buffer, and only the
68 modified sections are rescanned.
70 Hook functions must take one argument, which is the list of tags
71 updated in the current buffer.
73 For language specific hooks, make sure you define this as a local hook.")
75 (define-obsolete-variable-alias 'semantic-change-hooks
76 'semantic-change-functions "24.3")
77 (defvar semantic-change-functions
78 '(semantic-edits-change-function-handle-changes)
79 "Abnormal hook run when semantic detects a change in a buffer.
80 Each hook function must take three arguments, identical to the
81 common hook `after-change-functions'.")
83 (defvar semantic-reparse-needed-change-hook nil
84 "Hooks run when a user edit is detected as needing a reparse.
85 For language specific hooks, make sure you define this as a local hook.
86 Not used yet; part of the next generation reparse mechanism.")
88 (defvar semantic-no-reparse-needed-change-hook nil
89 "Hooks run when a user edit is detected as not needing a reparse.
90 If the hook returns non-nil, then declare that a reparse is needed.
91 For language specific hooks, make sure you define this as a local hook.
92 Not used yet; part of the next generation reparse mechanism.")
94 (define-obsolete-variable-alias 'semantic-edits-new-change-hooks
95 'semantic-edits-new-change-functions "24.3")
96 (defvar semantic-edits-new-change-functions nil
97 "Abnormal hook run when a new change is found.
98 Functions must take one argument representing an overlay on that change.")
100 (define-obsolete-variable-alias 'semantic-edits-delete-change-hooks
101 'semantic-edits-delete-change-functions "24.3")
102 (defvar semantic-edits-delete-change-functions nil
103 "Abnormal hook run before a change overlay is deleted.
104 Deleted changes occur when multiple changes are merged.
105 Functions must take one argument representing an overlay being deleted.")
107 (defvar semantic-edits-move-change-hook nil
108 "Abnormal hook run after a change overlay is moved.
109 Changes move when a new change overlaps an old change. The old change
110 will be moved.
111 Functions must take one argument representing an overlay being moved.")
113 (define-obsolete-variable-alias 'semantic-edits-reparse-change-hooks
114 'semantic-edits-reparse-change-functions "24.3")
115 (defvar semantic-edits-reparse-change-functions nil
116 "Abnormal hook run after a change results in a reparse.
117 Functions are called before the overlay is deleted, and after the
118 incremental reparse.")
120 (defvar semantic-edits-incremental-reparse-failed-hook nil
121 "Hook run after the incremental parser fails.
122 When this happens, the buffer is marked as needing a full reparse.")
124 (semantic-varalias-obsolete 'semantic-edits-incremental-reparse-failed-hooks
125 'semantic-edits-incremental-reparse-failed-hook "23.2")
127 (defcustom semantic-edits-verbose-flag nil
128 "Non-nil means the incremental parser is verbose.
129 If nil, errors are still displayed, but informative messages are not."
130 :group 'semantic
131 :type 'boolean)
133 ;;; Change State management
135 ;; Manage a series of overlays that define changes recently
136 ;; made to the current buffer.
137 ;;;###autoload
138 (defun semantic-change-function (start end length)
139 "Provide a mechanism for semantic tag management.
140 Argument START, END, and LENGTH specify the bounds of the change."
141 (setq semantic-unmatched-syntax-cache-check t)
142 (let ((inhibit-point-motion-hooks t)
144 (save-match-data
145 (run-hook-with-args 'semantic-change-functions start end length)
148 (defun semantic-changes-in-region (start end &optional buffer)
149 "Find change overlays which exist in whole or in part between START and END.
150 Optional argument BUFFER is the buffer to search for changes in."
151 (save-excursion
152 (if buffer (set-buffer buffer))
153 (let ((ol (semantic-overlays-in (max start (point-min))
154 (min end (point-max))))
155 (ret nil))
156 (while ol
157 (when (semantic-overlay-get (car ol) 'semantic-change)
158 (setq ret (cons (car ol) ret)))
159 (setq ol (cdr ol)))
160 (sort ret #'(lambda (a b) (< (semantic-overlay-start a)
161 (semantic-overlay-start b)))))))
163 (defun semantic-edits-change-function-handle-changes (start end length)
164 "Run whenever a buffer controlled by `semantic-mode' change.
165 Tracks when and how the buffer is re-parsed.
166 Argument START, END, and LENGTH specify the bounds of the change."
167 ;; We move start/end by one so that we can merge changes that occur
168 ;; just before, or just after. This lets simple typing capture everything
169 ;; into one overlay.
170 (let ((changes-in-change (semantic-changes-in-region (1- start) (1+ end)))
172 (semantic-parse-tree-set-needs-update)
173 (if (not changes-in-change)
174 (let ((o (semantic-make-overlay start end)))
175 (semantic-overlay-put o 'semantic-change t)
176 ;; Run the hooks safely. When hooks blow it, our dirty
177 ;; function will be removed from the list of active change
178 ;; functions.
179 (condition-case nil
180 (run-hook-with-args 'semantic-edits-new-change-functions o)
181 (error nil)))
182 (let ((tmp changes-in-change))
183 ;; Find greatest bounds of all changes
184 (while tmp
185 (when (< (semantic-overlay-start (car tmp)) start)
186 (setq start (semantic-overlay-start (car tmp))))
187 (when (> (semantic-overlay-end (car tmp)) end)
188 (setq end (semantic-overlay-end (car tmp))))
189 (setq tmp (cdr tmp)))
190 ;; Move the first found overlay, recycling that overlay.
191 (semantic-overlay-move (car changes-in-change) start end)
192 (condition-case nil
193 (run-hook-with-args 'semantic-edits-move-change-hooks
194 (car changes-in-change))
195 (error nil))
196 (setq changes-in-change (cdr changes-in-change))
197 ;; Delete other changes. They are now all bound here.
198 (while changes-in-change
199 (condition-case nil
200 (run-hook-with-args 'semantic-edits-delete-change-functions
201 (car changes-in-change))
202 (error nil))
203 (semantic-overlay-delete (car changes-in-change))
204 (setq changes-in-change (cdr changes-in-change))))
207 (defsubst semantic-edits-flush-change (change)
208 "Flush the CHANGE overlay."
209 (condition-case nil
210 (run-hook-with-args 'semantic-edits-delete-change-functions
211 change)
212 (error nil))
213 (semantic-overlay-delete change))
215 (defun semantic-edits-flush-changes ()
216 "Flush the changes in the current buffer."
217 (let ((changes (semantic-changes-in-region (point-min) (point-max))))
218 (while changes
219 (semantic-edits-flush-change (car changes))
220 (setq changes (cdr changes))))
223 (defun semantic-edits-change-in-one-tag-p (change hits)
224 "Return non-nil of the overlay CHANGE exists solely in one leaf tag.
225 HITS is the list of tags that CHANGE is in. It can have more than
226 one tag in it if the leaf tag is within a parent tag."
227 (and (< (semantic-tag-start (car hits))
228 (semantic-overlay-start change))
229 (> (semantic-tag-end (car hits))
230 (semantic-overlay-end change))
231 ;; Recurse on the rest. If this change is inside all
232 ;; of these tags, then they are all leaves or parents
233 ;; of the smallest tag.
234 (or (not (cdr hits))
235 (semantic-edits-change-in-one-tag-p change (cdr hits))))
238 ;;; Change/Tag Query functions
240 ;; A change (region of space) can effect tags in different ways.
241 ;; These functions perform queries on a buffer to determine different
242 ;; ways that a change effects a buffer.
244 ;; NOTE: After debugging these, replace below to no longer look
245 ;; at point and mark (via comments I assume.)
246 (defsubst semantic-edits-os (change)
247 "For testing: Start of CHANGE, or smaller of (point) and (mark)."
248 (if change (semantic-overlay-start change)
249 (if (< (point) (mark)) (point) (mark))))
251 (defsubst semantic-edits-oe (change)
252 "For testing: End of CHANGE, or larger of (point) and (mark)."
253 (if change (semantic-overlay-end change)
254 (if (> (point) (mark)) (point) (mark))))
256 (defun semantic-edits-change-leaf-tag (change)
257 "A leaf tag which completely encompasses CHANGE.
258 If change overlaps a tag, but is not encompassed in it, return nil.
259 Use `semantic-edits-change-overlap-leaf-tag'.
260 If CHANGE is completely encompassed in a tag, but overlaps sub-tags,
261 return nil."
262 (let* ((start (semantic-edits-os change))
263 (end (semantic-edits-oe change))
264 (tags (nreverse
265 (semantic-find-tag-by-overlay-in-region
266 start end))))
267 ;; A leaf is always first in this list
268 (if (and tags
269 (<= (semantic-tag-start (car tags)) start)
270 (> (semantic-tag-end (car tags)) end))
271 ;; Ok, we have a match. If this tag has children,
272 ;; we have to do more tests.
273 (let ((chil (semantic-tag-components (car tags))))
274 (if (not chil)
275 ;; Simple leaf.
276 (car tags)
277 ;; For this type, we say that we encompass it if the
278 ;; change occurs outside the range of the children.
279 (if (or (not (semantic-tag-with-position-p (car chil)))
280 (> start (semantic-tag-end (nth (1- (length chil)) chil)))
281 (< end (semantic-tag-start (car chil))))
282 ;; We have modifications to the definition of this parent
283 ;; so we have to reparse the whole thing.
284 (car tags)
285 ;; We actually modified an area between some children.
286 ;; This means we should return nil, as that case is
287 ;; calculated by someone else.
288 nil)))
289 nil)))
291 (defun semantic-edits-change-between-tags (change)
292 "Return a cache list of tags surrounding CHANGE.
293 The returned list is the CONS cell in the master list pointing to
294 a tag just before CHANGE. The CDR will have the tag just after CHANGE.
295 CHANGE cannot encompass or overlap a leaf tag.
296 If CHANGE is fully encompassed in a tag that has children, and
297 this change occurs between those children, this returns non-nil.
298 See `semantic-edits-change-leaf-tag' for details on parents."
299 (let* ((start (semantic-edits-os change))
300 (end (semantic-edits-oe change))
301 (tags (nreverse
302 (semantic-find-tag-by-overlay-in-region
303 start end)))
304 (list-to-search nil)
305 (found nil))
306 (if (not tags)
307 (setq list-to-search semantic--buffer-cache)
308 ;; A leaf is always first in this list
309 (if (and (< (semantic-tag-start (car tags)) start)
310 (> (semantic-tag-end (car tags)) end))
311 ;; We are completely encompassed in a tag.
312 (if (setq list-to-search
313 (semantic-tag-components (car tags)))
314 ;; Ok, we are completely encompassed within the first tag
315 ;; entry, AND that tag has children. This means that change
316 ;; occurred outside of all children, but inside some tag
317 ;; with children.
318 (if (or (not (semantic-tag-with-position-p (car list-to-search)))
319 (> start (semantic-tag-end
320 (nth (1- (length list-to-search))
321 list-to-search)))
322 (< end (semantic-tag-start (car list-to-search))))
323 ;; We have modifications to the definition of this parent
324 ;; and not between it's children. Clear the search list.
325 (setq list-to-search nil)))
326 ;; Search list is nil.
328 ;; If we have a search list, let's go. Otherwise nothing.
329 (while (and list-to-search (not found))
330 (if (cdr list-to-search)
331 ;; We end when the start of the CDR is after the end of our
332 ;; asked change.
333 (if (< (semantic-tag-start (cadr list-to-search)) end)
334 (setq list-to-search (cdr list-to-search))
335 (setq found t))
336 (setq list-to-search nil)))
337 ;; Return it. If it is nil, there is a logic bug, and we need
338 ;; to avoid this bit of logic anyway.
339 list-to-search
342 (defun semantic-edits-change-over-tags (change)
343 "Return a cache list of tags surrounding a CHANGE encompassing tags.
344 CHANGE must not only include all overlapped tags (excepting possible
345 parent tags) in their entirety. In this case, the change may be deleting
346 or moving whole tags.
347 The return value is a vector.
348 Cell 0 is a list of all tags completely encompassed in change.
349 Cell 1 is the cons cell into a master parser cache starting with
350 the cell which occurs BEFORE the first position of CHANGE.
351 Cell 2 is the parent of cell 1, or nil for the buffer cache.
352 This function returns nil if any tag covered by change is not
353 completely encompassed.
354 See `semantic-edits-change-leaf-tag' for details on parents."
355 (let* ((start (semantic-edits-os change))
356 (end (semantic-edits-oe change))
357 (tags (nreverse
358 (semantic-find-tag-by-overlay-in-region
359 start end)))
360 (parent nil)
361 (overlapped-tags nil)
362 inner-start inner-end
363 (list-to-search nil))
364 ;; By the time this is already called, we know that it is
365 ;; not a leaf change, nor a between tag change. That leaves
366 ;; an overlap, and this condition.
368 ;; A leaf is always first in this list.
369 ;; Is the leaf encompassed in this change?
370 (if (and tags
371 (>= (semantic-tag-start (car tags)) start)
372 (<= (semantic-tag-end (car tags)) end))
373 (progn
374 ;; We encompass one whole change.
375 (setq overlapped-tags (list (car tags))
376 inner-start (semantic-tag-start (car tags))
377 inner-end (semantic-tag-end (car tags))
378 tags (cdr tags))
379 ;; Keep looping while tags are inside the change.
380 (while (and tags
381 (>= (semantic-tag-start (car tags)) start)
382 (<= (semantic-tag-end (car tags)) end))
384 ;; Check if this new all-encompassing tag is a parent
385 ;; of that which went before. Only check end because
386 ;; we know that start is less than inner-start since
387 ;; tags was sorted on that.
388 (if (> (semantic-tag-end (car tags)) inner-end)
389 ;; This is a parent. Drop the children found
390 ;; so far.
391 (setq overlapped-tags (list (car tags))
392 inner-start (semantic-tag-start (car tags))
393 inner-end (semantic-tag-end (car tags))
395 ;; It is not a parent encompassing tag
396 (setq overlapped-tags (cons (car tags)
397 overlapped-tags)
398 inner-start (semantic-tag-start (car tags))))
399 (setq tags (cdr tags)))
400 (if (not tags)
401 ;; There are no tags left, and all tags originally
402 ;; found are encompassed by the change. Setup our list
403 ;; from the cache
404 (setq list-to-search semantic--buffer-cache);; We have a tag outside the list. Check for
405 ;; We know we have a parent because it would
406 ;; completely cover the change. A tag can only
407 ;; do that if it is a parent after we get here.
408 (when (and tags
409 (< (semantic-tag-start (car tags)) start)
410 (> (semantic-tag-end (car tags)) end))
411 ;; We have a parent. Stuff in the search list.
412 (setq parent (car tags)
413 list-to-search (semantic-tag-components parent))
414 ;; If the first of TAGS is a parent (see above)
415 ;; then clear out the list. All other tags in
416 ;; here must therefore be parents of the car.
417 (setq tags nil)
418 ;; One last check, If start is before the first
419 ;; tag or after the last, we may have overlap into
420 ;; the characters that make up the definition of
421 ;; the tag we are parsing.
422 (when (or (semantic-tag-with-position-p (car list-to-search))
423 (< start (semantic-tag-start
424 (car list-to-search)))
425 (> end (semantic-tag-end
426 (nth (1- (length list-to-search))
427 list-to-search))))
428 ;; We have a problem
429 (setq list-to-search nil
430 parent nil))))
432 (when list-to-search
434 ;; Ok, return the vector only if all TAGS are
435 ;; confirmed as the lineage of `overlapped-tags'
436 ;; which must have a value by now.
438 ;; Loop over the search list to find the preceding CDR.
439 ;; Fortunately, (car overlapped-tags) happens to be
440 ;; the first tag positionally.
441 (let ((tokstart (semantic-tag-start (car overlapped-tags))))
442 (while (and list-to-search
443 ;; Assume always (car (cdr list-to-search)).
444 ;; A thrown error will be captured nicely, but
445 ;; that case shouldn't happen.
447 ;; We end when the start of the CDR is after the
448 ;; end of our asked change.
449 (cdr list-to-search)
450 (< (semantic-tag-start (car (cdr list-to-search)))
451 tokstart)
452 (setq list-to-search (cdr list-to-search)))))
453 ;; Create the return vector
454 (vector overlapped-tags
455 list-to-search
456 parent)
458 nil)))
460 ;;; Default Incremental Parser
462 ;; Logic about how to group changes for effective reparsing and splicing.
464 (defun semantic-parse-changes-failed (&rest args)
465 "Signal that Semantic failed to parse changes.
466 That is, display a message by passing all ARGS to `format', then throw
467 a 'semantic-parse-changes-failed exception with value t."
468 (when semantic-edits-verbose-flag
469 (message "Semantic parse changes failed: %S"
470 (apply 'format args)))
471 (throw 'semantic-parse-changes-failed t))
473 (defsubst semantic-edits-incremental-fail ()
474 "When the incremental parser fails, we mark that we need a full reparse."
475 ;;(debug)
476 (semantic-parse-tree-set-needs-rebuild)
477 (when semantic-edits-verbose-flag
478 (message "Force full reparse (%s)"
479 (buffer-name (current-buffer))))
480 (run-hooks 'semantic-edits-incremental-reparse-failed-hook))
482 ;;;###autoload
483 (defun semantic-edits-incremental-parser ()
484 "Incrementally reparse the current buffer.
485 Incremental parser allows semantic to only reparse those sections of
486 the buffer that have changed. This function depends on
487 `semantic-edits-change-function-handle-changes' setting up change
488 overlays in the current buffer. Those overlays are analyzed against
489 the semantic cache to see what needs to be changed."
490 (let ((changed-tags
491 ;; Don't use `semantic-safe' here to explicitly catch errors
492 ;; and reset the parse tree.
493 (catch 'semantic-parse-changes-failed
494 (if debug-on-error
495 (semantic-edits-incremental-parser-1)
496 (condition-case err
497 (semantic-edits-incremental-parser-1)
498 (error
499 (message "incremental parser error: %S"
500 (error-message-string err))
501 t))))))
502 (when (eq changed-tags t)
503 ;; Force a full reparse.
504 (semantic-edits-incremental-fail)
505 (setq changed-tags nil))
506 changed-tags))
508 (defmacro semantic-edits-assert-valid-region ()
509 "Assert that parse-start and parse-end are sorted correctly."
510 ;;; (if (> parse-start parse-end)
511 ;;; (error "Bug is %s !> %d! Buff min/max = [ %d %d ]"
512 ;;; parse-start parse-end
513 ;;; (point-min) (point-max)))
516 (defun semantic-edits-incremental-parser-1 ()
517 "Incrementally reparse the current buffer.
518 Return the list of tags that changed.
519 If the incremental parse fails, throw a 'semantic-parse-changes-failed
520 exception with value t, that can be caught to schedule a full reparse.
521 This function is for internal use by `semantic-edits-incremental-parser'."
522 (let* ((changed-tags nil)
523 (debug-on-quit t) ; try to find this annoying bug!
524 (changes (semantic-changes-in-region
525 (point-min) (point-max)))
526 (tags nil) ;tags found at changes
527 (newf-tags nil) ;newfound tags in change
528 (parse-start nil) ;location to start parsing
529 (parse-end nil) ;location to end parsing
530 (parent-tag nil) ;parent of the cache list.
531 (cache-list nil) ;list of children within which
532 ;we incrementally reparse.
533 (reparse-symbol nil) ;The ruled we start at for reparse.
534 (change-group nil) ;changes grouped in this reparse
535 (last-cond nil) ;track the last case used.
536 ;query this when debugging to find
537 ;source of bugs.
539 (or changes
540 ;; If we were called, and there are no changes, then we
541 ;; don't know what to do. Force a full reparse.
542 (semantic-parse-changes-failed "Don't know what to do"))
543 ;; Else, we have some changes. Loop over them attempting to
544 ;; patch things up.
545 (while changes
546 ;; Calculate the reparse boundary.
547 ;; We want to take some set of changes, and group them
548 ;; together into a small change group. One change forces
549 ;; a reparse of a larger region (the size of some set of
550 ;; tags it encompasses.) It may contain several tags.
551 ;; That region may have other changes in it (several small
552 ;; changes in one function, for example.)
553 ;; Optimize for the simple cases here, but try to handle
554 ;; complex ones too.
556 (while (and changes ; we still have changes
557 (or (not parse-start)
558 ;; Below, if the change we are looking at
559 ;; is not the first change for this
560 ;; iteration, and it starts before the end
561 ;; of current parse region, then it is
562 ;; encompassed within the bounds of tags
563 ;; modified by the previous iteration's
564 ;; change.
565 (< (semantic-overlay-start (car changes))
566 parse-end)))
568 ;; REMOVE LATER
569 (if (eq (car changes) (car change-group))
570 (semantic-parse-changes-failed
571 "Possible infinite loop detected"))
573 ;; Store this change in this change group.
574 (setq change-group (cons (car changes) change-group))
576 (cond
577 ;; Is this is a new parse group?
578 ((not parse-start)
579 (setq last-cond "new group")
580 (let (tmp)
581 (cond
583 ;;;; Are we encompassed all in one tag?
584 ((setq tmp (semantic-edits-change-leaf-tag (car changes)))
585 (setq last-cond "Encompassed in tag")
586 (setq tags (list tmp)
587 parse-start (semantic-tag-start tmp)
588 parse-end (semantic-tag-end tmp)
590 (semantic-edits-assert-valid-region))
592 ;;;; Did the change occur between some tags?
593 ((setq cache-list (semantic-edits-change-between-tags
594 (car changes)))
595 (setq last-cond "Between and not overlapping tags")
596 ;; The CAR of cache-list is the tag just before
597 ;; our change, but wasn't modified. Hmmm.
598 ;; Bound our reparse between these two tags
599 (setq tags nil
600 parent-tag
601 (car (semantic-find-tag-by-overlay
602 parse-start)))
603 (cond
604 ;; A change at the beginning of the buffer.
605 ;; Feb 06 -
606 ;; IDed when the first cache-list tag is after
607 ;; our change, meaning there is nothing before
608 ;; the change.
609 ((> (semantic-tag-start (car cache-list))
610 (semantic-overlay-end (car changes)))
611 (setq last-cond "Beginning of buffer")
612 (setq parse-start
613 ;; Don't worry about parents since
614 ;; there there would be an exact
615 ;; match in the tag list otherwise
616 ;; and the routine would fail.
617 (point-min)
618 parse-end
619 (semantic-tag-start (car cache-list)))
620 (semantic-edits-assert-valid-region)
622 ;; A change stuck on the first surrounding tag.
623 ((= (semantic-tag-end (car cache-list))
624 (semantic-overlay-start (car changes)))
625 (setq last-cond "Beginning of Tag")
626 ;; Reparse that first tag.
627 (setq parse-start
628 (semantic-tag-start (car cache-list))
629 parse-end
630 (semantic-overlay-end (car changes))
631 tags
632 (list (car cache-list)))
633 (semantic-edits-assert-valid-region)
635 ;; A change at the end of the buffer.
636 ((not (car (cdr cache-list)))
637 (setq last-cond "End of buffer")
638 (setq parse-start (semantic-tag-end
639 (car cache-list))
640 parse-end (point-max))
641 (semantic-edits-assert-valid-region)
644 (setq last-cond "Default")
645 (setq parse-start
646 (semantic-tag-end (car cache-list))
647 parse-end
648 (semantic-tag-start (car (cdr cache-list)))
650 (semantic-edits-assert-valid-region))))
652 ;;;; Did the change completely overlap some number of tags?
653 ((setq tmp (semantic-edits-change-over-tags
654 (car changes)))
655 (setq last-cond "Overlap multiple tags")
656 ;; Extract the information
657 (setq tags (aref tmp 0)
658 cache-list (aref tmp 1)
659 parent-tag (aref tmp 2))
660 ;; We can calculate parse begin/end by checking
661 ;; out what is in TAGS. The one near start is
662 ;; always first. Make sure the reparse includes
663 ;; the `whitespace' around the snarfed tags.
664 ;; Since cache-list is positioned properly, use it
665 ;; to find that boundary.
666 (if (eq (car tags) (car cache-list))
667 ;; Beginning of the buffer!
668 (let ((end-marker (nth (length tags)
669 cache-list)))
670 (setq parse-start (point-min))
671 (if end-marker
672 (setq parse-end
673 (semantic-tag-start end-marker))
674 (setq parse-end (semantic-overlay-end
675 (car changes))))
676 (semantic-edits-assert-valid-region)
678 ;; Middle of the buffer.
679 (setq parse-start
680 (semantic-tag-end (car cache-list)))
681 ;; For the end, we need to scoot down some
682 ;; number of tags. We 1+ the length of tags
683 ;; because we want to skip the first tag
684 ;; (remove 1-) then want the tag after the end
685 ;; of the list (1+)
686 (let ((end-marker (nth (1+ (length tags)) cache-list)))
687 (if end-marker
688 (setq parse-end (semantic-tag-start end-marker))
689 ;; No marker. It is the last tag in our
690 ;; list of tags. Only possible if END
691 ;; already matches the end of that tag.
692 (setq parse-end
693 (semantic-overlay-end (car changes)))))
694 (semantic-edits-assert-valid-region)
697 ;;;; Unhandled case.
698 ;; Throw error, and force full reparse.
699 ((semantic-parse-changes-failed "Unhandled change group")))
701 ;; Is this change inside the previous parse group?
702 ;; We already checked start.
703 ((< (semantic-overlay-end (car changes)) parse-end)
704 (setq last-cond "in bounds")
705 nil)
706 ;; This change extends the current parse group.
707 ;; Find any new tags, and see how to append them.
708 ((semantic-parse-changes-failed
709 (setq last-cond "overlap boundary")
710 "Unhandled secondary change overlapping boundary"))
712 ;; Prepare for the next iteration.
713 (setq changes (cdr changes)))
715 ;; By the time we get here, all TAGS are children of
716 ;; some parent. They should all have the same start symbol
717 ;; since that is how the multi-tag parser works. Grab
718 ;; the reparse symbol from the first of the returned tags.
720 ;; Feb '06 - If reparse-symbol is nil, then they are top level
721 ;; tags. (I'm guessing.) Is this right?
722 (setq reparse-symbol
723 (semantic--tag-get-property (car (or tags cache-list))
724 'reparse-symbol))
725 ;; Find a parent if not provided.
726 (and (not parent-tag) tags
727 (setq parent-tag
728 (semantic-find-tag-parent-by-overlay
729 (car tags))))
730 ;; We can do the same trick for our parent and resulting
731 ;; cache list.
732 (unless cache-list
733 (if parent-tag
734 (setq cache-list
735 ;; We need to get all children in case we happen
736 ;; to have a mix of positioned and non-positioned
737 ;; children.
738 (semantic-tag-components parent-tag))
739 ;; Else, all the tags since there is no parent.
740 ;; It sucks to have to use the full buffer cache in
741 ;; this case because it can be big. Failure to provide
742 ;; however results in a crash.
743 (setq cache-list semantic--buffer-cache)
745 ;; Use the boundary to calculate the new tags found.
746 (setq newf-tags (semantic-parse-region
747 parse-start parse-end reparse-symbol))
748 ;; Make sure all these tags are given overlays.
749 ;; They have already been cooked by the parser and just
750 ;; need the overlays.
751 (let ((tmp newf-tags))
752 (while tmp
753 (semantic--tag-link-to-buffer (car tmp))
754 (setq tmp (cdr tmp))))
756 ;; See how this change lays out.
757 (cond
759 ;;;; Whitespace change
760 ((and (not tags) (not newf-tags))
761 ;; A change that occurred outside of any existing tags
762 ;; and there are no new tags to replace it.
763 (when semantic-edits-verbose-flag
764 (message "White space changes"))
768 ;;;; New tags in old whitespace area.
769 ((and (not tags) newf-tags)
770 ;; A change occurred outside existing tags which added
771 ;; a new tag. We need to splice these tags back
772 ;; into the cache at the right place.
773 (semantic-edits-splice-insert newf-tags parent-tag cache-list)
775 (setq changed-tags
776 (append newf-tags changed-tags))
778 (when semantic-edits-verbose-flag
779 (message "Inserted tags: (%s)"
780 (semantic-format-tag-name (car newf-tags))))
783 ;;;; Old tags removed
784 ((and tags (not newf-tags))
785 ;; A change occurred where pre-existing tags were
786 ;; deleted! Remove the tag from the cache.
787 (semantic-edits-splice-remove tags parent-tag cache-list)
789 (setq changed-tags
790 (append tags changed-tags))
792 (when semantic-edits-verbose-flag
793 (message "Deleted tags: (%s)"
794 (semantic-format-tag-name (car tags))))
797 ;;;; One tag was updated.
798 ((and (= (length tags) 1) (= (length newf-tags) 1))
799 ;; One old tag was modified, and it is replaced by
800 ;; One newfound tag. Splice the new tag into the
801 ;; position of the old tag.
802 ;; Do the splice.
803 (semantic-edits-splice-replace (car tags) (car newf-tags))
804 ;; Add this tag to our list of changed toksns
805 (setq changed-tags (cons (car tags) changed-tags))
806 ;; Debug
807 (when semantic-edits-verbose-flag
808 (message "Update Tag Table: %s"
809 (semantic-format-tag-name (car tags) nil t)))
810 ;; Flush change regardless of above if statement.
813 ;;;; Some unhandled case.
814 ((semantic-parse-changes-failed "Don't know what to do")))
816 ;; We got this far, and we didn't flag a full reparse.
817 ;; Clear out this change group.
818 (while change-group
819 (semantic-edits-flush-change (car change-group))
820 (setq change-group (cdr change-group)))
822 ;; Don't increment change here because an earlier loop
823 ;; created change-groups.
824 (setq parse-start nil)
826 ;; Mark that we are done with this glop
827 (semantic-parse-tree-set-up-to-date)
828 ;; Return the list of tags that changed. The caller will
829 ;; use this information to call hooks which can fix themselves.
830 changed-tags))
832 ;; Make it the default changes parser
833 ;;;###autoload
834 (defalias 'semantic-parse-changes-default
835 'semantic-edits-incremental-parser)
837 ;;; Cache Splicing
839 ;; The incremental parser depends on the ability to parse up sections
840 ;; of the file, and splice the results back into the cache. There are
841 ;; three types of splices. A REPLACE, an ADD, and a REMOVE. REPLACE
842 ;; is one of the simpler cases, as the starting cons cell representing
843 ;; the old tag can be used to auto-splice in. ADD and REMOVE
844 ;; require scanning the cache to find the correct location so that the
845 ;; list can be fiddled.
846 (defun semantic-edits-splice-remove (oldtags parent cachelist)
847 "Remove OLDTAGS from PARENT's CACHELIST.
848 OLDTAGS are tags in the current buffer, preferably linked
849 together also in CACHELIST.
850 PARENT is the parent tag containing OLDTAGS.
851 CACHELIST should be the children from PARENT, but may be
852 pre-positioned to a convenient location."
853 (let* ((first (car oldtags))
854 (last (nth (1- (length oldtags)) oldtags))
855 (chil (if parent
856 (semantic-tag-components parent)
857 semantic--buffer-cache))
858 (cachestart cachelist)
859 (cacheend nil)
861 ;; First in child list?
862 (if (eq first (car chil))
863 ;; First tags in the cache are being deleted.
864 (progn
865 (when semantic-edits-verbose-flag
866 (message "To Remove First Tag: (%s)"
867 (semantic-format-tag-name first)))
868 ;; Find the last tag
869 (setq cacheend chil)
870 (while (and cacheend (not (eq last (car cacheend))))
871 (setq cacheend (cdr cacheend)))
872 ;; The spliceable part is after cacheend.. so move cacheend
873 ;; one more tag.
874 (setq cacheend (cdr cacheend))
875 ;; Splice the found end tag into the cons cell
876 ;; owned by the current top child.
877 (setcar chil (car cacheend))
878 (setcdr chil (cdr cacheend))
879 (when (not cacheend)
880 ;; No cacheend.. then the whole system is empty.
881 ;; The best way to deal with that is to do a full
882 ;; reparse
883 (semantic-parse-changes-failed "Splice-remove failed. Empty buffer?")
885 (when semantic-edits-verbose-flag
886 (message "To Remove Middle Tag: (%s)"
887 (semantic-format-tag-name first))))
888 ;; Find in the cache the preceding tag
889 (while (and cachestart (not (eq first (car (cdr cachestart)))))
890 (setq cachestart (cdr cachestart)))
891 ;; Find the last tag
892 (setq cacheend cachestart)
893 (while (and cacheend (not (eq last (car cacheend))))
894 (setq cacheend (cdr cacheend)))
895 ;; Splice the end position into the start position.
896 ;; If there is no start, then this whole section is probably
897 ;; gone.
898 (if cachestart
899 (setcdr cachestart (cdr cacheend))
900 (semantic-parse-changes-failed "Splice-remove failed."))
902 ;; Remove old overlays of these deleted tags
903 (while oldtags
904 (semantic--tag-unlink-from-buffer (car oldtags))
905 (setq oldtags (cdr oldtags)))
908 (defun semantic-edits-splice-insert (newtags parent cachelist)
909 "Insert NEWTAGS into PARENT using CACHELIST.
910 PARENT could be nil, in which case CACHLIST is the buffer cache
911 which must be updated.
912 CACHELIST must be searched to find where NEWTAGS are to be inserted.
913 The positions of NEWTAGS must be synchronized with those in
914 CACHELIST for this to work. Some routines pre-position CACHLIST at a
915 convenient location, so use that."
916 (let* ((start (semantic-tag-start (car newtags)))
917 (newtagendcell (nthcdr (1- (length newtags)) newtags))
918 (end (semantic-tag-end (car newtagendcell)))
920 (if (> (semantic-tag-start (car cachelist)) start)
921 ;; We are at the beginning.
922 (let* ((pc (if parent
923 (semantic-tag-components parent)
924 semantic--buffer-cache))
925 (nc (cons (car pc) (cdr pc))) ; new cons cell.
927 ;; Splice the new cache cons cell onto the end of our list.
928 (setcdr newtagendcell nc)
929 ;; Set our list into parent.
930 (setcar pc (car newtags))
931 (setcdr pc (cdr newtags)))
932 ;; We are at the end, or in the middle. Find our match first.
933 (while (and (cdr cachelist)
934 (> end (semantic-tag-start (car (cdr cachelist)))))
935 (setq cachelist (cdr cachelist)))
936 ;; Now splice into the list!
937 (setcdr newtagendcell (cdr cachelist))
938 (setcdr cachelist newtags))))
940 (defun semantic-edits-splice-replace (oldtag newtag)
941 "Replace OLDTAG with NEWTAG in the current cache.
942 Do this by recycling OLDTAG's first CONS cell. This effectively
943 causes the new tag to completely replace the old one.
944 Make sure that all information in the overlay is transferred.
945 It is presumed that OLDTAG and NEWTAG are both cooked.
946 When this routine returns, OLDTAG is raw, and the data will be
947 lost if not transferred into NEWTAG."
948 (let* ((oo (semantic-tag-overlay oldtag))
949 (o (semantic-tag-overlay newtag))
950 (oo-props (semantic-overlay-properties oo)))
951 (while oo-props
952 (semantic-overlay-put o (car oo-props) (car (cdr oo-props)))
953 (setq oo-props (cdr (cdr oo-props)))
955 ;; Free the old overlay(s)
956 (semantic--tag-unlink-from-buffer oldtag)
957 ;; Recover properties
958 (semantic--tag-copy-properties oldtag newtag)
959 ;; Splice into the main list.
960 (setcdr oldtag (cdr newtag))
961 (setcar oldtag (car newtag))
962 ;; This important bit is because the CONS cell representing
963 ;; OLDTAG is now pointing to NEWTAG, but the NEWTAG
964 ;; cell is about to be abandoned. Here we update our overlay
965 ;; to point at the updated state of the world.
966 (semantic-overlay-put o 'semantic oldtag)
969 (add-hook 'semantic-before-toplevel-cache-flush-hook
970 #'semantic-edits-flush-changes)
972 (provide 'semantic/edit)
974 ;; Local variables:
975 ;; generated-autoload-file: "loaddefs.el"
976 ;; generated-autoload-load-name: "semantic/edit"
977 ;; End:
979 ;;; semantic/edit.el ends here