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