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