code.delx.au - gnu-emacs/blob - lisp/cedet/semantic/db-typecache.el

   1 ;;; db-typecache.el --- Manage Datatypes
   2
   3 ;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
   4
   5 ;; Author: Eric M. Ludlam <eric@siege-engine.com>
   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 <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23 ;;
  24 ;; Manage a datatype cache.
  25 ;;
  26 ;; For typed languages like C++ collect all known types from various
  27 ;; headers, merge namespaces, and expunge duplicates.
  28 ;;
  29 ;; It is likely this feature will only be needed for C/C++.
  30
  31 (require 'semantic)
  32 (require 'semantic/db)
  33 (require 'semantic/db-find)
  34 (require 'semantic/analyze/fcn)
  35
  36 ;; For semantic-find-tags-by-* macros
  37 (eval-when-compile (require 'semantic/find))
  38
  39 (declare-function data-debug-insert-thing "data-debug")
  40 (declare-function data-debug-new-buffer "data-debug")
  41 (declare-function semantic-sort-tags-by-name-then-type-increasing "semantic/sort")
  42 (declare-function semantic-scope-tag-clone-with-scope "semantic/scope")
  43
  44 ;;; Code:
  45
  46 \f
  47 ;;; TABLE TYPECACHE
  48 (defclass semanticdb-typecache ()
  49   ((filestream :initform nil
  50                :documentation
  51                "Fully sorted/merged list of tags within this buffer.")
  52    (includestream :initform nil
  53                   :documentation
  54                   "Fully sorted/merged list of tags from this file's includes list.")
  55    (stream :initform nil
  56            :documentation
  57            "The searchable tag stream for this cache.
  58 NOTE: Can I get rid of this?  Use a hashtable instead?")
  59    (dependants :initform nil
  60                :documentation
  61                "Any other object that is dependent on typecache results.
  62 Said object must support `semantic-reset' methods.")
  63    ;; @todo - add some sort of fast-hash.
  64    ;; @note - Rebuilds in large projects already take a while, and the
  65    ;;     actual searches are pretty fast.  Really needed?
  66    )
  67   "Structure for maintaining a typecache.")
  68
  69 (defmethod semantic-reset ((tc semanticdb-typecache))
  70   "Reset the object IDX."
  71   (oset tc filestream nil)
  72   (oset tc includestream nil)
  73
  74   (oset tc stream nil)
  75
  76   (mapc 'semantic-reset (oref tc dependants))
  77   (oset tc dependants nil)
  78   )
  79
  80 (defmethod semanticdb-typecache-notify-reset ((tc semanticdb-typecache))
  81   "Do a reset from a notify from a table we depend on."
  82   (oset tc includestream nil)
  83   (mapc 'semantic-reset (oref tc dependants))
  84   (oset tc dependants nil)
  85   )
  86
  87 (defmethod semanticdb-partial-synchronize ((tc semanticdb-typecache)
  88                                            new-tags)
  89   "Reset the typecache based on a partial reparse."
  90   (when (semantic-find-tags-by-class 'include new-tags)
  91     (oset tc includestream nil)
  92     (mapc 'semantic-reset (oref tc dependants))
  93     (oset tc dependants nil)
  94     )
  95
  96   (when (semantic-find-tags-by-class 'type new-tags)
  97     ;; Reset our index
  98     (oset tc filestream nil)
  99     t ;; Return true, our core file tags have changed in a relavant way.
 100     )
 101
 102   ;; NO CODE HERE
 103   )
 104
 105 (defun semanticdb-typecache-add-dependant (dep)
 106   "Add into the local typecache a dependant DEP."
 107   (let* ((table semanticdb-current-table)
 108          ;;(idx (semanticdb-get-table-index table))
 109          (cache (semanticdb-get-typecache table))
 110          )
 111     (object-add-to-list cache 'dependants dep)))
 112
 113 (defun semanticdb-typecache-length(thing)
 114   "How long is THING?
 115 Debugging function."
 116   (cond ((semanticdb-typecache-child-p thing)
 117          (length (oref thing stream)))
 118         ((semantic-tag-p thing)
 119          (length (semantic-tag-type-members thing)))
 120         ((and (listp thing) (semantic-tag-p (car thing)))
 121          (length thing))
 122         ((null thing)
 123          0)
 124         (t -1)  ))
 125
 126
 127 (defmethod semanticdb-get-typecache ((table semanticdb-abstract-table))
 128   "Retrieve the typecache from the semanticdb TABLE.
 129 If there is no table, create one, and fill it in."
 130   (semanticdb-refresh-table table)
 131   (let* ((idx (semanticdb-get-table-index table))
 132          (cache (oref idx type-cache))
 133          )
 134
 135     ;; Make sure we have a cache object in the DB index.
 136     (when (not cache)
 137       ;; The object won't change as we fill it with stuff.
 138       (setq cache (semanticdb-typecache (semanticdb-full-filename table)))
 139       (oset idx type-cache cache))
 140
 141     cache))
 142
 143 (defmethod semanticdb-have-typecache-p ((table semanticdb-abstract-table))
 144   "Return non-nil (the typecache) if TABLE has a pre-calculated typecache."
 145   (let* ((idx (semanticdb-get-table-index table)))
 146     (oref idx type-cache)))
 147
 148 \f
 149 ;;; DATABASE TYPECACHE
 150 ;;
 151 ;; A full database can cache the types across its files.
 152 ;;
 153 ;; Unlike file based caches, this one is a bit simpler, and just needs
 154 ;; to get reset when a table gets updated.
 155
 156 (defclass semanticdb-database-typecache (semanticdb-abstract-db-cache)
 157   ((stream :initform nil
 158            :documentation
 159            "The searchable tag stream for this cache.")
 160    )
 161   "Structure for maintaining a typecache.")
 162
 163 (defmethod semantic-reset ((tc semanticdb-database-typecache))
 164   "Reset the object IDX."
 165   (oset tc stream nil)
 166   )
 167
 168 (defmethod semanticdb-synchronize ((cache semanticdb-database-typecache)
 169                                    new-tags)
 170   "Synchronize a CACHE with some NEW-TAGS."
 171   )
 172
 173 (defmethod semanticdb-partial-synchronize ((cache semanticdb-database-typecache)
 174                                            new-tags)
 175   "Synchronize a CACHE with some changed NEW-TAGS."
 176   )
 177
 178 (defmethod semanticdb-get-typecache ((db semanticdb-project-database))
 179   "Retrieve the typecache from the semantic database DB.
 180 If there is no table, create one, and fill it in."
 181   (semanticdb-cache-get db semanticdb-database-typecache)
 182   )
 183
 184 \f
 185 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 186
 187 ;;; MERGING
 188 ;;
 189 ;; Managing long streams of tags representing data types.
 190 ;;
 191 (defun semanticdb-typecache-apply-filename (file stream)
 192   "Apply the filename FILE to all tags in STREAM."
 193   (let ((new nil))
 194     (while stream
 195       (setq new (cons (semantic-tag-copy (car stream) nil file)
 196                       new))
 197       ;The below is handled by the tag-copy fcn.
 198       ;(semantic--tag-put-property (car new) :filename file)
 199       (setq stream (cdr stream)))
 200     (nreverse new)))
 201
 202
 203 (defsubst semanticdb-typecache-safe-tag-members (tag)
 204   "Return a list of members for TAG that are safe to permute."
 205   (let ((mem (semantic-tag-type-members tag))
 206         (fname (semantic-tag-file-name tag)))
 207     (if fname
 208         (setq mem (semanticdb-typecache-apply-filename fname mem))
 209       (copy-sequence mem))))
 210
 211 (defsubst semanticdb-typecache-safe-tag-list (tags table)
 212   "Make the tag list TAGS found in TABLE safe for the typecache.
 213 Adds a filename and copies the tags."
 214   (semanticdb-typecache-apply-filename
 215    (semanticdb-full-filename table)
 216    tags))
 217
 218 (defun semanticdb-typecache-merge-streams (cache1 cache2)
 219   "Merge into CACHE1 and CACHE2 together.  The Caches will be merged in place."
 220   (if (or (and (not cache1) (not cache2))
 221           (and (not (cdr cache1)) (not cache2))
 222           (and (not cache1) (not (cdr cache2))))
 223       ;; If all caches are empty OR
 224       ;; cache1 is length 1 and no cache2 OR
 225       ;; no cache1 and length 1 cache2
 226       ;;
 227       ;; then just return the cache, and skip all this merging stuff.
 228       (or cache1 cache2)
 229
 230     ;; Assume we always have datatypes, as this typecache isn't really
 231     ;; useful without a typed language.
 232     (require 'semantic/sort)
 233     (let ((S (semantic-sort-tags-by-name-then-type-increasing
 234               ;; I used to use append, but it copied cache1 but not cache2.
 235               ;; Since sort was permuting cache2, I already had to make sure
 236               ;; the caches were permute-safe.  Might as well use nconc here.
 237               (nconc cache1 cache2)))
 238           (ans nil)
 239           (next nil)
 240           (prev nil)
 241           (type nil))
 242       ;; With all the tags in order, we can loop over them, and when
 243       ;; two have the same name, we can either throw one away, or construct
 244       ;; a fresh new tag merging the items together.
 245       (while S
 246         (setq prev (car ans))
 247         (setq next (car S))
 248         (if (or
 249              ;; CASE 1 - First item
 250              (null prev)
 251              ;; CASE 2 - New name
 252              (not (string= (semantic-tag-name next)
 253                            (semantic-tag-name prev))))
 254             (setq ans (cons next ans))
 255           ;; ELSE - We have a NAME match.
 256           (setq type (semantic-tag-type next))
 257           (if (semantic-tag-of-type-p prev type) ; Are they the same datatype
 258               ;; Same Class, we can do a merge.
 259               (cond
 260                ((and (semantic-tag-of-class-p next 'type)
 261                      (string= type "namespace"))
 262                 ;; Namespaces - merge the children together.
 263                 (setcar ans
 264                         (semantic-tag-new-type
 265                          (semantic-tag-name prev) ; - they are the same
 266                          "namespace"    ; - we know this as fact
 267                          (semanticdb-typecache-merge-streams
 268                           (semanticdb-typecache-safe-tag-members prev)
 269                           (semanticdb-typecache-safe-tag-members next))
 270                          nil            ; - no attributes
 271                          ))
 272                 ;; Make sure we mark this as a fake tag.
 273                 (semantic-tag-set-faux (car ans))
 274                 )
 275                ((semantic-tag-prototype-p next)
 276                 ;; NEXT is a prototype... so keep previous.
 277                 nil                     ; - keep prev, do nothing
 278                 )
 279                ((semantic-tag-prototype-p prev)
 280                 ;; PREV is a prototype, but not next.. so keep NEXT.
 281                 ;; setcar - set by side-effect on top of prev
 282                 (setcar ans next)
 283                 )
 284                (t
 285                 ;;(message "Don't know how to merge %s.  Keeping first entry." (semantic-tag-name next))
 286                 ))
 287             ;; Not same class... but same name
 288                                         ;(message "Same name, different type: %s, %s!=%s"
 289                                         ;          (semantic-tag-name next)
 290                                         ;          (semantic-tag-type next)
 291                                         ;        (semantic-tag-type prev))
 292             (setq ans (cons next ans))
 293             ))
 294         (setq S (cdr S)))
 295       (nreverse ans))))
 296 \f
 297 ;;; Refresh / Query API
 298 ;;
 299 ;; Queries that can be made for the typecache.
 300 (defmethod semanticdb-typecache-file-tags ((table semanticdb-abstract-table))
 301   "No tags available from non-file based tables."
 302   nil)
 303
 304 (defmethod semanticdb-typecache-file-tags ((table semanticdb-table))
 305   "Update the typecache for TABLE, and return the file-tags.
 306 File-tags are those that belong to this file only, and excludes
 307 all included files."
 308   (let* (;(idx (semanticdb-get-table-index table))
 309          (cache (semanticdb-get-typecache table))
 310          )
 311
 312     ;; Make sure our file-tags list is up to date.
 313     (when (not (oref cache filestream))
 314       (let ((tags  (semantic-find-tags-by-class 'type table)))
 315         (when tags
 316           (setq tags (semanticdb-typecache-safe-tag-list tags table))
 317           (oset cache filestream (semanticdb-typecache-merge-streams tags nil)))))
 318
 319     ;; Return our cache.
 320     (oref cache filestream)
 321     ))
 322
 323 (defmethod semanticdb-typecache-include-tags ((table semanticdb-abstract-table))
 324   "No tags available from non-file based tables."
 325   nil)
 326
 327 (defmethod semanticdb-typecache-include-tags ((table semanticdb-table))
 328   "Update the typecache for TABLE, and return the merged types from the include tags.
 329 Include-tags are the tags brought in via includes, all merged together into
 330 a master list."
 331   (let* ((cache (semanticdb-get-typecache table))
 332          )
 333
 334     ;; Make sure our file-tags list is up to date.
 335     (when (not (oref cache includestream))
 336       (let (;; Calc the path first.  This will have a nice side -effect of
 337             ;; getting the cache refreshed if a refresh is needed.  Most of the
 338             ;; time this value is itself cached, so the query is fast.
 339             (incpath (semanticdb-find-translate-path table nil))
 340             (incstream nil))
 341         ;; Get the translated path, and extract all the type tags, then merge
 342         ;; them all together.
 343         (dolist (i incpath)
 344           ;; don't include ourselves in this crazy list.
 345           (when (and i (not (eq i table))
 346                      ;; @todo - This eieio fcn can be slow!  Do I need it?
 347                      ;; (semanticdb-table-child-p i)
 348                      )
 349             (setq incstream
 350                   (semanticdb-typecache-merge-streams
 351                    incstream
 352                    ;; Getting the cache from this table will also cause this
 353                    ;; file to update it's cache from it's decendants.
 354                    ;;
 355                    ;; In theory, caches are only built for most includes
 356                    ;; only once (in the loop before this one), so this ends
 357                    ;; up being super fast as we edit our file.
 358                    (copy-sequence
 359                     (semanticdb-typecache-file-tags i))))
 360             ))
 361
 362         ;; Save...
 363         (oset cache includestream incstream)))
 364
 365     ;; Return our cache.
 366     (oref cache includestream)
 367     ))
 368
 369 \f
 370 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 371
 372 ;;; Search Routines
 373 ;;;###autoload
 374 (define-overloadable-function semanticdb-typecache-find (type &optional path find-file-match)
 375   "Search the typecache for TYPE in PATH.
 376 If type is a string, split the string, and search for the parts.
 377 If type is a list, treat the type as a pre-split string.
 378 PATH can be nil for the current buffer, or a semanticdb table.
 379 FIND-FILE-MATCH is non-nil to force all found tags to be loaded into a buffer.")
 380
 381 (defun semanticdb-typecache-find-default (type &optional path find-file-match)
 382   "Default implementation of `semanticdb-typecache-find'.
 383 TYPE is the datatype to find.
 384 PATH is the search path.. which should be one table object.
 385 If FIND-FILE-MATCH is non-nil, then force the file belonging to the
 386 found tag to be loaded."
 387   (semanticdb-typecache-find-method (or path semanticdb-current-table)
 388                                     type find-file-match))
 389
 390 (defun semanticdb-typecache-find-by-name-helper (name table)
 391   "Find the tag with NAME in TABLE, which is from a typecache.
 392 If more than one tag has NAME in TABLE, we will prefer the tag that
 393 is of class 'type."
 394   (let* ((names (semantic-find-tags-by-name name table))
 395          (types (semantic-find-tags-by-class 'type names)))
 396     (or (car-safe types) (car-safe names))))
 397
 398 (defmethod semanticdb-typecache-find-method ((table semanticdb-abstract-table)
 399                                              type find-file-match)
 400   "Search the typecache in TABLE for the datatype TYPE.
 401 If type is a string, split the string, and search for the parts.
 402 If type is a list, treat the type as a pre-split string.
 403 If FIND-FILE-MATCH is non-nil, then force the file belonging to the
 404 found tag to be loaded."
 405   ;; convert string to a list.
 406   (when (stringp type) (setq type (semantic-analyze-split-name type)))
 407   (when (stringp type) (setq type (list type)))
 408
 409   ;; Search for the list in our typecache.
 410   (let* ((file (semanticdb-typecache-file-tags table))
 411          (inc (semanticdb-typecache-include-tags table))
 412          (stream nil)
 413          (f-ans nil)
 414          (i-ans nil)
 415          (ans nil)
 416          (notdone t)
 417          (lastfile nil)
 418          (thisfile nil)
 419          (lastans nil)
 420          (calculated-scope nil)
 421          )
 422     ;; 1) Find first symbol in the two master lists and then merge
 423     ;;    the found streams.
 424
 425     ;; We stripped duplicates, so these will be super-fast!
 426     (setq f-ans (semantic-find-first-tag-by-name (car type) file))
 427     (setq i-ans (semantic-find-first-tag-by-name (car type) inc))
 428     (if (and f-ans i-ans)
 429         (progn
 430           ;; This trick merges the two identified tags, making sure our lists are
 431           ;; complete.  The second find then gets the new 'master' from the list of 2.
 432           (setq ans (semanticdb-typecache-merge-streams (list f-ans) (list i-ans)))
 433           (setq ans (semantic-find-first-tag-by-name (car type) ans))
 434           )
 435
 436       ;; The answers are already sorted and merged, so if one misses,
 437       ;; no need to do any special work.
 438       (setq ans (or f-ans i-ans)))
 439
 440     ;; 2) Loop over the remaining parts.
 441     (while (and type notdone)
 442
 443       ;; For pass > 1, stream will be non-nil, so do a search, otherwise
 444       ;; ans is from outside the loop.
 445       (when stream
 446         (setq ans (semanticdb-typecache-find-by-name-helper (car type) stream))
 447
 448         ;; NOTE: The below test to make sure we get a type is only relevant
 449         ;;       for the SECOND pass or later.  The first pass can only ever
 450         ;;       find a type/namespace because everything else is excluded.
 451
 452         ;; If this is not the last entry from the list, then it
 453         ;; must be a type or a namespace.  Lets double check.
 454         (when (cdr type)
 455
 456           ;; From above, there is only one tag in ans, and we prefer
 457           ;; types.
 458           (when (not (semantic-tag-of-class-p ans 'type))
 459
 460             (setq ans nil)))
 461         )
 462
 463       (push ans calculated-scope)
 464
 465       ;; Track most recent file.
 466       (setq thisfile (semantic-tag-file-name ans))
 467       (when (and thisfile (stringp thisfile))
 468         (setq lastfile thisfile))
 469
 470       ;; If we have a miss, exit, otherwise, update the stream to
 471       ;; the next set of members.
 472       (if (not ans)
 473           (setq notdone nil)
 474         (setq stream (semantic-tag-type-members ans)))
 475
 476       (setq lastans ans
 477             ans nil
 478             type (cdr type)))
 479
 480     (if (or type (not notdone))
 481         ;; If there is stuff left over, then we failed.  Just return
 482         ;; nothing.
 483         nil
 484
 485       ;; We finished, so return everything.
 486
 487       (if (and find-file-match lastfile)
 488           ;; This won't liven up the tag since we have a copy, but
 489           ;; we ought to be able to get there and go to the right line.
 490           (find-file-noselect lastfile)
 491         ;; We don't want to find-file match, so instead lets
 492         ;; push the filename onto the return tag.
 493         (when lastans
 494           (setq lastans (semantic-tag-copy lastans nil lastfile))
 495           ;; We used to do the below, but we would erroneously be putting
 496           ;; attributes on tags being shred with other lists.
 497           ;;(semantic--tag-put-property lastans :filename lastfile)
 498           )
 499         )
 500
 501       (if (and lastans calculated-scope)
 502
 503           ;; Put our discovered scope into the tag if we have a tag
 504           (progn
 505             (require 'semantic/scope)
 506             (semantic-scope-tag-clone-with-scope
 507              lastans (reverse (cdr calculated-scope))))
 508
 509         ;; Else, just return
 510         lastans
 511         ))))
 512 \f
 513 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 514
 515 ;;; BRUTISH Typecache
 516 ;;
 517 ;; Routines for a typecache that crosses all tables in a given database
 518 ;; for a matching major-mode.
 519 (defmethod semanticdb-typecache-for-database ((db semanticdb-project-database)
 520                                               &optional mode)
 521   "Return the typecache for the project database DB.
 522 If there isn't one, create it.
 523 "
 524   (let ((lmode (or mode major-mode))
 525         (cache (semanticdb-get-typecache db))
 526         (stream nil)
 527         )
 528     (dolist (table (semanticdb-get-database-tables db))
 529       (when (eq lmode (oref table :major-mode))
 530         (setq stream
 531               (semanticdb-typecache-merge-streams
 532                stream
 533                (copy-sequence
 534                 (semanticdb-typecache-file-tags table))))
 535         ))
 536     (oset cache stream stream)
 537     cache))
 538
 539 (defun semanticdb-typecache-refresh-for-buffer (buffer)
 540   "Refresh the typecache for BUFFER."
 541   (save-excursion
 542     (set-buffer buffer)
 543     (let* ((tab semanticdb-current-table)
 544            ;(idx (semanticdb-get-table-index tab))
 545            (tc (semanticdb-get-typecache tab)))
 546       (semanticdb-typecache-file-tags tab)
 547       (semanticdb-typecache-include-tags tab)
 548       tc)))
 549
 550 \f
 551 ;;; DEBUG
 552 ;;
 553 (defun semanticdb-typecache-complete-flush ()
 554   "Flush all typecaches referenced by the current buffer."
 555   (interactive)
 556   (let* ((path (semanticdb-find-translate-path nil nil)))
 557     (dolist (P path)
 558       (oset P pointmax nil)
 559       (semantic-reset (semanticdb-get-typecache P)))))
 560
 561 (defun semanticdb-typecache-dump ()
 562   "Dump the typecache for the current buffer."
 563   (interactive)
 564   (require 'data-debug)
 565   (let* ((start (current-time))
 566          (tc (semanticdb-typecache-refresh-for-buffer (current-buffer)))
 567          (end (current-time))
 568          )
 569     (data-debug-new-buffer "*TypeCache ADEBUG*")
 570     (message "Calculating Cache took %.2f seconds."
 571              (semantic-elapsed-time start end))
 572
 573     (data-debug-insert-thing tc "]" "")
 574
 575     ))
 576
 577 (defun semanticdb-db-typecache-dump ()
 578   "Dump the typecache for the current buffer's database."
 579   (interactive)
 580   (require 'data-debug)
 581   (let* ((tab semanticdb-current-table)
 582          (idx (semanticdb-get-table-index tab))
 583          (junk (oset idx type-cache nil)) ;; flush!
 584          (start (current-time))
 585          (tc (semanticdb-typecache-for-database (oref tab parent-db)))
 586          (end (current-time))
 587          )
 588     (data-debug-new-buffer "*TypeCache ADEBUG*")
 589     (message "Calculating Cache took %.2f seconds."
 590              (semantic-elapsed-time start end))
 591
 592     (data-debug-insert-thing tc "]" "")
 593
 594     ))
 595
 596 (provide 'semantic/db-typecache)
 597
 598 ;; Local variables:
 599 ;; generated-autoload-file: "loaddefs.el"
 600 ;; generated-autoload-feature: semantic/loaddefs
 601 ;; generated-autoload-load-name: "semantic/db-typecache"
 602 ;; End:
 603
 604 ;;; semanticdb-typecache.el ends here