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