123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626 |
- (require 'semantic)
- (require 'semantic/db)
- (require 'semantic/db-find)
- (require 'semantic/analyze/fcn)
- (eval-when-compile (require 'semantic/find))
- (declare-function data-debug-insert-thing "data-debug")
- (declare-function data-debug-new-buffer "data-debug")
- (declare-function semantic-sort-tags-by-name-then-type-increasing "semantic/sort")
- (declare-function semantic-scope-tag-clone-with-scope "semantic/scope")
- (defclass semanticdb-typecache ()
- ((filestream :initform nil
- :documentation
- "Fully sorted/merged list of tags within this buffer.")
- (includestream :initform nil
- :documentation
- "Fully sorted/merged list of tags from this file's includes list.")
- (stream :initform nil
- :documentation
- "The searchable tag stream for this cache.
- NOTE: Can I get rid of this? Use a hashtable instead?")
- (dependants :initform nil
- :documentation
- "Any other object that is dependent on typecache results.
- Said object must support `semantic-reset' methods.")
-
-
-
- )
- "Structure for maintaining a typecache.")
- (defmethod semantic-reset ((tc semanticdb-typecache))
- "Reset the object IDX."
- (oset tc filestream nil)
- (oset tc includestream nil)
- (oset tc stream nil)
- (mapc 'semantic-reset (oref tc dependants))
- (oset tc dependants nil)
- )
- (defmethod semanticdb-typecache-notify-reset ((tc semanticdb-typecache))
- "Do a reset from a notify from a table we depend on."
- (oset tc includestream nil)
- (mapc 'semantic-reset (oref tc dependants))
- (oset tc dependants nil)
- )
- (defmethod semanticdb-partial-synchronize ((tc semanticdb-typecache)
- new-tags)
- "Reset the typecache based on a partial reparse."
- (when (semantic-find-tags-by-class 'include new-tags)
- (oset tc includestream nil)
- (mapc 'semantic-reset (oref tc dependants))
- (oset tc dependants nil)
- )
- (when (semantic-find-tags-by-class 'type new-tags)
-
- (oset tc filestream nil)
- t
- )
-
- )
- (defun semanticdb-typecache-add-dependant (dep)
- "Add into the local typecache a dependant DEP."
- (let* ((table semanticdb-current-table)
-
- (cache (semanticdb-get-typecache table))
- )
- (object-add-to-list cache 'dependants dep)))
- (defun semanticdb-typecache-length (thing)
- "How long is THING?
- Debugging function."
- (cond ((semanticdb-typecache-child-p thing)
- (length (oref thing stream)))
- ((semantic-tag-p thing)
- (length (semantic-tag-type-members thing)))
- ((and (listp thing) (semantic-tag-p (car thing)))
- (length thing))
- ((null thing)
- 0)
- (t -1) ))
- (defmethod semanticdb-get-typecache ((table semanticdb-abstract-table))
- "Retrieve the typecache from the semanticdb TABLE.
- If there is no table, create one, and fill it in."
- (semanticdb-refresh-table table)
- (let* ((idx (semanticdb-get-table-index table))
- (cache (oref idx type-cache))
- )
-
- (when (not cache)
-
- (setq cache (semanticdb-typecache (semanticdb-full-filename table)))
- (oset idx type-cache cache))
- cache))
- (defmethod semanticdb-have-typecache-p ((table semanticdb-abstract-table))
- "Return non-nil (the typecache) if TABLE has a pre-calculated typecache."
- (let* ((idx (semanticdb-get-table-index table)))
- (oref idx type-cache)))
- (defclass semanticdb-database-typecache (semanticdb-abstract-db-cache)
- ((stream :initform nil
- :documentation
- "The searchable tag stream for this cache.")
- )
- "Structure for maintaining a typecache.")
- (defmethod semantic-reset ((tc semanticdb-database-typecache))
- "Reset the object IDX."
- (oset tc stream nil)
- )
- (defmethod semanticdb-synchronize ((cache semanticdb-database-typecache)
- new-tags)
- "Synchronize a CACHE with some NEW-TAGS."
- )
- (defmethod semanticdb-partial-synchronize ((cache semanticdb-database-typecache)
- new-tags)
- "Synchronize a CACHE with some changed NEW-TAGS."
- )
- (defmethod semanticdb-get-typecache ((db semanticdb-project-database))
- "Retrieve the typecache from the semantic database DB.
- If there is no table, create one, and fill it in."
- (semanticdb-cache-get db semanticdb-database-typecache)
- )
- (defun semanticdb-typecache-apply-filename (file stream)
- "Apply the filename FILE to all tags in STREAM."
- (let ((new nil))
- (while stream
- (setq new (cons (semantic-tag-copy (car stream) nil file)
- new))
-
-
- (setq stream (cdr stream)))
- (nreverse new)))
- (defsubst semanticdb-typecache-safe-tag-members (tag)
- "Return a list of members for TAG that are safe to permute."
- (let ((mem (semantic-tag-type-members tag))
- (fname (semantic-tag-file-name tag)))
- (if fname
- (setq mem (semanticdb-typecache-apply-filename fname mem))
- (copy-sequence mem))))
- (defsubst semanticdb-typecache-safe-tag-list (tags table)
- "Make the tag list TAGS found in TABLE safe for the typecache.
- Adds a filename and copies the tags."
- (semanticdb-typecache-apply-filename
- (semanticdb-full-filename table)
- tags))
- (defun semanticdb-typecache-faux-namespace (name members)
- "Create a new namespace tag with NAME and a set of MEMBERS.
- The new tag will be a faux tag, used as a placeholder in a typecache."
- (let ((tag (semantic-tag-new-type name "namespace" members nil)))
-
- (semantic-tag-set-faux tag)
- tag))
- (defun semanticdb-typecache-merge-streams (cache1 cache2)
- "Merge into CACHE1 and CACHE2 together. The Caches will be merged in place."
- (if (or (and (not cache1) (not cache2))
- (and (not (cdr cache1)) (not cache2))
- (and (not cache1) (not (cdr cache2))))
-
-
-
-
-
- (or cache1 cache2)
-
-
- (require 'semantic/sort)
- (let ((S (semantic-sort-tags-by-name-then-type-increasing
-
-
-
- (nconc cache1 cache2)))
- (ans nil)
- (next nil)
- (prev nil)
- (type nil))
-
-
-
- (while S
- (setq prev (car ans))
- (setq next (car S))
- (if (or
-
- (null prev)
-
- (not (string= (semantic-tag-name next)
- (semantic-tag-name prev))))
- (setq ans (cons next ans))
-
- (setq type (semantic-tag-type next))
- (if (or (semantic-tag-of-type-p prev type)
- (semantic-tag-faux-p prev)
- (semantic-tag-faux-p next)
- )
-
- (cond
- ((and (semantic-tag-of-class-p next 'type)
- (string= type "namespace"))
-
- (setcar ans
- (semanticdb-typecache-faux-namespace
- (semantic-tag-name prev)
- (semanticdb-typecache-merge-streams
- (semanticdb-typecache-safe-tag-members prev)
- (semanticdb-typecache-safe-tag-members next))
- ))
- )
- ((semantic-tag-prototype-p next)
-
- nil
- )
- ((semantic-tag-prototype-p prev)
-
-
- (setcar ans next)
- )
- (t
-
- ))
-
-
-
-
-
- (setq ans (cons next ans))
- ))
- (setq S (cdr S)))
- (nreverse ans))))
- (define-overloadable-function semanticdb-expand-nested-tag (tag)
- "Expand TAG from fully qualified names.
- If TAG has fully qualified names, expand it to a series of nested
- namespaces instead."
- tag)
- (defmethod semanticdb-typecache-file-tags ((table semanticdb-abstract-table))
- "No tags available from non-file based tables."
- nil)
- (defmethod semanticdb-typecache-file-tags ((table semanticdb-table))
- "Update the typecache for TABLE, and return the file-tags.
- File-tags are those that belong to this file only, and excludes
- all included files."
- (let* (
- (cache (semanticdb-get-typecache table))
- )
-
- (when (not (oref cache filestream))
- (let ((tags (semantic-find-tags-by-class 'type table))
- (exptags nil))
- (when tags
- (setq tags (semanticdb-typecache-safe-tag-list tags table))
- (dolist (T tags)
- (push (semanticdb-expand-nested-tag T) exptags))
- (oset cache filestream (semanticdb-typecache-merge-streams exptags nil)))))
-
- (oref cache filestream)
- ))
- (defmethod semanticdb-typecache-include-tags ((table semanticdb-abstract-table))
- "No tags available from non-file based tables."
- nil)
- (defmethod semanticdb-typecache-include-tags ((table semanticdb-table))
- "Update the typecache for TABLE, and return the merged types from the include tags.
- Include-tags are the tags brought in via includes, all merged together into
- a master list."
- (let* ((cache (semanticdb-get-typecache table))
- )
-
- (when (not (oref cache includestream))
- (let (
-
-
- (incpath (semanticdb-find-translate-path table nil))
- (incstream nil))
-
-
- (dolist (i incpath)
-
- (when (and i (not (eq i table))
-
-
- )
- (setq incstream
- (semanticdb-typecache-merge-streams
- incstream
-
-
-
-
-
-
- (copy-sequence
- (semanticdb-typecache-file-tags i))))
- ))
-
- (oset cache includestream incstream)))
-
- (oref cache includestream)
- ))
- (define-overloadable-function semanticdb-typecache-find (type &optional path find-file-match)
- "Search the typecache for TYPE in PATH.
- If type is a string, split the string, and search for the parts.
- If type is a list, treat the type as a pre-split string.
- PATH can be nil for the current buffer, or a semanticdb table.
- FIND-FILE-MATCH is non-nil to force all found tags to be loaded into a buffer.")
- (defun semanticdb-typecache-find-default (type &optional path find-file-match)
- "Default implementation of `semanticdb-typecache-find'.
- TYPE is the datatype to find.
- PATH is the search path, which should be one table object.
- If FIND-FILE-MATCH is non-nil, then force the file belonging to the
- found tag to be loaded."
- (if (not (and (featurep 'semantic/db) semanticdb-current-database))
- nil
- (save-excursion
- (semanticdb-typecache-find-method (or path semanticdb-current-table)
- type find-file-match))))
- (defun semanticdb-typecache-find-by-name-helper (name table)
- "Find the tag with NAME in TABLE, which is from a typecache.
- If more than one tag has NAME in TABLE, we will prefer the tag that
- is of class 'type."
- (let* ((names (semantic-find-tags-by-name name table))
- (nmerge (semanticdb-typecache-merge-streams names nil))
- (types (semantic-find-tags-by-class 'type nmerge)))
- (or (car-safe types) (car-safe nmerge))))
- (defmethod semanticdb-typecache-find-method ((table semanticdb-abstract-table)
- type find-file-match)
- "Search the typecache in TABLE for the datatype TYPE.
- If type is a string, split the string, and search for the parts.
- If type is a list, treat the type as a pre-split string.
- If FIND-FILE-MATCH is non-nil, then force the file belonging to the
- found tag to be loaded."
-
- (when (stringp type) (setq type (semantic-analyze-split-name type)))
- (when (stringp type) (setq type (list type)))
-
- (let* ((file (semanticdb-typecache-file-tags table))
- (inc (semanticdb-typecache-include-tags table))
- (stream nil)
- (f-ans nil)
- (i-ans nil)
- (ans nil)
- (notdone t)
- (lastfile nil)
- (thisfile nil)
- (lastans nil)
- (calculated-scope nil)
- )
-
-
-
- (setq f-ans (semantic-find-first-tag-by-name (car type) file))
- (setq i-ans (semantic-find-first-tag-by-name (car type) inc))
- (if (and f-ans i-ans)
- (progn
-
-
- (setq ans (semanticdb-typecache-merge-streams (list f-ans) (list i-ans)))
- (setq ans (semantic-find-first-tag-by-name (car type) ans))
- )
-
-
- (setq ans (or f-ans i-ans)))
-
- (while (and type notdone)
-
-
- (when stream
- (setq ans (semanticdb-typecache-find-by-name-helper (car type) stream))
-
-
-
-
-
- (when (cdr type)
-
-
- (when (not (semantic-tag-of-class-p ans 'type))
- (setq ans nil)))
- )
- (push ans calculated-scope)
-
- (setq thisfile (semantic-tag-file-name ans))
- (when (and thisfile (stringp thisfile))
- (setq lastfile thisfile))
-
-
- (if (not ans)
- (setq notdone nil)
- (setq stream (semantic-tag-type-members ans)))
- (setq lastans ans
- ans nil
- type (cdr type)))
- (if (or type (not notdone))
-
-
- nil
-
- (if (and find-file-match lastfile)
-
-
- (find-file-noselect lastfile)
-
-
- (when lastans
- (setq lastans (semantic-tag-copy lastans nil lastfile))
-
-
-
- )
- )
- (if (and lastans calculated-scope)
-
- (progn
- (require 'semantic/scope)
- (semantic-scope-tag-clone-with-scope
- lastans (reverse (cdr calculated-scope))))
-
- lastans
- ))))
- (defmethod semanticdb-typecache-for-database ((db semanticdb-project-database)
- &optional mode)
- "Return the typecache for the project database DB.
- If there isn't one, create it.
- "
- (let ((lmode (or mode major-mode))
- (cache (semanticdb-get-typecache db))
- (stream nil)
- )
- (dolist (table (semanticdb-get-database-tables db))
- (when (eq lmode (oref table :major-mode))
- (setq stream
- (semanticdb-typecache-merge-streams
- stream
- (copy-sequence
- (semanticdb-typecache-file-tags table))))
- ))
- (oset cache stream stream)
- cache))
- (defun semanticdb-typecache-refresh-for-buffer (buffer)
- "Refresh the typecache for BUFFER."
- (with-current-buffer buffer
- (let* ((tab semanticdb-current-table)
-
- (tc (semanticdb-get-typecache tab)))
- (semanticdb-typecache-file-tags tab)
- (semanticdb-typecache-include-tags tab)
- tc)))
- (defun semanticdb-typecache-complete-flush ()
- "Flush all typecaches referenced by the current buffer."
- (interactive)
- (let* ((path (semanticdb-find-translate-path nil nil)))
- (dolist (P path)
- (oset P pointmax nil)
- (semantic-reset (semanticdb-get-typecache P)))))
- (defun semanticdb-typecache-dump ()
- "Dump the typecache for the current buffer."
- (interactive)
- (require 'data-debug)
- (let* ((start (current-time))
- (tc (semanticdb-typecache-refresh-for-buffer (current-buffer)))
- (end (current-time))
- )
- (data-debug-new-buffer "*TypeCache ADEBUG*")
- (message "Calculating Cache took %.2f seconds."
- (semantic-elapsed-time start end))
- (data-debug-insert-thing tc "]" "")
- ))
- (defun semanticdb-db-typecache-dump ()
- "Dump the typecache for the current buffer's database."
- (interactive)
- (require 'data-debug)
- (let* ((tab semanticdb-current-table)
- (idx (semanticdb-get-table-index tab))
- (junk (oset idx type-cache nil))
- (start (current-time))
- (tc (semanticdb-typecache-for-database (oref tab parent-db)))
- (end (current-time))
- )
- (data-debug-new-buffer "*TypeCache ADEBUG*")
- (message "Calculating Cache took %.2f seconds."
- (semantic-elapsed-time start end))
- (data-debug-insert-thing tc "]" "")
- ))
- (provide 'semantic/db-typecache)
|