diff options
Diffstat (limited to 'lisp')
| -rw-r--r-- | lisp/cedet/semantic/adebug.el | 423 | ||||
| -rw-r--r-- | lisp/cedet/semantic/chart.el | 167 | ||||
| -rw-r--r-- | lisp/cedet/semantic/db-debug.el | 108 | ||||
| -rw-r--r-- | lisp/cedet/semantic/db-ebrowse.el | 706 | ||||
| -rw-r--r-- | lisp/cedet/semantic/db-el.el | 343 | ||||
| -rw-r--r-- | lisp/cedet/semantic/db-file.el | 438 | ||||
| -rw-r--r-- | lisp/cedet/semantic/db-javascript.el | 310 | ||||
| -rw-r--r-- | lisp/cedet/semantic/db-search.el | 451 | ||||
| -rw-r--r-- | lisp/cedet/semantic/db-typecache.el | 585 | ||||
| -rw-r--r-- | lisp/cedet/semantic/dep.el | 228 | ||||
| -rw-r--r-- | lisp/cedet/semantic/ia.el | 439 | ||||
| -rw-r--r-- | lisp/cedet/semantic/tag-file.el | 202 | ||||
| -rw-r--r-- | lisp/cedet/semantic/tag-ls.el | 276 |
13 files changed, 4676 insertions, 0 deletions
diff --git a/lisp/cedet/semantic/adebug.el b/lisp/cedet/semantic/adebug.el new file mode 100644 index 00000000000..fe8e71b82e8 --- /dev/null +++ b/lisp/cedet/semantic/adebug.el | |||
| @@ -0,0 +1,423 @@ | |||
| 1 | ;;; adebug.el --- Semantic Application Debugger | ||
| 2 | |||
| 3 | ;;; Copyright (C) 2007, 2008, 2009 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 <http://www.gnu.org/licenses/>. | ||
| 21 | |||
| 22 | ;;; Commentary: | ||
| 23 | ;; | ||
| 24 | ;; Semantic datastructure debugger for semantic applications. | ||
| 25 | ;; Uses data-debug for core implementation. | ||
| 26 | ;; | ||
| 27 | ;; Goals: | ||
| 28 | ;; | ||
| 29 | ;; Inspect all known details of a TAG in a buffer. | ||
| 30 | ;; | ||
| 31 | ;; Analyze the list of active semantic databases, and the tags therin. | ||
| 32 | ;; | ||
| 33 | ;; Allow interactive navigation of the analysis process, tags, etc. | ||
| 34 | |||
| 35 | (require 'data-debug) | ||
| 36 | (require 'eieio-datadebug) | ||
| 37 | (require 'semantic/analyze) | ||
| 38 | |||
| 39 | ;;; Code: | ||
| 40 | |||
| 41 | ;;; SEMANTIC TAG STUFF | ||
| 42 | ;; | ||
| 43 | (defun data-debug-insert-tag-parts (tag prefix &optional parent) | ||
| 44 | "Insert all the parts of TAG. | ||
| 45 | PREFIX specifies what to insert at the start of each line. | ||
| 46 | PARENT specifires any parent tag." | ||
| 47 | (data-debug-insert-thing (semantic-tag-name tag) | ||
| 48 | prefix | ||
| 49 | "Name: " | ||
| 50 | parent) | ||
| 51 | (insert prefix "Class: '" (format "%S" (semantic-tag-class tag)) "\n") | ||
| 52 | (when (semantic-tag-with-position-p tag) | ||
| 53 | (let ((ol (semantic-tag-overlay tag)) | ||
| 54 | (file (semantic-tag-file-name tag)) | ||
| 55 | (start (semantic-tag-start tag)) | ||
| 56 | (end (semantic-tag-end tag)) | ||
| 57 | ) | ||
| 58 | (insert prefix "Position: " | ||
| 59 | (if (and (numberp start) (numberp end)) | ||
| 60 | (format "%d -> %d in " start end) | ||
| 61 | "") | ||
| 62 | (if file (file-name-nondirectory file) "unknown-file") | ||
| 63 | (if (semantic-overlay-p ol) | ||
| 64 | " <live tag>" | ||
| 65 | "") | ||
| 66 | "\n") | ||
| 67 | (data-debug-insert-thing ol prefix | ||
| 68 | "Position Data: " | ||
| 69 | parent) | ||
| 70 | )) | ||
| 71 | (let ((attrprefix (concat (make-string (length prefix) ? ) "# "))) | ||
| 72 | (insert prefix "Attributes:\n") | ||
| 73 | (data-debug-insert-property-list | ||
| 74 | (semantic-tag-attributes tag) attrprefix tag) | ||
| 75 | (insert prefix "Properties:\n") | ||
| 76 | (data-debug-insert-property-list | ||
| 77 | (semantic-tag-properties tag) attrprefix tag) | ||
| 78 | ) | ||
| 79 | |||
| 80 | ) | ||
| 81 | |||
| 82 | (defun data-debug-insert-tag-parts-from-point (point) | ||
| 83 | "Call `data-debug-insert-tag-parts' based on text properties at POINT." | ||
| 84 | (let ((tag (get-text-property point 'ddebug)) | ||
| 85 | (parent (get-text-property point 'ddebug-parent)) | ||
| 86 | (indent (get-text-property point 'ddebug-indent)) | ||
| 87 | start | ||
| 88 | ) | ||
| 89 | (end-of-line) | ||
| 90 | (setq start (point)) | ||
| 91 | (forward-char 1) | ||
| 92 | (data-debug-insert-tag-parts tag | ||
| 93 | (concat (make-string indent ? ) | ||
| 94 | "| ") | ||
| 95 | parent) | ||
| 96 | (goto-char start) | ||
| 97 | )) | ||
| 98 | |||
| 99 | (defun data-debug-insert-tag (tag prefix prebuttontext &optional parent) | ||
| 100 | "Insert TAG into the current buffer at the current point. | ||
| 101 | PREFIX specifies text to insert in front of TAG. | ||
| 102 | PREBUTTONTEXT is text appearing btewen the prefix and TAG. | ||
| 103 | Optional PARENT is the parent tag containing TAG. | ||
| 104 | Add text properties needed to allow tag expansion later." | ||
| 105 | (let ((start (point)) | ||
| 106 | (end nil) | ||
| 107 | (str (semantic-format-tag-uml-abbreviate tag parent t)) | ||
| 108 | (tip (semantic-format-tag-prototype tag parent t)) | ||
| 109 | ) | ||
| 110 | (insert prefix prebuttontext str "\n") | ||
| 111 | (setq end (point)) | ||
| 112 | (put-text-property start end 'ddebug tag) | ||
| 113 | (put-text-property start end 'ddebug-parent parent) | ||
| 114 | (put-text-property start end 'ddebug-indent(length prefix)) | ||
| 115 | (put-text-property start end 'ddebug-prefix prefix) | ||
| 116 | (put-text-property start end 'help-echo tip) | ||
| 117 | (put-text-property start end 'ddebug-function | ||
| 118 | 'data-debug-insert-tag-parts-from-point) | ||
| 119 | |||
| 120 | )) | ||
| 121 | |||
| 122 | ;;; TAG LISTS | ||
| 123 | ;; | ||
| 124 | (defun data-debug-insert-tag-list (taglist prefix &optional parent) | ||
| 125 | "Insert the tag list TAGLIST with PREFIX. | ||
| 126 | Optional argument PARENT specifies the part of TAGLIST." | ||
| 127 | (condition-case nil | ||
| 128 | (while taglist | ||
| 129 | (cond ((and (consp taglist) (semantic-tag-p (car taglist))) | ||
| 130 | (data-debug-insert-tag (car taglist) prefix "" parent)) | ||
| 131 | ((consp taglist) | ||
| 132 | (data-debug-insert-thing (car taglist) prefix "" parent)) | ||
| 133 | (t (data-debug-insert-thing taglist prefix "" parent))) | ||
| 134 | (setq taglist (cdr taglist))) | ||
| 135 | (error nil))) | ||
| 136 | |||
| 137 | (defun data-debug-insert-taglist-from-point (point) | ||
| 138 | "Insert the taglist found at the taglist button at POINT." | ||
| 139 | (let ((taglist (get-text-property point 'ddebug)) | ||
| 140 | (parent (get-text-property point 'ddebug-parent)) | ||
| 141 | (indent (get-text-property point 'ddebug-indent)) | ||
| 142 | start | ||
| 143 | ) | ||
| 144 | (end-of-line) | ||
| 145 | (setq start (point)) | ||
| 146 | (forward-char 1) | ||
| 147 | (data-debug-insert-tag-list taglist | ||
| 148 | (concat (make-string indent ? ) | ||
| 149 | "* ") | ||
| 150 | parent) | ||
| 151 | (goto-char start) | ||
| 152 | |||
| 153 | )) | ||
| 154 | |||
| 155 | (defun data-debug-insert-tag-list-button (taglist prefix prebuttontext &optional parent) | ||
| 156 | "Insert a single summary of a TAGLIST. | ||
| 157 | PREFIX is the text that preceeds the button. | ||
| 158 | PREBUTTONTEXT is some text between PREFIX and the taglist button. | ||
| 159 | PARENT is the tag that represents the parent of all the tags." | ||
| 160 | (let ((start (point)) | ||
| 161 | (end nil) | ||
| 162 | (str (format "#<TAG LIST: %d entries>" (safe-length taglist))) | ||
| 163 | (tip nil)) | ||
| 164 | (insert prefix prebuttontext str) | ||
| 165 | (setq end (point)) | ||
| 166 | (put-text-property (- end (length str)) end 'face 'font-lock-function-name-face) | ||
| 167 | (put-text-property start end 'ddebug taglist) | ||
| 168 | (put-text-property start end 'ddebug-parent parent) | ||
| 169 | (put-text-property start end 'ddebug-indent(length prefix)) | ||
| 170 | (put-text-property start end 'ddebug-prefix prefix) | ||
| 171 | (put-text-property start end 'help-echo tip) | ||
| 172 | (put-text-property start end 'ddebug-function | ||
| 173 | 'data-debug-insert-taglist-from-point) | ||
| 174 | (insert "\n") | ||
| 175 | )) | ||
| 176 | |||
| 177 | ;;; SEMANTICDB FIND RESULTS | ||
| 178 | ;; | ||
| 179 | (defun data-debug-insert-find-results (findres prefix) | ||
| 180 | "Insert the find results FINDRES with PREFIX." | ||
| 181 | ;; ( (DBOBJ TAG TAG TAG) (DBOBJ TAG TAG TAG) ... ) | ||
| 182 | (let ((cnt 1)) | ||
| 183 | (while findres | ||
| 184 | (let* ((dbhit (car findres)) | ||
| 185 | (db (car dbhit)) | ||
| 186 | (tags (cdr dbhit))) | ||
| 187 | (data-debug-insert-thing db prefix (format "DB %d: " cnt)) | ||
| 188 | (data-debug-insert-thing tags prefix (format "HITS %d: " cnt)) | ||
| 189 | ) | ||
| 190 | (setq findres (cdr findres) | ||
| 191 | cnt (1+ cnt))))) | ||
| 192 | |||
| 193 | (defun data-debug-insert-find-results-from-point (point) | ||
| 194 | "Insert the find results found at the find results button at POINT." | ||
| 195 | (let ((findres (get-text-property point 'ddebug)) | ||
| 196 | (indent (get-text-property point 'ddebug-indent)) | ||
| 197 | start | ||
| 198 | ) | ||
| 199 | (end-of-line) | ||
| 200 | (setq start (point)) | ||
| 201 | (forward-char 1) | ||
| 202 | (data-debug-insert-find-results findres | ||
| 203 | (concat (make-string indent ? ) | ||
| 204 | "!* ") | ||
| 205 | ) | ||
| 206 | (goto-char start) | ||
| 207 | )) | ||
| 208 | |||
| 209 | (defun data-debug-insert-find-results-button (findres prefix prebuttontext) | ||
| 210 | "Insert a single summary of a find results FINDRES. | ||
| 211 | PREFIX is the text that preceeds the button. | ||
| 212 | PREBUTTONTEXT is some text between prefix and the find results button." | ||
| 213 | (let ((start (point)) | ||
| 214 | (end nil) | ||
| 215 | (str (semanticdb-find-result-prin1-to-string findres)) | ||
| 216 | (tip nil)) | ||
| 217 | (insert prefix prebuttontext str) | ||
| 218 | (setq end (point)) | ||
| 219 | (put-text-property (- end (length str)) end 'face 'font-lock-function-name-face) | ||
| 220 | (put-text-property start end 'ddebug findres) | ||
| 221 | (put-text-property start end 'ddebug-indent(length prefix)) | ||
| 222 | (put-text-property start end 'ddebug-prefix prefix) | ||
| 223 | (put-text-property start end 'help-echo tip) | ||
| 224 | (put-text-property start end 'ddebug-function | ||
| 225 | 'data-debug-insert-find-results-from-point) | ||
| 226 | (insert "\n") | ||
| 227 | )) | ||
| 228 | |||
| 229 | (defun data-debug-insert-db-and-tag-button (dbtag prefix prebuttontext) | ||
| 230 | "Insert a single summary of short list DBTAG of format (DB . TAG). | ||
| 231 | PREFIX is the text that preceeds the button. | ||
| 232 | PREBUTTONTEXT is some text between prefix and the find results button." | ||
| 233 | (let ((start (point)) | ||
| 234 | (end nil) | ||
| 235 | (str (concat "(#<db/tag " | ||
| 236 | (object-name-string (car dbtag)) | ||
| 237 | " / " | ||
| 238 | (semantic-format-tag-name (cdr dbtag) nil t) | ||
| 239 | ")")) | ||
| 240 | (tip nil)) | ||
| 241 | (insert prefix prebuttontext str) | ||
| 242 | (setq end (point)) | ||
| 243 | (put-text-property (- end (length str)) end 'face 'font-lock-function-name-face) | ||
| 244 | (put-text-property start end 'ddebug dbtag) | ||
| 245 | (put-text-property start end 'ddebug-indent(length prefix)) | ||
| 246 | (put-text-property start end 'ddebug-prefix prefix) | ||
| 247 | (put-text-property start end 'help-echo tip) | ||
| 248 | (put-text-property start end 'ddebug-function | ||
| 249 | 'data-debug-insert-db-and-tag-from-point) | ||
| 250 | (insert "\n") | ||
| 251 | )) | ||
| 252 | |||
| 253 | (defun data-debug-insert-db-and-tag-from-point (point) | ||
| 254 | "Insert the find results found at the find results button at POINT." | ||
| 255 | (let ((dbtag (get-text-property point 'ddebug)) | ||
| 256 | (indent (get-text-property point 'ddebug-indent)) | ||
| 257 | start | ||
| 258 | ) | ||
| 259 | (end-of-line) | ||
| 260 | (setq start (point)) | ||
| 261 | (forward-char 1) | ||
| 262 | (data-debug-insert-thing (car dbtag) (make-string indent ? ) | ||
| 263 | "| DB ") | ||
| 264 | (data-debug-insert-tag (cdr dbtag) (concat (make-string indent ? ) | ||
| 265 | "| ") | ||
| 266 | "TAG ") | ||
| 267 | (goto-char start) | ||
| 268 | )) | ||
| 269 | |||
| 270 | ;;; DEBUG COMMANDS | ||
| 271 | ;; | ||
| 272 | ;; Various commands to output aspects of the current semantic environment. | ||
| 273 | (defun semantic-adebug-bovinate () | ||
| 274 | "The same as `bovinate'. Display the results in a debug buffer." | ||
| 275 | (interactive) | ||
| 276 | (let* ((start (current-time)) | ||
| 277 | (out (semantic-fetch-tags)) | ||
| 278 | (end (current-time))) | ||
| 279 | |||
| 280 | (message "Retrieving tags took %.2f seconds." | ||
| 281 | (semantic-elapsed-time start end)) | ||
| 282 | |||
| 283 | (data-debug-new-buffer (concat "*" (buffer-name) " ADEBUG*")) | ||
| 284 | (data-debug-insert-tag-list out "* ")) | ||
| 285 | ) | ||
| 286 | |||
| 287 | (defun semantic-adebug-searchdb (regex) | ||
| 288 | "Search the semanticdb for REGEX for the current buffer. | ||
| 289 | Display the results as a debug list." | ||
| 290 | (interactive "sSymbol Regex: ") | ||
| 291 | (let ((start (current-time)) | ||
| 292 | (fr (semanticdb-find-tags-by-name-regexp regex)) | ||
| 293 | (end (current-time))) | ||
| 294 | |||
| 295 | (data-debug-new-buffer (concat "*SEMANTICDB SEARCH: " | ||
| 296 | regex | ||
| 297 | " ADEBUG*")) | ||
| 298 | (message "Search of tags took %.2f seconds." | ||
| 299 | (semantic-elapsed-time start end)) | ||
| 300 | |||
| 301 | (data-debug-insert-find-results fr "*"))) | ||
| 302 | |||
| 303 | (defun semantic-adebug-analyze (&optional ctxt) | ||
| 304 | "Perform `semantic-analyze-current-context'. | ||
| 305 | Display the results as a debug list. | ||
| 306 | Optional argument CTXT is the context to show." | ||
| 307 | (interactive) | ||
| 308 | (let ((start (current-time)) | ||
| 309 | (ctxt (or ctxt (semantic-analyze-current-context))) | ||
| 310 | (end (current-time))) | ||
| 311 | (if (not ctxt) | ||
| 312 | (message "No Analyzer Results") | ||
| 313 | (message "Analysis took %.2f seconds." | ||
| 314 | (semantic-elapsed-time start end)) | ||
| 315 | (semantic-analyze-pulse ctxt) | ||
| 316 | (if ctxt | ||
| 317 | (progn | ||
| 318 | (data-debug-new-buffer "*Analyzer ADEBUG*") | ||
| 319 | (data-debug-insert-object-slots ctxt "]")) | ||
| 320 | (message "No Context to analyze here."))))) | ||
| 321 | |||
| 322 | (defun semantic-adebug-edebug-expr (expr) | ||
| 323 | "Dump out the contets of some expression EXPR in edebug with adebug." | ||
| 324 | (interactive "sExpression: ") | ||
| 325 | (let ((v (eval (read expr)))) | ||
| 326 | (if (not v) | ||
| 327 | (message "Expression %s is nil." expr) | ||
| 328 | (data-debug-new-buffer "*expression ADEBUG*") | ||
| 329 | (data-debug-insert-thing v "?" "") | ||
| 330 | ))) | ||
| 331 | |||
| 332 | (defun semanticdb-debug-file-tag-check (startfile) | ||
| 333 | "Report debug info for checking STARTFILE for up-to-date tags." | ||
| 334 | (interactive "FFile to Check (default = current-buffer): ") | ||
| 335 | (let* ((file (file-truename startfile)) | ||
| 336 | (default-directory (file-name-directory file)) | ||
| 337 | (db (or | ||
| 338 | ;; This line will pick up system databases. | ||
| 339 | (semanticdb-directory-loaded-p default-directory) | ||
| 340 | ;; this line will make a new one if needed. | ||
| 341 | (semanticdb-get-database default-directory))) | ||
| 342 | (tab (semanticdb-file-table db file)) | ||
| 343 | ) | ||
| 344 | (with-output-to-temp-buffer "*DEBUG STUFF*" | ||
| 345 | (princ "Starting file is: ") | ||
| 346 | (princ startfile) | ||
| 347 | (princ "\nTrueName is: ") | ||
| 348 | (princ file) | ||
| 349 | (when (not (file-exists-p file)) | ||
| 350 | (princ "\nFile does not exist!")) | ||
| 351 | (princ "\nDirectory Part is: ") | ||
| 352 | (princ default-directory) | ||
| 353 | (princ "\nFound Database is: ") | ||
| 354 | (princ (object-print db)) | ||
| 355 | (princ "\nFound Table is: ") | ||
| 356 | (if tab (princ (object-print tab)) (princ "nil")) | ||
| 357 | (princ "\n\nAction Summary: ") | ||
| 358 | (cond | ||
| 359 | ((and tab | ||
| 360 | ;; Is this in a buffer? | ||
| 361 | (find-buffer-visiting (semanticdb-full-filename tab)) | ||
| 362 | ) | ||
| 363 | (princ "Found Buffer: ") | ||
| 364 | (prin1 (find-buffer-visiting (semanticdb-full-filename tab))) | ||
| 365 | ) | ||
| 366 | ((and tab | ||
| 367 | ;; Is table fully loaded, or just a proxy? | ||
| 368 | (number-or-marker-p (oref tab pointmax)) | ||
| 369 | ;; Is this table up to date with the file? | ||
| 370 | (not (semanticdb-needs-refresh-p tab))) | ||
| 371 | (princ "Found table, no refresh needed.\n Pointmax is: ") | ||
| 372 | (prin1 (oref tab pointmax)) | ||
| 373 | ) | ||
| 374 | (t | ||
| 375 | (princ "Found table that needs refresh.") | ||
| 376 | (if (not tab) | ||
| 377 | (princ "\n No Saved Point.") | ||
| 378 | (princ "\n Saved pointmax: ") | ||
| 379 | (prin1 (oref tab pointmax)) | ||
| 380 | (princ " Needs Refresh: ") | ||
| 381 | (prin1 (semanticdb-needs-refresh-p tab)) | ||
| 382 | ) | ||
| 383 | )) | ||
| 384 | ;; Buffer isn't loaded. The only clue we have is if the file | ||
| 385 | ;; is somehow different from our mark in the semanticdb table. | ||
| 386 | (let* ((stats (file-attributes file)) | ||
| 387 | (actualsize (nth 7 stats)) | ||
| 388 | (actualmod (nth 5 stats)) | ||
| 389 | ) | ||
| 390 | |||
| 391 | (if (or (not tab) | ||
| 392 | (not (slot-boundp tab 'tags)) | ||
| 393 | (not (oref tab tags))) | ||
| 394 | (princ "\n No tags in table.") | ||
| 395 | (princ "\n Number of known tags: ") | ||
| 396 | (prin1 (length (oref tab tags)))) | ||
| 397 | |||
| 398 | (princ "\n File Size is: ") | ||
| 399 | (prin1 actualsize) | ||
| 400 | (princ "\n File Mod Time is: ") | ||
| 401 | (princ (format-time-string "%Y-%m-%d %T" actualmod)) | ||
| 402 | (when tab | ||
| 403 | (princ "\n Saved file size is: ") | ||
| 404 | (prin1 (oref tab fsize)) | ||
| 405 | (princ "\n Saved Mod time is: ") | ||
| 406 | (princ (format-time-string "%Y-%m-%d %T" | ||
| 407 | (oref tab lastmodtime))) | ||
| 408 | ) | ||
| 409 | ) | ||
| 410 | ) | ||
| 411 | ;; Force load | ||
| 412 | (semanticdb-file-table-object file) | ||
| 413 | nil | ||
| 414 | )) | ||
| 415 | |||
| 416 | ;; (semanticdb-debug-file-tag-check "/usr/lib/gcc/i486-linux-gnu/4.2/include/stddef.h") | ||
| 417 | ;; (semanticdb-debug-file-tag-check "/usr/include/stdlib.h") | ||
| 418 | |||
| 419 | |||
| 420 | |||
| 421 | (provide 'semantic/adebug) | ||
| 422 | |||
| 423 | ;;; semantic-adebug.el ends here | ||
diff --git a/lisp/cedet/semantic/chart.el b/lisp/cedet/semantic/chart.el new file mode 100644 index 00000000000..95c60a51365 --- /dev/null +++ b/lisp/cedet/semantic/chart.el | |||
| @@ -0,0 +1,167 @@ | |||
| 1 | ;;; chart.el --- Utilities for use with semantic tag tables | ||
| 2 | |||
| 3 | ;;; Copyright (C) 1999, 2000, 2001, 2003, 2005, 2008, 2009 | ||
| 4 | ;;; Free Software Foundation, Inc. | ||
| 5 | |||
| 6 | ;; Author: Eric M. Ludlam <zappo@gnu.org> | ||
| 7 | |||
| 8 | ;; This file is part of GNU Emacs. | ||
| 9 | |||
| 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
| 11 | ;; it under the terms of the GNU General Public License as published by | ||
| 12 | ;; the Free Software Foundation, either version 3 of the License, or | ||
| 13 | ;; (at your option) any later version. | ||
| 14 | |||
| 15 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 18 | ;; GNU General Public License for more details. | ||
| 19 | |||
| 20 | ;; You should have received a copy of the GNU General Public License | ||
| 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | ||
| 22 | |||
| 23 | ;;; Commentary: | ||
| 24 | ;; | ||
| 25 | ;; A set of simple functions for charting details about a file based on | ||
| 26 | ;; the output of the semantic parser. | ||
| 27 | ;; | ||
| 28 | |||
| 29 | (require 'semantic) | ||
| 30 | (require 'chart) | ||
| 31 | |||
| 32 | ;;; Code: | ||
| 33 | |||
| 34 | (defun semantic-chart-tags-by-class (&optional tagtable) | ||
| 35 | "Create a bar chart representing the number of tags for a given tag class. | ||
| 36 | Each bar represents how many toplevel tags in TAGTABLE | ||
| 37 | exist with a given class. See `semantic-symbol->name-assoc-list' | ||
| 38 | for tokens which will be charted. | ||
| 39 | TAGTABLE is passedto `semantic-something-to-tag-table'." | ||
| 40 | (interactive) | ||
| 41 | (let* ((stream (semantic-something-to-tag-table | ||
| 42 | (or tagtable (current-buffer)))) | ||
| 43 | (names (mapcar 'cdr semantic-symbol->name-assoc-list)) | ||
| 44 | (nums (mapcar | ||
| 45 | (lambda (symname) | ||
| 46 | (length | ||
| 47 | (semantic-brute-find-tag-by-class (car symname) | ||
| 48 | stream) | ||
| 49 | )) | ||
| 50 | semantic-symbol->name-assoc-list))) | ||
| 51 | (chart-bar-quickie 'vertical | ||
| 52 | "Semantic Toplevel Tag Volume" | ||
| 53 | names "Tag Class" | ||
| 54 | nums "Volume") | ||
| 55 | )) | ||
| 56 | |||
| 57 | (defun semantic-chart-database-size (&optional tagtable) | ||
| 58 | "Create a bar chart representing the size of each file in semanticdb. | ||
| 59 | Each bar represents how many toplevel tags in TAGTABLE | ||
| 60 | exist in each database entry. | ||
| 61 | TAGTABLE is passed to `semantic-something-to-tag-table'." | ||
| 62 | (interactive) | ||
| 63 | (if (or (not (fboundp 'semanticdb-minor-mode-p)) | ||
| 64 | (not (semanticdb-minor-mode-p))) | ||
| 65 | (error "Semanticdb is not enabled")) | ||
| 66 | (let* ((db semanticdb-current-database) | ||
| 67 | (dbt (semanticdb-get-database-tables db)) | ||
| 68 | (names (mapcar 'car | ||
| 69 | (object-assoc-list | ||
| 70 | 'file | ||
| 71 | dbt))) | ||
| 72 | (numnuts (mapcar (lambda (dba) | ||
| 73 | (prog1 | ||
| 74 | (cons | ||
| 75 | (if (slot-boundp dba 'tags) | ||
| 76 | (length (oref dba tags)) | ||
| 77 | 1) | ||
| 78 | (car names)) | ||
| 79 | (setq names (cdr names)))) | ||
| 80 | dbt)) | ||
| 81 | (nums nil) | ||
| 82 | (fh (/ (- (frame-height) 7) 4))) | ||
| 83 | (setq numnuts (sort numnuts (lambda (a b) (> (car a) (car b))))) | ||
| 84 | (setq names (mapcar 'cdr numnuts) | ||
| 85 | nums (mapcar 'car numnuts)) | ||
| 86 | (if (> (length names) fh) | ||
| 87 | (progn | ||
| 88 | (setcdr (nthcdr fh names) nil) | ||
| 89 | (setcdr (nthcdr fh nums) nil))) | ||
| 90 | (chart-bar-quickie 'horizontal | ||
| 91 | "Semantic DB Toplevel Tag Volume" | ||
| 92 | names "File" | ||
| 93 | nums "Volume") | ||
| 94 | )) | ||
| 95 | |||
| 96 | (defun semantic-chart-token-complexity (tok) | ||
| 97 | "Calculate the `complexity' of token TOK." | ||
| 98 | (count-lines | ||
| 99 | (semantic-tag-end tok) | ||
| 100 | (semantic-tag-start tok))) | ||
| 101 | |||
| 102 | (defun semantic-chart-tag-complexity | ||
| 103 | (&optional class tagtable) | ||
| 104 | "Create a bar chart representing the complexity of some tags. | ||
| 105 | Complexity is calculated for tags of CLASS. Each bar represents | ||
| 106 | the complexity of some tag in TAGTABLE. Only the most complex | ||
| 107 | items are charted. TAGTABLE is passedto | ||
| 108 | `semantic-something-to-tag-table'." | ||
| 109 | (interactive) | ||
| 110 | (let* ((sym (if (not class) 'function)) | ||
| 111 | (stream | ||
| 112 | (semantic-find-tags-by-class | ||
| 113 | sym (semantic-something-to-tag-table (or tagtable | ||
| 114 | (current-buffer))) | ||
| 115 | )) | ||
| 116 | (name (cond ((semantic-tag-with-position-p (car stream)) | ||
| 117 | (buffer-name (semantic-tag-buffer (car stream)))) | ||
| 118 | (t ""))) | ||
| 119 | (cplx (mapcar (lambda (tok) | ||
| 120 | (cons tok (semantic-chart-token-complexity tok))) | ||
| 121 | stream)) | ||
| 122 | (namelabel (cdr (assoc 'function semantic-symbol->name-assoc-list))) | ||
| 123 | (names nil) | ||
| 124 | (nums nil)) | ||
| 125 | (setq cplx (sort cplx (lambda (a b) (> (cdr a) (cdr b))))) | ||
| 126 | (while (and cplx (<= (length names) (/ (- (frame-height) 7) 4))) | ||
| 127 | (setq names (cons (semantic-tag-name (car (car cplx))) | ||
| 128 | names) | ||
| 129 | nums (cons (cdr (car cplx)) nums) | ||
| 130 | cplx (cdr cplx))) | ||
| 131 | ;; ;; (setq names (mapcar (lambda (str) | ||
| 132 | ;; ;; (substring str (- (length str) 10))) | ||
| 133 | ;; ;; names)) | ||
| 134 | (chart-bar-quickie 'horizontal | ||
| 135 | (format "%s Complexity in %s" | ||
| 136 | (capitalize (symbol-name sym)) | ||
| 137 | name) | ||
| 138 | names namelabel | ||
| 139 | nums "Complexity (Lines of code)") | ||
| 140 | )) | ||
| 141 | |||
| 142 | (defun semantic-chart-analyzer () | ||
| 143 | "Chart the extent of the context analysis." | ||
| 144 | (interactive) | ||
| 145 | (let* ((p (semanticdb-find-translate-path nil nil)) | ||
| 146 | (plen (length p)) | ||
| 147 | (tab semanticdb-current-table) | ||
| 148 | (tc (semanticdb-get-typecache tab)) | ||
| 149 | (tclen (+ (length (oref tc filestream)) | ||
| 150 | (length (oref tc includestream)))) | ||
| 151 | (scope (semantic-calculate-scope)) | ||
| 152 | (fslen (length (oref scope fullscope))) | ||
| 153 | (lvarlen (length (oref scope localvar))) | ||
| 154 | ) | ||
| 155 | (chart-bar-quickie 'vertical | ||
| 156 | (format "Analyzer Overhead in %s" (buffer-name)) | ||
| 157 | '("includes" "typecache" "scopelen" "localvar") | ||
| 158 | "Overhead Entries" | ||
| 159 | (list plen tclen fslen lvarlen) | ||
| 160 | "Number of tags") | ||
| 161 | )) | ||
| 162 | |||
| 163 | |||
| 164 | |||
| 165 | (provide 'semantic/chart) | ||
| 166 | |||
| 167 | ;;; semantic-chart.el ends here | ||
diff --git a/lisp/cedet/semantic/db-debug.el b/lisp/cedet/semantic/db-debug.el new file mode 100644 index 00000000000..6db1cbfaae9 --- /dev/null +++ b/lisp/cedet/semantic/db-debug.el | |||
| @@ -0,0 +1,108 @@ | |||
| 1 | ;;; db-debug.el --- Extra level debugging routines for Semantic | ||
| 2 | |||
| 3 | ;;; Copyright (C) 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 | ;; Various routines for debugging SemanticDB issues, or viewing | ||
| 25 | ;; semanticdb state. | ||
| 26 | |||
| 27 | (require 'semantic/db) | ||
| 28 | |||
| 29 | ;;; Code: | ||
| 30 | ;; | ||
| 31 | (defun semanticdb-dump-all-table-summary () | ||
| 32 | "Dump a list of all databases in Emacs memory." | ||
| 33 | (interactive) | ||
| 34 | (require 'data-debug) | ||
| 35 | (let ((db semanticdb-database-list)) | ||
| 36 | (data-debug-new-buffer "*SEMANTICDB*") | ||
| 37 | (data-debug-insert-stuff-list db "*"))) | ||
| 38 | |||
| 39 | (defalias 'semanticdb-adebug-database-list 'semanticdb-dump-all-table-summary) | ||
| 40 | |||
| 41 | (defun semanticdb-adebug-current-database () | ||
| 42 | "Run ADEBUG on the current database." | ||
| 43 | (interactive) | ||
| 44 | (require 'data-debug) | ||
| 45 | (let ((p semanticdb-current-database) | ||
| 46 | ) | ||
| 47 | (data-debug-new-buffer "*SEMANTICDB ADEBUG*") | ||
| 48 | (data-debug-insert-stuff-list p "*"))) | ||
| 49 | |||
| 50 | (defun semanticdb-adebug-current-table () | ||
| 51 | "Run ADEBUG on the current database." | ||
| 52 | (interactive) | ||
| 53 | (require 'data-debug) | ||
| 54 | (let ((p semanticdb-current-table)) | ||
| 55 | (data-debug-new-buffer "*SEMANTICDB ADEBUG*") | ||
| 56 | (data-debug-insert-stuff-list p "*"))) | ||
| 57 | |||
| 58 | |||
| 59 | (defun semanticdb-adebug-project-database-list () | ||
| 60 | "Run ADEBUG on the current database." | ||
| 61 | (interactive) | ||
| 62 | (require 'data-debug) | ||
| 63 | (let ((p (semanticdb-current-database-list))) | ||
| 64 | (data-debug-new-buffer "*SEMANTICDB ADEBUG*") | ||
| 65 | (data-debug-insert-stuff-list p "*"))) | ||
| 66 | |||
| 67 | |||
| 68 | |||
| 69 | ;;; Sanity Checks | ||
| 70 | ;; | ||
| 71 | |||
| 72 | (defun semanticdb-table-oob-sanity-check (cache) | ||
| 73 | "Validate that CACHE tags do not have any overlays in them." | ||
| 74 | (while cache | ||
| 75 | (when (semantic-overlay-p (semantic-tag-overlay cache)) | ||
| 76 | (message "Tag %s has an erroneous overlay!" | ||
| 77 | (semantic-format-tag-summarize (car cache)))) | ||
| 78 | (semanticdb-table-oob-sanity-check | ||
| 79 | (semantic-tag-components-with-overlays (car cache))) | ||
| 80 | (setq cache (cdr cache)))) | ||
| 81 | |||
| 82 | (defun semanticdb-table-sanity-check (&optional table) | ||
| 83 | "Validate the current semanticdb TABLE." | ||
| 84 | (interactive) | ||
| 85 | (if (not table) (setq table semanticdb-current-table)) | ||
| 86 | (let* ((full-filename (semanticdb-full-filename table)) | ||
| 87 | (buff (find-buffer-visiting full-filename))) | ||
| 88 | (if buff | ||
| 89 | (save-excursion | ||
| 90 | (set-buffer buff) | ||
| 91 | (semantic-sanity-check)) | ||
| 92 | ;; We can't use the usual semantic validity check, so hack our own. | ||
| 93 | (semanticdb-table-oob-sanity-check (semanticdb-get-tags table))))) | ||
| 94 | |||
| 95 | (defun semanticdb-database-sanity-check () | ||
| 96 | "Validate the current semantic database." | ||
| 97 | (interactive) | ||
| 98 | (let ((tables (semanticdb-get-database-tables | ||
| 99 | semanticdb-current-database))) | ||
| 100 | (while tables | ||
| 101 | (semanticdb-table-sanity-check (car tables)) | ||
| 102 | (setq tables (cdr tables))) | ||
| 103 | )) | ||
| 104 | |||
| 105 | |||
| 106 | |||
| 107 | (provide 'semantic/db-debug) | ||
| 108 | ;;; semanticdb-debug.el ends here | ||
diff --git a/lisp/cedet/semantic/db-ebrowse.el b/lisp/cedet/semantic/db-ebrowse.el new file mode 100644 index 00000000000..3302afd83da --- /dev/null +++ b/lisp/cedet/semantic/db-ebrowse.el | |||
| @@ -0,0 +1,706 @@ | |||
| 1 | ;;; db-ebrowse.el --- Semanticdb backend using ebrowse. | ||
| 2 | |||
| 3 | ;;; Copyright (C) 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. | ||
| 4 | |||
| 5 | ;; Authors: Eric M. Ludlam <zappo@gnu.org>, Joakim Verona | ||
| 6 | ;; Keywords: tags | ||
| 7 | |||
| 8 | ;; This file is part of GNU Emacs. | ||
| 9 | |||
| 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
| 11 | ;; it under the terms of the GNU General Public License as published by | ||
| 12 | ;; the Free Software Foundation, either version 3 of the License, or | ||
| 13 | ;; (at your option) any later version. | ||
| 14 | |||
| 15 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 18 | ;; GNU General Public License for more details. | ||
| 19 | |||
| 20 | ;; You should have received a copy of the GNU General Public License | ||
| 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | ||
| 22 | |||
| 23 | ;;; Commentary: | ||
| 24 | ;; | ||
| 25 | ;; This program was started by Eric Ludlam, and Joakim Verona finished | ||
| 26 | ;; the implementation by adding searches and fixing bugs. | ||
| 27 | ;; | ||
| 28 | ;; Read in custom-created ebrowse BROWSE files into a semanticdb back | ||
| 29 | ;; end. | ||
| 30 | ;; | ||
| 31 | ;; Add these databases to the 'system' search. | ||
| 32 | ;; Possibly use ebrowse for local parsing too. | ||
| 33 | ;; | ||
| 34 | ;; When real details are needed out of the tag system from ebrowse, | ||
| 35 | ;; we will need to delve into the originating source and parse those | ||
| 36 | ;; files the usual way. | ||
| 37 | ;; | ||
| 38 | ;; COMMANDS: | ||
| 39 | ;; `semanticdb-create-ebrowse-database' - Call EBROWSE to create a | ||
| 40 | ;; system database for some directory. In general, use this for | ||
| 41 | ;; system libraries, such as /usr/include, or include directories | ||
| 42 | ;; large software projects. | ||
| 43 | ;; Customize `semanticdb-ebrowse-file-match' to make sure the correct | ||
| 44 | ;; file extensions are matched. | ||
| 45 | ;; | ||
| 46 | ;; `semanticdb-load-ebrowse-caches' - Load all the EBROWSE caches from | ||
| 47 | ;; your semanticdb system database directory. Once they are | ||
| 48 | ;; loaded, they become searchable as omnipotent databases for | ||
| 49 | ;; all C++ files. This is called automatically by semantic-load. | ||
| 50 | ;; Call it a second time to refresh the Emacs DB with the file. | ||
| 51 | ;; | ||
| 52 | |||
| 53 | (eval-when-compile | ||
| 54 | ;; For generic function searching. | ||
| 55 | (require 'eieio) | ||
| 56 | (require 'eieio-opt) | ||
| 57 | ) | ||
| 58 | (require 'semantic/db-file) | ||
| 59 | |||
| 60 | (eval-and-compile | ||
| 61 | ;; Hopefully, this will allow semanticdb-ebrowse to compile under | ||
| 62 | ;; XEmacs, it just won't run if a user attempts to use it. | ||
| 63 | (condition-case nil | ||
| 64 | (require 'ebrowse) | ||
| 65 | (error nil))) | ||
| 66 | |||
| 67 | ;;; Code: | ||
| 68 | (defvar semanticdb-ebrowse-default-file-name "BROWSE" | ||
| 69 | "The EBROWSE file name used for system caches.") | ||
| 70 | |||
| 71 | (defcustom semanticdb-ebrowse-file-match "\\.\\(hh?\\|HH?\\|hpp\\)" | ||
| 72 | "Regular expression matching file names for ebrowse to parse. | ||
| 73 | This expression should exclude C++ headers that have no extension. | ||
| 74 | By default, include only headers since the semantic use of EBrowse | ||
| 75 | is only for searching via semanticdb, and thus only headers would | ||
| 76 | be searched." | ||
| 77 | :group 'semanticdb | ||
| 78 | :type 'string) | ||
| 79 | |||
| 80 | (defun semanticdb-ebrowse-C-file-p (file) | ||
| 81 | "Is FILE a C or C++ file?" | ||
| 82 | (or (string-match semanticdb-ebrowse-file-match file) | ||
| 83 | (and (string-match "/\\w+$" file) | ||
| 84 | (not (file-directory-p file)) | ||
| 85 | (let ((tmp (get-buffer-create "*semanticdb-ebrowse-tmp*"))) | ||
| 86 | (save-excursion | ||
| 87 | (set-buffer tmp) | ||
| 88 | (condition-case nil | ||
| 89 | (insert-file-contents file nil 0 100 t) | ||
| 90 | (error (insert-file-contents file nil nil nil t))) | ||
| 91 | (goto-char (point-min)) | ||
| 92 | (looking-at "\\s-*/\\(\\*\\|/\\)") | ||
| 93 | )) | ||
| 94 | ))) | ||
| 95 | |||
| 96 | (defun semanticdb-create-ebrowse-database (dir) | ||
| 97 | "Create an EBROSE database for directory DIR. | ||
| 98 | The database file is stored in ~/.semanticdb, or whichever directory | ||
| 99 | is specified by `semanticdb-default-save-directory'." | ||
| 100 | (interactive "DDirectory: ") | ||
| 101 | (setq dir (file-name-as-directory dir)) ;; for / on end | ||
| 102 | (let* ((savein (semanticdb-ebrowse-file-for-directory dir)) | ||
| 103 | (filebuff (get-buffer-create "*SEMANTICDB EBROWSE TMP*")) | ||
| 104 | (files (directory-files (expand-file-name dir) t)) | ||
| 105 | (mma auto-mode-alist) | ||
| 106 | (regexp nil) | ||
| 107 | ) | ||
| 108 | ;; Create the input to the ebrowse command | ||
| 109 | (save-excursion | ||
| 110 | (set-buffer filebuff) | ||
| 111 | (buffer-disable-undo filebuff) | ||
| 112 | (setq default-directory (expand-file-name dir)) | ||
| 113 | |||
| 114 | ;;; @TODO - convert to use semanticdb-collect-matching-filenames | ||
| 115 | ;; to get the file names. | ||
| 116 | |||
| 117 | |||
| 118 | (mapcar (lambda (f) | ||
| 119 | (when (semanticdb-ebrowse-C-file-p f) | ||
| 120 | (insert f) | ||
| 121 | (insert "\n"))) | ||
| 122 | files) | ||
| 123 | ;; Cleanup the ebrowse output buffer. | ||
| 124 | (save-excursion | ||
| 125 | (set-buffer (get-buffer-create "*EBROWSE OUTPUT*")) | ||
| 126 | (erase-buffer)) | ||
| 127 | ;; Call the EBROWSE command. | ||
| 128 | (message "Creating ebrowse file: %s ..." savein) | ||
| 129 | (call-process-region (point-min) (point-max) | ||
| 130 | "ebrowse" nil "*EBROWSE OUTPUT*" nil | ||
| 131 | (concat "--output-file=" savein) | ||
| 132 | "--very-verbose") | ||
| 133 | ) | ||
| 134 | ;; Create a short LOADER program for loading in this database. | ||
| 135 | (let* ((lfn (concat savein "-load.el")) | ||
| 136 | (lf (find-file-noselect lfn))) | ||
| 137 | (save-excursion | ||
| 138 | (set-buffer lf) | ||
| 139 | (erase-buffer) | ||
| 140 | (insert "(semanticdb-ebrowse-load-helper \"" | ||
| 141 | (expand-file-name dir) | ||
| 142 | "\")\n") | ||
| 143 | (save-buffer) | ||
| 144 | (kill-buffer (current-buffer))) | ||
| 145 | (message "Creating ebrowse file: %s ... done" savein) | ||
| 146 | ;; Reload that database | ||
| 147 | (load lfn nil t) | ||
| 148 | ))) | ||
| 149 | |||
| 150 | (defun semanticdb-load-ebrowse-caches () | ||
| 151 | "Load all semanticdb controlled EBROWSE caches." | ||
| 152 | (interactive) | ||
| 153 | (let ((f (directory-files semanticdb-default-save-directory | ||
| 154 | t (concat semanticdb-ebrowse-default-file-name "-load.el$") t))) | ||
| 155 | (while f | ||
| 156 | (load (car f) nil t) | ||
| 157 | (setq f (cdr f))) | ||
| 158 | )) | ||
| 159 | |||
| 160 | (defun semanticdb-ebrowse-load-helper (directory) | ||
| 161 | "Create the semanticdb database via ebrowse for directory. | ||
| 162 | If DIRECTORY is found to be defunct, it won't load the DB, and will | ||
| 163 | warn instead." | ||
| 164 | (if (file-directory-p directory) | ||
| 165 | (semanticdb-create-database semanticdb-project-database-ebrowse | ||
| 166 | directory) | ||
| 167 | (let* ((BF (semanticdb-ebrowse-file-for-directory directory)) | ||
| 168 | (BFL (concat BF "-load.el")) | ||
| 169 | (BFLB (concat BF "-load.el~"))) | ||
| 170 | (save-window-excursion | ||
| 171 | (with-output-to-temp-buffer "*FILES TO DELETE*" | ||
| 172 | (princ "The following BROWSE files are obsolete.\n\n") | ||
| 173 | (princ BF) | ||
| 174 | (princ "\n") | ||
| 175 | (princ BFL) | ||
| 176 | (princ "\n") | ||
| 177 | (when (file-exists-p BFLB) | ||
| 178 | (princ BFLB) | ||
| 179 | (princ "\n")) | ||
| 180 | ) | ||
| 181 | (when (y-or-n-p (format | ||
| 182 | "Warning: Obsolete BROWSE file for: %s\nDelete? " | ||
| 183 | directory)) | ||
| 184 | (delete-file BF) | ||
| 185 | (delete-file BFL) | ||
| 186 | (when (file-exists-p BFLB) | ||
| 187 | (delete-file BFLB)) | ||
| 188 | ))))) | ||
| 189 | |||
| 190 | ;;; SEMANTIC Database related Code | ||
| 191 | ;;; Classes: | ||
| 192 | (defclass semanticdb-table-ebrowse (semanticdb-table) | ||
| 193 | ((major-mode :initform c++-mode) | ||
| 194 | (ebrowse-tree :initform nil | ||
| 195 | :initarg :ebrowse-tree | ||
| 196 | :documentation | ||
| 197 | "The raw ebrowse tree for this file." | ||
| 198 | ) | ||
| 199 | (global-extract :initform nil | ||
| 200 | :initarg :global-extract | ||
| 201 | :documentation | ||
| 202 | "Table of ebrowse tags specific to this file. | ||
| 203 | This table is compisited from the ebrowse *Globals* section.") | ||
| 204 | ) | ||
| 205 | "A table for returning search results from ebrowse.") | ||
| 206 | |||
| 207 | (defclass semanticdb-project-database-ebrowse | ||
| 208 | (semanticdb-project-database) | ||
| 209 | ((new-table-class :initform semanticdb-table-ebrowse | ||
| 210 | :type class | ||
| 211 | :documentation | ||
| 212 | "New tables created for this database are of this class.") | ||
| 213 | (system-include-p :initform nil | ||
| 214 | :initarg :system-include | ||
| 215 | :documentation | ||
| 216 | "Flag indicating this database represents a system include directory.") | ||
| 217 | (ebrowse-struct :initform nil | ||
| 218 | :initarg :ebrowse-struct | ||
| 219 | ) | ||
| 220 | ) | ||
| 221 | "Semantic Database deriving tags using the EBROWSE tool. | ||
| 222 | EBROWSE is a C/C++ parser for use with `ebrowse' Emacs program.") | ||
| 223 | |||
| 224 | ;JAVE this just instantiates a default empty ebrowse struct? | ||
| 225 | ; how would new instances wind up here? | ||
| 226 | ; the ebrowse class isnt singleton, unlike the emacs lisp one | ||
| 227 | (defvar-mode-local c++-mode semanticdb-project-system-databases | ||
| 228 | () | ||
| 229 | "Search Ebrowse for symbols.") | ||
| 230 | |||
| 231 | (defmethod semanticdb-needs-refresh-p ((table semanticdb-table-ebrowse)) | ||
| 232 | "EBROWSE database do not need to be refreshed. | ||
| 233 | |||
| 234 | JAVE: stub for needs-refresh, because, how do we know if BROWSE files | ||
| 235 | are out of date? | ||
| 236 | |||
| 237 | EML: Our database should probably remember the timestamp/checksum of | ||
| 238 | the most recently read EBROWSE file, and use that." | ||
| 239 | nil | ||
| 240 | ) | ||
| 241 | |||
| 242 | |||
| 243 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | ||
| 244 | |||
| 245 | |||
| 246 | |||
| 247 | ;;; EBROWSE code | ||
| 248 | ;; | ||
| 249 | ;; These routines deal with part of the ebrowse interface. | ||
| 250 | (defun semanticdb-ebrowse-file-for-directory (dir) | ||
| 251 | "Return the file name for DIR where the ebrowse BROWSE file is. | ||
| 252 | This file should reside in `semanticdb-default-save-directory'." | ||
| 253 | (let* ((semanticdb-default-save-directory | ||
| 254 | semanticdb-default-save-directory) | ||
| 255 | (B (semanticdb-file-name-directory | ||
| 256 | 'semanticdb-project-database-file | ||
| 257 | (concat (expand-file-name dir) | ||
| 258 | semanticdb-ebrowse-default-file-name))) | ||
| 259 | ) | ||
| 260 | B)) | ||
| 261 | |||
| 262 | (defun semanticdb-ebrowse-get-ebrowse-structure (dir) | ||
| 263 | "Return the ebrowse structure for directory DIR. | ||
| 264 | This assumes semantic manages the BROWSE files, so they are assumed to live | ||
| 265 | where semantic cache files live, depending on your settings. | ||
| 266 | |||
| 267 | For instance: /home/<username>/.semanticdb/!usr!include!BROWSE" | ||
| 268 | (let* ((B (semanticdb-ebrowse-file-for-directory dir)) | ||
| 269 | (buf (get-buffer-create "*semanticdb ebrowse*"))) | ||
| 270 | (message "semanticdb-ebrowse %s" B) | ||
| 271 | (when (file-exists-p B) | ||
| 272 | (set-buffer buf) | ||
| 273 | (buffer-disable-undo buf) | ||
| 274 | (erase-buffer) | ||
| 275 | (insert-file-contents B) | ||
| 276 | (let ((ans nil) | ||
| 277 | (efcn (symbol-function 'ebrowse-show-progress))) | ||
| 278 | (fset 'ebrowse-show-progress #'(lambda (&rest junk) nil)) | ||
| 279 | (unwind-protect ;; Protect against errors w/ ebrowse | ||
| 280 | (setq ans (list B (ebrowse-read))) | ||
| 281 | ;; These items must always happen | ||
| 282 | (erase-buffer) | ||
| 283 | (fset 'ebrowse-show-fcn efcn) | ||
| 284 | ) | ||
| 285 | ans)))) | ||
| 286 | |||
| 287 | ;;; Methods for creating a database or tables | ||
| 288 | ;; | ||
| 289 | (defmethod semanticdb-create-database :STATIC ((dbeC semanticdb-project-database-ebrowse) | ||
| 290 | directory) | ||
| 291 | "Create a new semantic database for DIRECTORY based on ebrowse. | ||
| 292 | If there is no database for DIRECTORY available, then | ||
| 293 | {not implemented yet} create one. Return nil if that is not possible." | ||
| 294 | ;; MAKE SURE THAT THE FILE LOADED DOESN'T ALREADY EXIST. | ||
| 295 | (let ((dbs semanticdb-database-list) | ||
| 296 | (found nil)) | ||
| 297 | (while (and (not found) dbs) | ||
| 298 | (when (semanticdb-project-database-ebrowse-p (car dbs)) | ||
| 299 | (when (string= (oref (car dbs) reference-directory) directory) | ||
| 300 | (setq found (car dbs)))) | ||
| 301 | (setq dbs (cdr dbs))) | ||
| 302 | ;;STATIC means DBE cant be used as object, only as a class | ||
| 303 | (let* ((ebrowse-data (semanticdb-ebrowse-get-ebrowse-structure directory)) | ||
| 304 | (dat (car (cdr ebrowse-data))) | ||
| 305 | (ebd (car dat)) | ||
| 306 | (db nil) | ||
| 307 | (default-directory directory) | ||
| 308 | ) | ||
| 309 | (if found | ||
| 310 | (setq db found) | ||
| 311 | (setq db (make-instance | ||
| 312 | dbeC | ||
| 313 | directory | ||
| 314 | :ebrowse-struct ebd | ||
| 315 | )) | ||
| 316 | (oset db reference-directory directory)) | ||
| 317 | |||
| 318 | ;; Once we recycle or make a new DB, refresh the | ||
| 319 | ;; contents from the BROWSE file. | ||
| 320 | (oset db tables nil) | ||
| 321 | ;; only possible after object creation, tables inited to nil. | ||
| 322 | (semanticdb-ebrowse-strip-trees db dat) | ||
| 323 | |||
| 324 | ;; Once our database is loaded, if we are a system DB, we | ||
| 325 | ;; add ourselves to the include list for C++. | ||
| 326 | (semantic-add-system-include directory 'c++-mode) | ||
| 327 | (semantic-add-system-include directory 'c-mode) | ||
| 328 | |||
| 329 | db))) | ||
| 330 | |||
| 331 | (defmethod semanticdb-ebrowse-strip-trees ((dbe semanticdb-project-database-ebrowse) | ||
| 332 | data) | ||
| 333 | "For the ebrowse database DBE, strip all tables from DATA." | ||
| 334 | ;JAVE what it actually seems to do is split the original tree in "tables" associated with files | ||
| 335 | ; im not sure it actually works: | ||
| 336 | ; the filename slot sometimes gets to be nil, | ||
| 337 | ; apparently for classes which definition cant be found, yet needs to be included in the tree | ||
| 338 | ; like library baseclasses | ||
| 339 | ; a file can define several classes | ||
| 340 | (let ((T (car (cdr data))));1st comes a header, then the tree | ||
| 341 | (while T | ||
| 342 | |||
| 343 | (let* ((tree (car T)) | ||
| 344 | (class (ebrowse-ts-class tree)); root class of tree | ||
| 345 | ;; Something funny going on with this file thing... | ||
| 346 | (filename (or (ebrowse-cs-source-file class) | ||
| 347 | (ebrowse-cs-file class))) | ||
| 348 | ) | ||
| 349 | (cond | ||
| 350 | ((ebrowse-globals-tree-p tree) | ||
| 351 | ;; We have the globals tree.. save this special. | ||
| 352 | (semanticdb-ebrowse-add-globals-to-table dbe tree) | ||
| 353 | ) | ||
| 354 | (t | ||
| 355 | ;; ebrowse will collect all the info from multiple files | ||
| 356 | ;; into one tree. Semantic wants all the bits to be tied | ||
| 357 | ;; into different files. We need to do a full dissociation | ||
| 358 | ;; into semantic parsable tables. | ||
| 359 | (semanticdb-ebrowse-add-tree-to-table dbe tree) | ||
| 360 | )) | ||
| 361 | (setq T (cdr T)))) | ||
| 362 | )) | ||
| 363 | |||
| 364 | ;;; Filename based methods | ||
| 365 | ;; | ||
| 366 | (defun semanticdb-ebrowse-add-globals-to-table (dbe tree) | ||
| 367 | "For database DBE, add the ebrowse TREE into the table." | ||
| 368 | (if (or (not (ebrowse-ts-p tree)) | ||
| 369 | (not (ebrowse-globals-tree-p tree))) | ||
| 370 | (signal 'wrong-type-argument (list 'ebrowse-ts-p tree))) | ||
| 371 | |||
| 372 | (let* ((class (ebrowse-ts-class tree)) | ||
| 373 | (fname (or (ebrowse-cs-source-file class) | ||
| 374 | (ebrowse-cs-file class) | ||
| 375 | ;; Not def'd here, assume our current | ||
| 376 | ;; file | ||
| 377 | (concat default-directory "/unknown-proxy.hh"))) | ||
| 378 | (vars (ebrowse-ts-member-functions tree)) | ||
| 379 | (fns (ebrowse-ts-member-variables tree)) | ||
| 380 | (toks nil) | ||
| 381 | ) | ||
| 382 | (while vars | ||
| 383 | (let ((nt (semantic-tag (ebrowse-ms-name (car vars)) | ||
| 384 | 'variable)) | ||
| 385 | (defpoint (ebrowse-bs-point class))) | ||
| 386 | (when defpoint | ||
| 387 | (semantic--tag-set-overlay nt | ||
| 388 | (vector defpoint defpoint))) | ||
| 389 | (setq toks (cons nt toks))) | ||
| 390 | (setq vars (cdr vars))) | ||
| 391 | (while fns | ||
| 392 | (let ((nt (semantic-tag (ebrowse-ms-name (car fns)) | ||
| 393 | 'function)) | ||
| 394 | (defpoint (ebrowse-bs-point class))) | ||
| 395 | (when defpoint | ||
| 396 | (semantic--tag-set-overlay nt | ||
| 397 | (vector defpoint defpoint))) | ||
| 398 | (setq toks (cons nt toks))) | ||
| 399 | (setq fns (cdr fns))) | ||
| 400 | |||
| 401 | )) | ||
| 402 | |||
| 403 | (defun semanticdb-ebrowse-add-tree-to-table (dbe tree &optional fname baseclasses) | ||
| 404 | "For database DBE, add the ebrowse TREE into the table for FNAME. | ||
| 405 | Optional argument BASECLASSES specifyies a baseclass to the tree being provided." | ||
| 406 | (if (not (ebrowse-ts-p tree)) | ||
| 407 | (signal 'wrong-type-argument (list 'ebrowse-ts-p tree))) | ||
| 408 | |||
| 409 | ;; Strategy overview: | ||
| 410 | ;; 1) Calculate the filename for this tree. | ||
| 411 | ;; 2) Find a matching namespace in TAB, or create a new one. | ||
| 412 | ;; 3) Fabricate a tag proxy for CLASS | ||
| 413 | ;; 4) Add it to the namespace | ||
| 414 | ;; 5) Add subclasses | ||
| 415 | |||
| 416 | ;; 1 - Find the filename | ||
| 417 | (if (not fname) | ||
| 418 | (setq fname (or (ebrowse-cs-source-file (ebrowse-ts-class tree)) | ||
| 419 | (ebrowse-cs-file (ebrowse-ts-class tree)) | ||
| 420 | ;; Not def'd here, assume our current | ||
| 421 | ;; file | ||
| 422 | (concat default-directory "/unknown-proxy.hh")))) | ||
| 423 | |||
| 424 | (let* ((tab (or (semanticdb-file-table dbe fname) | ||
| 425 | (semanticdb-create-table dbe fname))) | ||
| 426 | (class (ebrowse-ts-class tree)) | ||
| 427 | (scope (ebrowse-cs-scope class)) | ||
| 428 | (ns (when scope (cedet-split-string scope ":" t))) | ||
| 429 | (nst nil) | ||
| 430 | (cls nil) | ||
| 431 | ) | ||
| 432 | |||
| 433 | ;; 2 - Get the namespace tag | ||
| 434 | (when ns | ||
| 435 | (let ((taglst (if (slot-boundp tab 'tags) (oref tab tags) nil))) | ||
| 436 | (setq nst (semantic-find-first-tag-by-name (car ns) taglst)) | ||
| 437 | (when (not nst) | ||
| 438 | (setq nst (semantic-tag (car ns) 'type :type "namespace")) | ||
| 439 | (oset tab tags (cons nst taglst)) | ||
| 440 | ))) | ||
| 441 | |||
| 442 | ;; 3 - Create a proxy tg. | ||
| 443 | (setq cls (semantic-tag (ebrowse-cs-name class) | ||
| 444 | 'type | ||
| 445 | :type "class" | ||
| 446 | :superclasses baseclasses | ||
| 447 | :faux t | ||
| 448 | :filename fname | ||
| 449 | )) | ||
| 450 | (let ((defpoint (ebrowse-bs-point class))) | ||
| 451 | (when defpoint | ||
| 452 | (semantic--tag-set-overlay cls | ||
| 453 | (vector defpoint defpoint)))) | ||
| 454 | |||
| 455 | ;; 4 - add to namespace | ||
| 456 | (if nst | ||
| 457 | (semantic-tag-put-attribute | ||
| 458 | nst :members (cons cls (semantic-tag-get-attribute nst :members))) | ||
| 459 | (oset tab tags (cons cls (when (slot-boundp tab 'tags) | ||
| 460 | (oref tab tags))))) | ||
| 461 | |||
| 462 | ;; 5 - Subclasses | ||
| 463 | (let* ((subclass (ebrowse-ts-subclasses tree)) | ||
| 464 | (pname (ebrowse-cs-name class))) | ||
| 465 | (when (ebrowse-cs-scope class) | ||
| 466 | (setq pname (concat (mapconcat (lambda (a) a) (cdr ns) "::") "::" pname))) | ||
| 467 | |||
| 468 | (while subclass | ||
| 469 | (let* ((scc (ebrowse-ts-class (car subclass))) | ||
| 470 | (fname (or (ebrowse-cs-source-file scc) | ||
| 471 | (ebrowse-cs-file scc) | ||
| 472 | ;; Not def'd here, assume our current | ||
| 473 | ;; file | ||
| 474 | fname | ||
| 475 | ))) | ||
| 476 | (when fname | ||
| 477 | (semanticdb-ebrowse-add-tree-to-table | ||
| 478 | dbe (car subclass) fname pname))) | ||
| 479 | (setq subclass (cdr subclass)))) | ||
| 480 | )) | ||
| 481 | |||
| 482 | ;;; | ||
| 483 | ;; Overload for converting the simple faux tag into something better. | ||
| 484 | ;; | ||
| 485 | (defmethod semanticdb-normalize-tags ((obj semanticdb-table-ebrowse) tags) | ||
| 486 | "Convert in Ebrowse database OBJ a list of TAGS into a complete tag. | ||
| 487 | The default tag provided by searches exclude many features of a | ||
| 488 | semantic parsed tag. Look up the file for OBJ, and match TAGS | ||
| 489 | against a semantic parsed tag that has all the info needed, and | ||
| 490 | return that." | ||
| 491 | (let ((tagret nil) | ||
| 492 | ) | ||
| 493 | ;; SemanticDB will automatically create a regular database | ||
| 494 | ;; on top of the file just loaded by ebrowse during the set | ||
| 495 | ;; buffer. Fetch that table, and use it's tag list to look | ||
| 496 | ;; up the tag we just got, and thus turn it into a full semantic | ||
| 497 | ;; tag. | ||
| 498 | (while tags | ||
| 499 | (let ((tag (car tags))) | ||
| 500 | (save-excursion | ||
| 501 | (semanticdb-set-buffer obj) | ||
| 502 | (let ((ans nil)) | ||
| 503 | ;; Gee, it would be nice to do this, but ebrowse LIES. Oi. | ||
| 504 | (when (semantic-tag-with-position-p tag) | ||
| 505 | (goto-char (semantic-tag-start tag)) | ||
| 506 | (let ((foundtag (semantic-current-tag))) | ||
| 507 | ;; Make sure the discovered tag is the same as what we started with. | ||
| 508 | (when (string= (semantic-tag-name tag) | ||
| 509 | (semantic-tag-name foundtag)) | ||
| 510 | ;; We have a winner! | ||
| 511 | (setq ans foundtag)))) | ||
| 512 | ;; Sometimes ebrowse lies. Do a generic search | ||
| 513 | ;; to find it within this file. | ||
| 514 | (when (not ans) | ||
| 515 | ;; We might find multiple hits for this tag, and we have no way | ||
| 516 | ;; of knowing which one the user wanted. Return the first one. | ||
| 517 | (setq ans (semantic-deep-find-tags-by-name | ||
| 518 | (semantic-tag-name tag) | ||
| 519 | (semantic-fetch-tags)))) | ||
| 520 | (if (semantic-tag-p ans) | ||
| 521 | (setq tagret (cons ans tagret)) | ||
| 522 | (setq tagret (append ans tagret))) | ||
| 523 | )) | ||
| 524 | (setq tags (cdr tags)))) | ||
| 525 | tagret)) | ||
| 526 | |||
| 527 | (defmethod semanticdb-normalize-one-tag ((obj semanticdb-table-ebrowse) tag) | ||
| 528 | "Convert in Ebrowse database OBJ one TAG into a complete tag. | ||
| 529 | The default tag provided by searches exclude many features of a | ||
| 530 | semantic parsed tag. Look up the file for OBJ, and match TAG | ||
| 531 | against a semantic parsed tag that has all the info needed, and | ||
| 532 | return that." | ||
| 533 | (let ((tagret nil) | ||
| 534 | (objret nil)) | ||
| 535 | ;; SemanticDB will automatically create a regular database | ||
| 536 | ;; on top of the file just loaded by ebrowse during the set | ||
| 537 | ;; buffer. Fetch that table, and use it's tag list to look | ||
| 538 | ;; up the tag we just got, and thus turn it into a full semantic | ||
| 539 | ;; tag. | ||
| 540 | (save-excursion | ||
| 541 | (semanticdb-set-buffer obj) | ||
| 542 | (setq objret semanticdb-current-table) | ||
| 543 | (when (not objret) | ||
| 544 | ;; What to do?? | ||
| 545 | (debug)) | ||
| 546 | (let ((ans nil)) | ||
| 547 | ;; Gee, it would be nice to do this, but ebrowse LIES. Oi. | ||
| 548 | (when (semantic-tag-with-position-p tag) | ||
| 549 | (goto-char (semantic-tag-start tag)) | ||
| 550 | (let ((foundtag (semantic-current-tag))) | ||
| 551 | ;; Make sure the discovered tag is the same as what we started with. | ||
| 552 | (when (string= (semantic-tag-name tag) | ||
| 553 | (semantic-tag-name foundtag)) | ||
| 554 | ;; We have a winner! | ||
| 555 | (setq ans foundtag)))) | ||
| 556 | ;; Sometimes ebrowse lies. Do a generic search | ||
| 557 | ;; to find it within this file. | ||
| 558 | (when (not ans) | ||
| 559 | ;; We might find multiple hits for this tag, and we have no way | ||
| 560 | ;; of knowing which one the user wanted. Return the first one. | ||
| 561 | (setq ans (semantic-deep-find-tags-by-name | ||
| 562 | (semantic-tag-name tag) | ||
| 563 | (semantic-fetch-tags)))) | ||
| 564 | (if (semantic-tag-p ans) | ||
| 565 | (setq tagret ans) | ||
| 566 | (setq tagret (car ans))) | ||
| 567 | )) | ||
| 568 | (cons objret tagret))) | ||
| 569 | |||
| 570 | ;;; Search Overrides | ||
| 571 | ;; | ||
| 572 | ;; NOTE WHEN IMPLEMENTING: Be sure to add doc-string updates explaining | ||
| 573 | ;; how your new search routines are implemented. | ||
| 574 | ;; | ||
| 575 | (defmethod semanticdb-find-tags-by-name-method | ||
| 576 | ((table semanticdb-table-ebrowse) name &optional tags) | ||
| 577 | "Find all tags named NAME in TABLE. | ||
| 578 | Return a list of tags." | ||
| 579 | ;;(message "semanticdb-find-tags-by-name-method name -- %s" name) | ||
| 580 | (if tags | ||
| 581 | ;; If TAGS are passed in, then we don't need to do work here. | ||
| 582 | (call-next-method) | ||
| 583 | ;; If we ever need to do something special, add here. | ||
| 584 | ;; Since ebrowse tags are converted into semantic tags, we can | ||
| 585 | ;; get away with this sort of thing. | ||
| 586 | (call-next-method) | ||
| 587 | ) | ||
| 588 | ) | ||
| 589 | |||
| 590 | (defmethod semanticdb-find-tags-by-name-regexp-method | ||
| 591 | ((table semanticdb-table-ebrowse) regex &optional tags) | ||
| 592 | "Find all tags with name matching REGEX in TABLE. | ||
| 593 | Optional argument TAGS is a list of tags to search. | ||
| 594 | Return a list of tags." | ||
| 595 | (if tags (call-next-method) | ||
| 596 | ;; YOUR IMPLEMENTATION HERE | ||
| 597 | (call-next-method) | ||
| 598 | )) | ||
| 599 | |||
| 600 | (defmethod semanticdb-find-tags-for-completion-method | ||
| 601 | ((table semanticdb-table-ebrowse) prefix &optional tags) | ||
| 602 | "In TABLE, find all occurances of tags matching PREFIX. | ||
| 603 | Optional argument TAGS is a list of tags to search. | ||
| 604 | Returns a table of all matching tags." | ||
| 605 | (if tags (call-next-method) | ||
| 606 | ;; YOUR IMPLEMENTATION HERE | ||
| 607 | (call-next-method) | ||
| 608 | )) | ||
| 609 | |||
| 610 | (defmethod semanticdb-find-tags-by-class-method | ||
| 611 | ((table semanticdb-table-ebrowse) class &optional tags) | ||
| 612 | "In TABLE, find all occurances of tags of CLASS. | ||
| 613 | Optional argument TAGS is a list of tags to search. | ||
| 614 | Returns a table of all matching tags." | ||
| 615 | (if tags (call-next-method) | ||
| 616 | (call-next-method))) | ||
| 617 | |||
| 618 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | ||
| 619 | |||
| 620 | ;;; Deep Searches | ||
| 621 | ;; | ||
| 622 | ;; If your language does not have a `deep' concept, these can be left | ||
| 623 | ;; alone, otherwise replace with implementations similar to those | ||
| 624 | ;; above. | ||
| 625 | ;; | ||
| 626 | |||
| 627 | (defmethod semanticdb-deep-find-tags-by-name-method | ||
| 628 | ((table semanticdb-table-ebrowse) name &optional tags) | ||
| 629 | "Find all tags name NAME in TABLE. | ||
| 630 | Optional argument TAGS is a list of tags t | ||
| 631 | Like `semanticdb-find-tags-by-name-method' for ebrowse." | ||
| 632 | ;;(semanticdb-find-tags-by-name-method table name tags) | ||
| 633 | (call-next-method)) | ||
| 634 | |||
| 635 | (defmethod semanticdb-deep-find-tags-by-name-regexp-method | ||
| 636 | ((table semanticdb-table-ebrowse) regex &optional tags) | ||
| 637 | "Find all tags with name matching REGEX in TABLE. | ||
| 638 | Optional argument TAGS is a list of tags to search. | ||
| 639 | Like `semanticdb-find-tags-by-name-method' for ebrowse." | ||
| 640 | ;;(semanticdb-find-tags-by-name-regexp-method table regex tags) | ||
| 641 | (call-next-method)) | ||
| 642 | |||
| 643 | (defmethod semanticdb-deep-find-tags-for-completion-method | ||
| 644 | ((table semanticdb-table-ebrowse) prefix &optional tags) | ||
| 645 | "In TABLE, find all occurances of tags matching PREFIX. | ||
| 646 | Optional argument TAGS is a list of tags to search. | ||
| 647 | Like `semanticdb-find-tags-for-completion-method' for ebrowse." | ||
| 648 | ;;(semanticdb-find-tags-for-completion-method table prefix tags) | ||
| 649 | (call-next-method)) | ||
| 650 | |||
| 651 | ;;; Advanced Searches | ||
| 652 | ;; | ||
| 653 | (defmethod semanticdb-find-tags-external-children-of-type-method | ||
| 654 | ((table semanticdb-table-ebrowse) type &optional tags) | ||
| 655 | "Find all nonterminals which are child elements of TYPE | ||
| 656 | Optional argument TAGS is a list of tags to search. | ||
| 657 | Return a list of tags." | ||
| 658 | (if tags (call-next-method) | ||
| 659 | ;; Ebrowse collects all this type of stuff together for us. | ||
| 660 | ;; but we can't use it.... yet. | ||
| 661 | nil | ||
| 662 | )) | ||
| 663 | |||
| 664 | ;;; TESTING | ||
| 665 | ;; | ||
| 666 | ;; This is a complex bit of stuff. Here are some tests for the | ||
| 667 | ;; system. | ||
| 668 | |||
| 669 | (defun semanticdb-ebrowse-run-tests () | ||
| 670 | "Run some tests of the semanticdb-ebrowse system. | ||
| 671 | All systems are different. Ask questions along the way." | ||
| 672 | (interactive) | ||
| 673 | (let ((doload nil)) | ||
| 674 | (when (y-or-n-p "Create a system database to test with? ") | ||
| 675 | (call-interactively 'semanticdb-create-ebrowse-database) | ||
| 676 | (setq doload t)) | ||
| 677 | ;; Should we load in caches | ||
| 678 | (when (if doload | ||
| 679 | (y-or-n-p "New database created. Reload system databases? ") | ||
| 680 | (y-or-n-p "Load in all system databases? ")) | ||
| 681 | (semanticdb-load-ebrowse-caches))) | ||
| 682 | ;; Ok, databases were creatd. Lets try some searching. | ||
| 683 | (when (not (or (eq major-mode 'c-mode) | ||
| 684 | (eq major-mode 'c++-mode))) | ||
| 685 | (error "Please make your default buffer be a C or C++ file, then | ||
| 686 | run the test again..") | ||
| 687 | ) | ||
| 688 | |||
| 689 | ) | ||
| 690 | |||
| 691 | (defun semanticdb-ebrowse-dump () | ||
| 692 | "Find the first loaded ebrowse table, and dump out the contents." | ||
| 693 | (interactive) | ||
| 694 | (let ((db semanticdb-database-list) | ||
| 695 | (ab nil)) | ||
| 696 | (while db | ||
| 697 | (when (semanticdb-project-database-ebrowse-p (car db)) | ||
| 698 | (setq ab (data-debug-new-buffer "*EBROWSE Database*")) | ||
| 699 | (data-debug-insert-thing (car db) "*" "") | ||
| 700 | (setq db nil) | ||
| 701 | ) | ||
| 702 | (setq db (cdr db))))) | ||
| 703 | |||
| 704 | (provide 'semantic/db-ebrowse) | ||
| 705 | |||
| 706 | ;;; semanticdb-ebrowse.el ends here | ||
diff --git a/lisp/cedet/semantic/db-el.el b/lisp/cedet/semantic/db-el.el new file mode 100644 index 00000000000..3db6c15570e --- /dev/null +++ b/lisp/cedet/semantic/db-el.el | |||
| @@ -0,0 +1,343 @@ | |||
| 1 | ;;; db-el.el --- Semantic database extensions for Emacs Lisp | ||
| 2 | |||
| 3 | ;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 | ||
| 4 | ;;; Free Software Foundation, Inc. | ||
| 5 | |||
| 6 | ;; Author: Eric M. Ludlam <zappo@gnu.org> | ||
| 7 | ;; Keywords: tags | ||
| 8 | |||
| 9 | ;; This file is part of GNU Emacs. | ||
| 10 | |||
| 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
| 12 | ;; it under the terms of the GNU General Public License as published by | ||
| 13 | ;; the Free Software Foundation, either version 3 of the License, or | ||
| 14 | ;; (at your option) any later version. | ||
| 15 | |||
| 16 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 19 | ;; GNU General Public License for more details. | ||
| 20 | |||
| 21 | ;; You should have received a copy of the GNU General Public License | ||
| 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | ||
| 23 | |||
| 24 | ;;; Commentary: | ||
| 25 | ;; | ||
| 26 | ;; There are a lot of Emacs Lisp functions and variables available for | ||
| 27 | ;; the asking. This adds on to the semanticdb programming interface to | ||
| 28 | ;; allow all loaded Emacs Lisp functions to be queried via semanticdb. | ||
| 29 | ;; | ||
| 30 | ;; This allows you to use programs written for Semantic using the database | ||
| 31 | ;; to also work in Emacs Lisp with no compromises. | ||
| 32 | ;; | ||
| 33 | |||
| 34 | (require 'semantic/db-search) | ||
| 35 | (eval-when-compile | ||
| 36 | ;; For generic function searching. | ||
| 37 | (require 'eieio) | ||
| 38 | (require 'eieio-opt) | ||
| 39 | (require 'eieio-base) | ||
| 40 | ) | ||
| 41 | ;;; Code: | ||
| 42 | |||
| 43 | ;;; Classes: | ||
| 44 | (defclass semanticdb-table-emacs-lisp (semanticdb-abstract-table) | ||
| 45 | ((major-mode :initform emacs-lisp-mode) | ||
| 46 | ) | ||
| 47 | "A table for returning search results from Emacs.") | ||
| 48 | |||
| 49 | (defmethod semanticdb-refresh-table ((obj semanticdb-table-emacs-lisp) &optional force) | ||
| 50 | "Do not refresh Emacs Lisp table. | ||
| 51 | It does not need refreshing." | ||
| 52 | nil) | ||
| 53 | |||
| 54 | (defmethod semanticdb-needs-refresh-p ((obj semanticdb-table-emacs-lisp)) | ||
| 55 | "Return nil, we never need a refresh." | ||
| 56 | nil) | ||
| 57 | |||
| 58 | (defclass semanticdb-project-database-emacs-lisp | ||
| 59 | (semanticdb-project-database eieio-singleton) | ||
| 60 | ((new-table-class :initform semanticdb-table-emacs-lisp | ||
| 61 | :type class | ||
| 62 | :documentation | ||
| 63 | "New tables created for this database are of this class.") | ||
| 64 | ) | ||
| 65 | "Database representing Emacs core.") | ||
| 66 | |||
| 67 | ;; Create the database, and add it to searchable databases for Emacs Lisp mode. | ||
| 68 | (defvar-mode-local emacs-lisp-mode semanticdb-project-system-databases | ||
| 69 | (list | ||
| 70 | (semanticdb-project-database-emacs-lisp "Emacs")) | ||
| 71 | "Search Emacs core for symbols.") | ||
| 72 | |||
| 73 | (defvar-mode-local emacs-lisp-mode semanticdb-find-default-throttle | ||
| 74 | '(project omniscience) | ||
| 75 | "Search project files, then search this omniscience database. | ||
| 76 | It is not necessary to to system or recursive searching because of | ||
| 77 | the omniscience database.") | ||
| 78 | |||
| 79 | ;;; Filename based methods | ||
| 80 | ;; | ||
| 81 | (defmethod semanticdb-get-database-tables ((obj semanticdb-project-database-emacs-lisp)) | ||
| 82 | "For an Emacs Lisp database, there are no explicit tables. | ||
| 83 | Create one of our special tables that can act as an intermediary." | ||
| 84 | ;; We need to return something since there is always the "master table" | ||
| 85 | ;; The table can then answer file name type questions. | ||
| 86 | (when (not (slot-boundp obj 'tables)) | ||
| 87 | (let ((newtable (semanticdb-table-emacs-lisp "Emacs System Table"))) | ||
| 88 | (oset obj tables (list newtable)) | ||
| 89 | (oset newtable parent-db obj) | ||
| 90 | (oset newtable tags nil) | ||
| 91 | )) | ||
| 92 | (call-next-method)) | ||
| 93 | |||
| 94 | (defmethod semanticdb-file-table ((obj semanticdb-project-database-emacs-lisp) filename) | ||
| 95 | "From OBJ, return FILENAME's associated table object. | ||
| 96 | For Emacs Lisp, creates a specialized table." | ||
| 97 | (car (semanticdb-get-database-tables obj)) | ||
| 98 | ) | ||
| 99 | |||
| 100 | (defmethod semanticdb-get-tags ((table semanticdb-table-emacs-lisp )) | ||
| 101 | "Return the list of tags belonging to TABLE." | ||
| 102 | ;; specialty table ? Probably derive tags at request time. | ||
| 103 | nil) | ||
| 104 | |||
| 105 | (defmethod semanticdb-equivalent-mode ((table semanticdb-table-emacs-lisp) &optional buffer) | ||
| 106 | "Return non-nil if TABLE's mode is equivalent to BUFFER. | ||
| 107 | Equivalent modes are specified by by `semantic-equivalent-major-modes' | ||
| 108 | local variable." | ||
| 109 | (save-excursion | ||
| 110 | (set-buffer buffer) | ||
| 111 | (eq (or mode-local-active-mode major-mode) 'emacs-lisp-mode))) | ||
| 112 | |||
| 113 | (defmethod semanticdb-full-filename ((obj semanticdb-table-emacs-lisp)) | ||
| 114 | "Fetch the full filename that OBJ refers to. | ||
| 115 | For Emacs Lisp system DB, there isn't one." | ||
| 116 | nil) | ||
| 117 | |||
| 118 | ;;; Conversion | ||
| 119 | ;; | ||
| 120 | (defmethod semanticdb-normalize-tags ((obj semanticdb-table-emacs-lisp) tags) | ||
| 121 | "Convert tags, originating from Emacs OBJ, into standardized form." | ||
| 122 | (let ((newtags nil)) | ||
| 123 | (dolist (T tags) | ||
| 124 | (let* ((ot (semanticdb-normalize-one-tag obj T)) | ||
| 125 | (tag (cdr ot))) | ||
| 126 | (setq newtags (cons tag newtags)))) | ||
| 127 | ;; There is no promise to have files associated. | ||
| 128 | (nreverse newtags))) | ||
| 129 | |||
| 130 | (defmethod semanticdb-normalize-one-tag ((obj semanticdb-table-emacs-lisp) tag) | ||
| 131 | "Convert one TAG, originating from Emacs OBJ, into standardized form. | ||
| 132 | If Emacs cannot resolve this symbol to a particular file, then return nil." | ||
| 133 | ;; Here's the idea. For each tag, get the name, then use | ||
| 134 | ;; Emacs' `symbol-file' to get the source. Once we have that, | ||
| 135 | ;; we can use more typical semantic searching techniques to | ||
| 136 | ;; get a regularly parsed tag. | ||
| 137 | (let* ((type (cond ((semantic-tag-of-class-p tag 'function) | ||
| 138 | 'defun) | ||
| 139 | ((semantic-tag-of-class-p tag 'variable) | ||
| 140 | 'defvar) | ||
| 141 | )) | ||
| 142 | (sym (intern (semantic-tag-name tag))) | ||
| 143 | (file (condition-case err | ||
| 144 | (symbol-file sym type) | ||
| 145 | ;; Older [X]Emacs don't have a 2nd argument. | ||
| 146 | (error (symbol-file sym)))) | ||
| 147 | ) | ||
| 148 | (if (or (not file) (not (file-exists-p file))) | ||
| 149 | ;; The file didn't exist. Return nil. | ||
| 150 | ;; We can't normalize this tag. Fake it out. | ||
| 151 | (cons obj tag) | ||
| 152 | (when (string-match "\\.elc" file) | ||
| 153 | (setq file (concat (file-name-sans-extension file) | ||
| 154 | ".el")) | ||
| 155 | (when (and (not (file-exists-p file)) | ||
| 156 | (file-exists-p (concat file ".gz"))) | ||
| 157 | ;; Is it a .gz file? | ||
| 158 | (setq file (concat file ".gz")))) | ||
| 159 | |||
| 160 | (let* ((tab (semanticdb-file-table-object file)) | ||
| 161 | (alltags (semanticdb-get-tags tab)) | ||
| 162 | (newtags (semanticdb-find-tags-by-name-method | ||
| 163 | tab (semantic-tag-name tag))) | ||
| 164 | (match nil)) | ||
| 165 | ;; Find the best match. | ||
| 166 | (dolist (T newtags) | ||
| 167 | (when (semantic-tag-similar-p T tag) | ||
| 168 | (setq match T))) | ||
| 169 | ;; Backup system. | ||
| 170 | (when (not match) | ||
| 171 | (setq match (car newtags))) | ||
| 172 | ;; Return it. | ||
| 173 | (cons tab match))))) | ||
| 174 | |||
| 175 | (defun semanticdb-elisp-sym-function-arglist (sym) | ||
| 176 | "Get the argument list for SYM. | ||
| 177 | Deal with all different forms of function. | ||
| 178 | This was snarfed out of eldoc." | ||
| 179 | (let* ((prelim-def | ||
| 180 | (let ((sd (and (fboundp sym) | ||
| 181 | (symbol-function sym)))) | ||
| 182 | (and (symbolp sd) | ||
| 183 | (condition-case err | ||
| 184 | (setq sd (indirect-function sym)) | ||
| 185 | (error (setq sd nil)))) | ||
| 186 | sd)) | ||
| 187 | (def (if (eq (car-safe prelim-def) 'macro) | ||
| 188 | (cdr prelim-def) | ||
| 189 | prelim-def)) | ||
| 190 | (arglist (cond ((null def) nil) | ||
| 191 | ((byte-code-function-p def) | ||
| 192 | ;; This is an eieio compatibility function. | ||
| 193 | ;; We depend on EIEIO, so use this. | ||
| 194 | (eieio-compiled-function-arglist def)) | ||
| 195 | ((eq (car-safe def) 'lambda) | ||
| 196 | (nth 1 def)) | ||
| 197 | (t nil)))) | ||
| 198 | arglist)) | ||
| 199 | |||
| 200 | (defun semanticdb-elisp-sym->tag (sym &optional toktype) | ||
| 201 | "Convert SYM into a semantic tag. | ||
| 202 | TOKTYPE is a hint to the type of tag desired." | ||
| 203 | (if (stringp sym) | ||
| 204 | (setq sym (intern-soft sym))) | ||
| 205 | (when sym | ||
| 206 | (cond ((and (eq toktype 'function) (fboundp sym)) | ||
| 207 | (semantic-tag-new-function | ||
| 208 | (symbol-name sym) | ||
| 209 | nil ;; return type | ||
| 210 | (semantic-elisp-desymbolify | ||
| 211 | (semanticdb-elisp-sym-function-arglist sym)) ;; arg-list | ||
| 212 | :user-visible-flag (condition-case nil | ||
| 213 | (interactive-form sym) | ||
| 214 | (error nil)) | ||
| 215 | )) | ||
| 216 | ((and (eq toktype 'variable) (boundp sym)) | ||
| 217 | (semantic-tag-new-variable | ||
| 218 | (symbol-name sym) | ||
| 219 | nil ;; type | ||
| 220 | nil ;; value - ignore for now | ||
| 221 | )) | ||
| 222 | ((and (eq toktype 'type) (class-p sym)) | ||
| 223 | (semantic-tag-new-type | ||
| 224 | (symbol-name sym) | ||
| 225 | "class" | ||
| 226 | (semantic-elisp-desymbolify | ||
| 227 | (aref (class-v semanticdb-project-database) | ||
| 228 | class-public-a)) ;; slots | ||
| 229 | (semantic-elisp-desymbolify (class-parents sym)) ;; parents | ||
| 230 | )) | ||
| 231 | ((not toktype) | ||
| 232 | ;; Figure it out on our own. | ||
| 233 | (cond ((class-p sym) | ||
| 234 | (semanticdb-elisp-sym->tag sym 'type)) | ||
| 235 | ((fboundp sym) | ||
| 236 | (semanticdb-elisp-sym->tag sym 'function)) | ||
| 237 | ((boundp sym) | ||
| 238 | (semanticdb-elisp-sym->tag sym 'variable)) | ||
| 239 | (t nil)) | ||
| 240 | ) | ||
| 241 | (t nil)))) | ||
| 242 | |||
| 243 | ;;; Search Overrides | ||
| 244 | ;; | ||
| 245 | (defvar semanticdb-elisp-mapatom-collector nil | ||
| 246 | "Variable used to collect mapatoms output.") | ||
| 247 | |||
| 248 | (defmethod semanticdb-find-tags-by-name-method | ||
| 249 | ((table semanticdb-table-emacs-lisp) name &optional tags) | ||
| 250 | "Find all tags name NAME in TABLE. | ||
| 251 | Uses `inter-soft' to match NAME to emacs symbols. | ||
| 252 | Return a list of tags." | ||
| 253 | (if tags (call-next-method) | ||
| 254 | ;; No need to search. Use `intern-soft' which does the same thing for us. | ||
| 255 | (let* ((sym (intern-soft name)) | ||
| 256 | (fun (semanticdb-elisp-sym->tag sym 'function)) | ||
| 257 | (var (semanticdb-elisp-sym->tag sym 'variable)) | ||
| 258 | (typ (semanticdb-elisp-sym->tag sym 'type)) | ||
| 259 | (taglst nil) | ||
| 260 | ) | ||
| 261 | (when (or fun var typ) | ||
| 262 | ;; If the symbol is any of these things, build the search table. | ||
| 263 | (when var (setq taglst (cons var taglst))) | ||
| 264 | (when typ (setq taglst (cons typ taglst))) | ||
| 265 | (when fun (setq taglst (cons fun taglst))) | ||
| 266 | taglst | ||
| 267 | )))) | ||
| 268 | |||
| 269 | (defmethod semanticdb-find-tags-by-name-regexp-method | ||
| 270 | ((table semanticdb-table-emacs-lisp) regex &optional tags) | ||
| 271 | "Find all tags with name matching REGEX in TABLE. | ||
| 272 | Optional argument TAGS is a list of tags to search. | ||
| 273 | Uses `apropos-internal' to find matches. | ||
| 274 | Return a list of tags." | ||
| 275 | (if tags (call-next-method) | ||
| 276 | (delq nil (mapcar 'semanticdb-elisp-sym->tag | ||
| 277 | (apropos-internal regex))))) | ||
| 278 | |||
| 279 | (defmethod semanticdb-find-tags-for-completion-method | ||
| 280 | ((table semanticdb-table-emacs-lisp) prefix &optional tags) | ||
| 281 | "In TABLE, find all occurances of tags matching PREFIX. | ||
| 282 | Optional argument TAGS is a list of tags to search. | ||
| 283 | Returns a table of all matching tags." | ||
| 284 | (if tags (call-next-method) | ||
| 285 | (delq nil (mapcar 'semanticdb-elisp-sym->tag | ||
| 286 | (all-completions prefix obarray))))) | ||
| 287 | |||
| 288 | (defmethod semanticdb-find-tags-by-class-method | ||
| 289 | ((table semanticdb-table-emacs-lisp) class &optional tags) | ||
| 290 | "In TABLE, find all occurances of tags of CLASS. | ||
| 291 | Optional argument TAGS is a list of tags to search. | ||
| 292 | Returns a table of all matching tags." | ||
| 293 | (if tags (call-next-method) | ||
| 294 | ;; We could implement this, but it could be messy. | ||
| 295 | nil)) | ||
| 296 | |||
| 297 | ;;; Deep Searches | ||
| 298 | ;; | ||
| 299 | ;; For Emacs Lisp deep searches are like top level searches. | ||
| 300 | (defmethod semanticdb-deep-find-tags-by-name-method | ||
| 301 | ((table semanticdb-table-emacs-lisp) name &optional tags) | ||
| 302 | "Find all tags name NAME in TABLE. | ||
| 303 | Optional argument TAGS is a list of tags to search. | ||
| 304 | Like `semanticdb-find-tags-by-name-method' for Emacs Lisp." | ||
| 305 | (semanticdb-find-tags-by-name-method table name tags)) | ||
| 306 | |||
| 307 | (defmethod semanticdb-deep-find-tags-by-name-regexp-method | ||
| 308 | ((table semanticdb-table-emacs-lisp) regex &optional tags) | ||
| 309 | "Find all tags with name matching REGEX in TABLE. | ||
| 310 | Optional argument TAGS is a list of tags to search. | ||
| 311 | Like `semanticdb-find-tags-by-name-method' for Emacs Lisp." | ||
| 312 | (semanticdb-find-tags-by-name-regexp-method table regex tags)) | ||
| 313 | |||
| 314 | (defmethod semanticdb-deep-find-tags-for-completion-method | ||
| 315 | ((table semanticdb-table-emacs-lisp) prefix &optional tags) | ||
| 316 | "In TABLE, find all occurances of tags matching PREFIX. | ||
| 317 | Optional argument TAGS is a list of tags to search. | ||
| 318 | Like `semanticdb-find-tags-for-completion-method' for Emacs Lisp." | ||
| 319 | (semanticdb-find-tags-for-completion-method table prefix tags)) | ||
| 320 | |||
| 321 | ;;; Advanced Searches | ||
| 322 | ;; | ||
| 323 | (defmethod semanticdb-find-tags-external-children-of-type-method | ||
| 324 | ((table semanticdb-table-emacs-lisp) type &optional tags) | ||
| 325 | "Find all nonterminals which are child elements of TYPE | ||
| 326 | Optional argument TAGS is a list of tags to search. | ||
| 327 | Return a list of tags." | ||
| 328 | (if tags (call-next-method) | ||
| 329 | ;; EIEIO is the only time this matters | ||
| 330 | (when (featurep 'eieio) | ||
| 331 | (let* ((class (intern-soft type)) | ||
| 332 | (taglst (when class | ||
| 333 | (delq nil | ||
| 334 | (mapcar 'semanticdb-elisp-sym->tag | ||
| 335 | ;; Fancy eieio function that knows all about | ||
| 336 | ;; built in methods belonging to CLASS. | ||
| 337 | (eieio-all-generic-functions class))))) | ||
| 338 | ) | ||
| 339 | taglst)))) | ||
| 340 | |||
| 341 | (provide 'semantic/db-el) | ||
| 342 | |||
| 343 | ;;; semanticdb-el.el ends here | ||
diff --git a/lisp/cedet/semantic/db-file.el b/lisp/cedet/semantic/db-file.el new file mode 100644 index 00000000000..a16f9bbf14a --- /dev/null +++ b/lisp/cedet/semantic/db-file.el | |||
| @@ -0,0 +1,438 @@ | |||
| 1 | ;;; db-file.el --- Save a semanticdb to a cache file. | ||
| 2 | |||
| 3 | ;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009 | ||
| 4 | ;;; Free Software Foundation, Inc. | ||
| 5 | |||
| 6 | ;; Author: Eric M. Ludlam <zappo@gnu.org> | ||
| 7 | ;; Keywords: tags | ||
| 8 | |||
| 9 | ;; This file is part of GNU Emacs. | ||
| 10 | |||
| 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
| 12 | ;; it under the terms of the GNU General Public License as published by | ||
| 13 | ;; the Free Software Foundation, either version 3 of the License, or | ||
| 14 | ;; (at your option) any later version. | ||
| 15 | |||
| 16 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 19 | ;; GNU General Public License for more details. | ||
| 20 | |||
| 21 | ;; You should have received a copy of the GNU General Public License | ||
| 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | ||
| 23 | |||
| 24 | ;;; Commentary: | ||
| 25 | ;; | ||
| 26 | ;; A set of semanticdb classes for persistently saving caches on disk. | ||
| 27 | ;; | ||
| 28 | |||
| 29 | (require 'semantic) | ||
| 30 | (require 'semantic/db) | ||
| 31 | (require 'cedet-files) | ||
| 32 | |||
| 33 | (defvar semanticdb-file-version semantic-version | ||
| 34 | "Version of semanticdb we are writing files to disk with.") | ||
| 35 | (defvar semanticdb-file-incompatible-version "1.4" | ||
| 36 | "Version of semanticdb we are not reverse compatible with.") | ||
| 37 | |||
| 38 | ;;; Settings | ||
| 39 | ;; | ||
| 40 | (defcustom semanticdb-default-file-name "semantic.cache" | ||
| 41 | "*File name of the semantic tag cache." | ||
| 42 | :group 'semanticdb | ||
| 43 | :type 'string) | ||
| 44 | |||
| 45 | (defcustom semanticdb-default-save-directory (expand-file-name "~/.semanticdb") | ||
| 46 | "*Directory name where semantic cache files are stored. | ||
| 47 | If this value is nil, files are saved in the current directory. If the value | ||
| 48 | is a valid directory, then it overrides `semanticdb-default-file-name' and | ||
| 49 | stores caches in a coded file name in this directory." | ||
| 50 | :group 'semanticdb | ||
| 51 | :type '(choice :tag "Default-Directory" | ||
| 52 | :menu-tag "Default-Directory" | ||
| 53 | (const :tag "Use current directory" :value nil) | ||
| 54 | (directory))) | ||
| 55 | |||
| 56 | (defcustom semanticdb-persistent-path '(always) | ||
| 57 | "*List of valid paths that semanticdb will cache tags to. | ||
| 58 | When `global-semanticdb-minor-mode' is active, tag lists will | ||
| 59 | be saved to disk when Emacs exits. Not all directories will have | ||
| 60 | tags that should be saved. | ||
| 61 | The value should be a list of valid paths. A path can be a string, | ||
| 62 | indicating a directory in which to save a variable. An element in the | ||
| 63 | list can also be a symbol. Valid symbols are `never', which will | ||
| 64 | disable any saving anywhere, `always', which enables saving | ||
| 65 | everywhere, or `project', which enables saving in any directory that | ||
| 66 | passes a list of predicates in `semanticdb-project-predicate-functions'." | ||
| 67 | :group 'semanticdb | ||
| 68 | :type nil) | ||
| 69 | |||
| 70 | (defcustom semanticdb-save-database-hooks nil | ||
| 71 | "*Hooks run after a database is saved. | ||
| 72 | Each function is called with one argument, the object representing | ||
| 73 | the database recently written." | ||
| 74 | :group 'semanticdb | ||
| 75 | :type 'hook) | ||
| 76 | |||
| 77 | (defvar semanticdb-dir-sep-char (if (boundp 'directory-sep-char) | ||
| 78 | (symbol-value 'directory-sep-char) | ||
| 79 | ?/) | ||
| 80 | "Character used for directory separation. | ||
| 81 | Obsoleted in some versions of Emacs. Needed in others. | ||
| 82 | NOTE: This should get deleted from semantic soon.") | ||
| 83 | |||
| 84 | (defun semanticdb-fix-pathname (dir) | ||
| 85 | "If DIR is broken, fix it. | ||
| 86 | Force DIR to end with a /. | ||
| 87 | Note: Same as `file-name-as-directory'. | ||
| 88 | NOTE: This should get deleted from semantic soon." | ||
| 89 | (file-name-as-directory dir)) | ||
| 90 | ;; I didn't initially know about the above fcn. Keep the below as a | ||
| 91 | ;; reference. Delete it someday once I've proven everything is the same. | ||
| 92 | ;; (if (not (= semanticdb-dir-sep-char (aref path (1- (length path))))) | ||
| 93 | ;; (concat path (list semanticdb-dir-sep-char)) | ||
| 94 | ;; path)) | ||
| 95 | |||
| 96 | ;;; Classes | ||
| 97 | ;; | ||
| 98 | (defclass semanticdb-project-database-file (semanticdb-project-database | ||
| 99 | eieio-persistent) | ||
| 100 | ((file-header-line :initform ";; SEMANTICDB Tags save file") | ||
| 101 | (do-backups :initform nil) | ||
| 102 | (semantic-tag-version :initarg :semantic-tag-version | ||
| 103 | :initform "1.4" | ||
| 104 | :documentation | ||
| 105 | "The version of the tags saved. | ||
| 106 | The default value is 1.4. In semantic 1.4 there was no versioning, so | ||
| 107 | when those files are loaded, this becomes the version number. | ||
| 108 | To save the version number, we must hand-set this version string.") | ||
| 109 | (semanticdb-version :initarg :semanticdb-version | ||
| 110 | :initform "1.4" | ||
| 111 | :documentation | ||
| 112 | "The version of the object system saved. | ||
| 113 | The default value is 1.4. In semantic 1.4, there was no versioning, | ||
| 114 | so when those files are loaded, this becomes the version number. | ||
| 115 | To save the version number, we must hand-set this version string.") | ||
| 116 | ) | ||
| 117 | "Database of file tables saved to disk.") | ||
| 118 | |||
| 119 | ;;; Code: | ||
| 120 | ;; | ||
| 121 | (defmethod semanticdb-create-database :STATIC ((dbc semanticdb-project-database-file) | ||
| 122 | directory) | ||
| 123 | "Create a new semantic database for DIRECTORY and return it. | ||
| 124 | If a database for DIRECTORY has already been loaded, return it. | ||
| 125 | If a database for DIRECTORY exists, then load that database, and return it. | ||
| 126 | If DIRECTORY doesn't exist, create a new one." | ||
| 127 | ;; Make sure this is fully expanded so we don't get duplicates. | ||
| 128 | (setq directory (file-truename directory)) | ||
| 129 | (let* ((fn (semanticdb-cache-filename dbc directory)) | ||
| 130 | (db (or (semanticdb-file-loaded-p fn) | ||
| 131 | (if (file-exists-p fn) | ||
| 132 | (progn | ||
| 133 | (semanticdb-load-database fn)))))) | ||
| 134 | (unless db | ||
| 135 | (setq db (make-instance | ||
| 136 | dbc ; Create the database requested. Perhaps | ||
| 137 | (concat (file-name-nondirectory | ||
| 138 | (directory-file-name | ||
| 139 | directory)) | ||
| 140 | "/") | ||
| 141 | :file fn :tables nil | ||
| 142 | :semantic-tag-version semantic-version | ||
| 143 | :semanticdb-version semanticdb-file-version))) | ||
| 144 | ;; Set this up here. We can't put it in the constructor because it | ||
| 145 | ;; would be saved, and we want DB files to be portable. | ||
| 146 | (oset db reference-directory directory) | ||
| 147 | db)) | ||
| 148 | |||
| 149 | ;;; File IO | ||
| 150 | (defun semanticdb-load-database (filename) | ||
| 151 | "Load the database FILENAME." | ||
| 152 | (require 'inversion) | ||
| 153 | (condition-case foo | ||
| 154 | (let* ((r (eieio-persistent-read filename)) | ||
| 155 | (c (semanticdb-get-database-tables r)) | ||
| 156 | (tv (oref r semantic-tag-version)) | ||
| 157 | (fv (oref r semanticdb-version)) | ||
| 158 | ) | ||
| 159 | ;; Restore the parent-db connection | ||
| 160 | (while c | ||
| 161 | (oset (car c) parent-db r) | ||
| 162 | (setq c (cdr c))) | ||
| 163 | (if (not (inversion-test 'semanticdb-file fv)) | ||
| 164 | (when (inversion-test 'semantic-tag tv) | ||
| 165 | ;; Incompatible version. Flush tables. | ||
| 166 | (semanticdb-flush-database-tables r) | ||
| 167 | ;; Reset the version to new version. | ||
| 168 | (oset r semantic-tag-version semantic-tag-version) | ||
| 169 | ;; Warn user | ||
| 170 | (message "Semanticdb file is old. Starting over for %s" | ||
| 171 | filename) | ||
| 172 | ) | ||
| 173 | ;; Version is not ok. Flush whole system | ||
| 174 | (message "semanticdb file is old. Starting over for %s" | ||
| 175 | filename) | ||
| 176 | ;; This database is so old, we need to replace it. | ||
| 177 | ;; We also need to delete it from the instance tracker. | ||
| 178 | (delete-instance r) | ||
| 179 | (setq r nil)) | ||
| 180 | r) | ||
| 181 | (error (message "Cache Error: [%s] %s, Restart" | ||
| 182 | filename foo) | ||
| 183 | nil))) | ||
| 184 | |||
| 185 | (defun semanticdb-file-loaded-p (filename) | ||
| 186 | "Return the project belonging to FILENAME if it was already loaded." | ||
| 187 | (eieio-instance-tracker-find filename 'file 'semanticdb-database-list)) | ||
| 188 | |||
| 189 | (defmethod semanticdb-file-directory-exists-p ((DB semanticdb-project-database-file) | ||
| 190 | &optional supress-questions) | ||
| 191 | "Does the directory the database DB needs to write to exist? | ||
| 192 | If SUPRESS-QUESTIONS, then do not ask to create the directory." | ||
| 193 | (let ((dest (file-name-directory (oref DB file))) | ||
| 194 | ) | ||
| 195 | (cond ((null dest) | ||
| 196 | ;; @TODO - If it was never set up... what should we do ? | ||
| 197 | nil) | ||
| 198 | ((file-exists-p dest) t) | ||
| 199 | (supress-questions nil) | ||
| 200 | ((y-or-n-p (format "Create directory %s for SemanticDB? " | ||
| 201 | dest)) | ||
| 202 | (make-directory dest t) | ||
| 203 | t) | ||
| 204 | (t nil)) | ||
| 205 | )) | ||
| 206 | |||
| 207 | (defmethod semanticdb-save-db ((DB semanticdb-project-database-file) | ||
| 208 | &optional | ||
| 209 | supress-questions) | ||
| 210 | "Write out the database DB to its file. | ||
| 211 | If DB is not specified, then use the current database." | ||
| 212 | (let ((objname (oref DB file))) | ||
| 213 | (when (and (semanticdb-dirty-p DB) | ||
| 214 | (semanticdb-live-p DB) | ||
| 215 | (semanticdb-file-directory-exists-p DB supress-questions) | ||
| 216 | (semanticdb-write-directory-p DB) | ||
| 217 | ) | ||
| 218 | ;;(message "Saving tag summary for %s..." objname) | ||
| 219 | (condition-case foo | ||
| 220 | (eieio-persistent-save (or DB semanticdb-current-database)) | ||
| 221 | (file-error ; System error saving? Ignore it. | ||
| 222 | (message "%S: %s" foo objname)) | ||
| 223 | (error | ||
| 224 | (cond | ||
| 225 | ((and (listp foo) | ||
| 226 | (stringp (nth 1 foo)) | ||
| 227 | (string-match "write[- ]protected" (nth 1 foo))) | ||
| 228 | (message (nth 1 foo))) | ||
| 229 | ((and (listp foo) | ||
| 230 | (stringp (nth 1 foo)) | ||
| 231 | (string-match "no such directory" (nth 1 foo))) | ||
| 232 | (message (nth 1 foo))) | ||
| 233 | (t | ||
| 234 | ;; @todo - It should ask if we are not called from a hook. | ||
| 235 | ;; How? | ||
| 236 | (if (or supress-questions | ||
| 237 | (y-or-n-p (format "Skip Error: %S ?" (car (cdr foo))))) | ||
| 238 | (message "Save Error: %S: %s" (car (cdr foo)) | ||
| 239 | objname) | ||
| 240 | (error "%S" (car (cdr foo)))))))) | ||
| 241 | (run-hook-with-args 'semanticdb-save-database-hooks | ||
| 242 | (or DB semanticdb-current-database)) | ||
| 243 | ;;(message "Saving tag summary for %s...done" objname) | ||
| 244 | ) | ||
| 245 | )) | ||
| 246 | |||
| 247 | (defmethod semanticdb-live-p ((obj semanticdb-project-database)) | ||
| 248 | "Return non-nil if the file associated with OBJ is live. | ||
| 249 | Live databases are objects associated with existing directories." | ||
| 250 | (and (slot-boundp obj 'reference-directory) | ||
| 251 | (file-exists-p (oref obj reference-directory)))) | ||
| 252 | |||
| 253 | (defmethod semanticdb-live-p ((obj semanticdb-table)) | ||
| 254 | "Return non-nil if the file associated with OBJ is live. | ||
| 255 | Live files are either buffers in Emacs, or files existing on the filesystem." | ||
| 256 | (let ((full-filename (semanticdb-full-filename obj))) | ||
| 257 | (or (find-buffer-visiting full-filename) | ||
| 258 | (file-exists-p full-filename)))) | ||
| 259 | |||
| 260 | (defvar semanticdb-data-debug-on-write-error nil | ||
| 261 | "Run the data debugger on tables that issue errors. | ||
| 262 | This variable is set to nil after the first error is encountered | ||
| 263 | to prevent overload.") | ||
| 264 | |||
| 265 | (defmethod object-write ((obj semanticdb-table)) | ||
| 266 | "When writing a table, we have to make sure we deoverlay it first. | ||
| 267 | Restore the overlays after writting. | ||
| 268 | Argument OBJ is the object to write." | ||
| 269 | (when (semanticdb-live-p obj) | ||
| 270 | (when (semanticdb-in-buffer-p obj) | ||
| 271 | (save-excursion | ||
| 272 | (set-buffer (semanticdb-in-buffer-p obj)) | ||
| 273 | |||
| 274 | ;; Make sure all our tag lists are up to date. | ||
| 275 | (semantic-fetch-tags) | ||
| 276 | |||
| 277 | ;; Try to get an accurate unmatched syntax table. | ||
| 278 | (when (and (boundp semantic-show-unmatched-syntax-mode) | ||
| 279 | semantic-show-unmatched-syntax-mode) | ||
| 280 | ;; Only do this if the user runs unmatched syntax | ||
| 281 | ;; mode display enties. | ||
| 282 | (oset obj unmatched-syntax | ||
| 283 | (semantic-show-unmatched-lex-tokens-fetch)) | ||
| 284 | ) | ||
| 285 | |||
| 286 | ;; Make sure pointmax is up to date | ||
| 287 | (oset obj pointmax (point-max)) | ||
| 288 | )) | ||
| 289 | |||
| 290 | ;; Make sure that the file size and other attributes are | ||
| 291 | ;; up to date. | ||
| 292 | (let ((fattr (file-attributes (semanticdb-full-filename obj)))) | ||
| 293 | (oset obj fsize (nth 7 fattr)) | ||
| 294 | (oset obj lastmodtime (nth 5 fattr)) | ||
| 295 | ) | ||
| 296 | |||
| 297 | ;; Do it! | ||
| 298 | (condition-case tableerror | ||
| 299 | (call-next-method) | ||
| 300 | (error | ||
| 301 | (when semanticdb-data-debug-on-write-error | ||
| 302 | (require 'data-debug) | ||
| 303 | (data-debug-new-buffer (concat "*SEMANTICDB ERROR*")) | ||
| 304 | (data-debug-insert-thing obj "*" "") | ||
| 305 | (setq semanticdb-data-debug-on-write-error nil)) | ||
| 306 | (message "Error Writing Table: %s" (object-name obj)) | ||
| 307 | (error "%S" (car (cdr tableerror))))) | ||
| 308 | |||
| 309 | ;; Clear the dirty bit. | ||
| 310 | (oset obj dirty nil) | ||
| 311 | )) | ||
| 312 | |||
| 313 | ;;; State queries | ||
| 314 | ;; | ||
| 315 | (defmethod semanticdb-write-directory-p ((obj semanticdb-project-database-file)) | ||
| 316 | "Return non-nil if OBJ should be written to disk. | ||
| 317 | Uses `semanticdb-persistent-path' to determine the return value." | ||
| 318 | (let ((path semanticdb-persistent-path)) | ||
| 319 | (catch 'found | ||
| 320 | (while path | ||
| 321 | (cond ((stringp (car path)) | ||
| 322 | (if (string= (oref obj reference-directory) (car path)) | ||
| 323 | (throw 'found t))) | ||
| 324 | ((eq (car path) 'project) | ||
| 325 | ;; @TODO - EDE causes us to go in here and disable | ||
| 326 | ;; the old default 'always save' setting. | ||
| 327 | ;; | ||
| 328 | ;; With new default 'always' should I care? | ||
| 329 | (if semanticdb-project-predicate-functions | ||
| 330 | (if (run-hook-with-args-until-success | ||
| 331 | 'semanticdb-project-predicate-functions | ||
| 332 | (oref obj reference-directory)) | ||
| 333 | (throw 'found t)) | ||
| 334 | ;; If the mode is 'project, and there are no project | ||
| 335 | ;; modes, then just always save the file. If users | ||
| 336 | ;; wish to restrict the search, modify | ||
| 337 | ;; `semanticdb-persistent-path' to include desired paths. | ||
| 338 | (if (= (length semanticdb-persistent-path) 1) | ||
| 339 | (throw 'found t)) | ||
| 340 | )) | ||
| 341 | ((eq (car path) 'never) | ||
| 342 | (throw 'found nil)) | ||
| 343 | ((eq (car path) 'always) | ||
| 344 | (throw 'found t)) | ||
| 345 | (t (error "Invalid path %S" (car path)))) | ||
| 346 | (setq path (cdr path))) | ||
| 347 | (call-next-method)) | ||
| 348 | )) | ||
| 349 | |||
| 350 | ;;; Filename manipulation | ||
| 351 | ;; | ||
| 352 | (defmethod semanticdb-file-table ((obj semanticdb-project-database-file) filename) | ||
| 353 | "From OBJ, return FILENAME's associated table object." | ||
| 354 | ;; Cheater option. In this case, we always have files directly | ||
| 355 | ;; under ourselves. The main project type may not. | ||
| 356 | (object-assoc (file-name-nondirectory filename) 'file (oref obj tables))) | ||
| 357 | |||
| 358 | (defmethod semanticdb-file-name-non-directory :STATIC | ||
| 359 | ((dbclass semanticdb-project-database-file)) | ||
| 360 | "Return the file name DBCLASS will use. | ||
| 361 | File name excludes any directory part." | ||
| 362 | semanticdb-default-file-name) | ||
| 363 | |||
| 364 | (defmethod semanticdb-file-name-directory :STATIC | ||
| 365 | ((dbclass semanticdb-project-database-file) directory) | ||
| 366 | "Return the relative directory to where DBCLASS will save its cache file. | ||
| 367 | The returned path is related to DIRECTORY." | ||
| 368 | (if semanticdb-default-save-directory | ||
| 369 | (let ((file (cedet-directory-name-to-file-name directory))) | ||
| 370 | ;; Now create a filename for the cache file in | ||
| 371 | ;; ;`semanticdb-default-save-directory'. | ||
| 372 | (expand-file-name | ||
| 373 | file (file-name-as-directory semanticdb-default-save-directory))) | ||
| 374 | directory)) | ||
| 375 | |||
| 376 | (defmethod semanticdb-cache-filename :STATIC | ||
| 377 | ((dbclass semanticdb-project-database-file) path) | ||
| 378 | "For DBCLASS, return a file to a cache file belonging to PATH. | ||
| 379 | This could be a cache file in the current directory, or an encoded file | ||
| 380 | name in a secondary directory." | ||
| 381 | ;; Use concat and not expand-file-name, because the dir part | ||
| 382 | ;; may include some of the file name. | ||
| 383 | (concat (semanticdb-file-name-directory dbclass path) | ||
| 384 | (semanticdb-file-name-non-directory dbclass))) | ||
| 385 | |||
| 386 | (defmethod semanticdb-full-filename ((obj semanticdb-project-database-file)) | ||
| 387 | "Fetch the full filename that OBJ refers to." | ||
| 388 | (oref obj file)) | ||
| 389 | |||
| 390 | ;;; FLUSH OLD FILES | ||
| 391 | ;; | ||
| 392 | (defun semanticdb-cleanup-cache-files (&optional noerror) | ||
| 393 | "Cleanup any cache files associated with directories that no longer exist. | ||
| 394 | Optional NOERROR prevents errors from being displayed." | ||
| 395 | (interactive) | ||
| 396 | (when (and (not semanticdb-default-save-directory) | ||
| 397 | (not noerror)) | ||
| 398 | (error "No default save directory for semantic-save files")) | ||
| 399 | |||
| 400 | (when semanticdb-default-save-directory | ||
| 401 | |||
| 402 | ;; Calculate all the cache files we have. | ||
| 403 | (let* ((regexp (regexp-quote semanticdb-default-file-name)) | ||
| 404 | (files (directory-files semanticdb-default-save-directory | ||
| 405 | t regexp)) | ||
| 406 | (orig nil) | ||
| 407 | (to-delete nil)) | ||
| 408 | (dolist (F files) | ||
| 409 | (setq orig (cedet-file-name-to-directory-name | ||
| 410 | (file-name-nondirectory F))) | ||
| 411 | (when (not (file-exists-p (file-name-directory orig))) | ||
| 412 | (setq to-delete (cons F to-delete)) | ||
| 413 | )) | ||
| 414 | (if to-delete | ||
| 415 | (save-window-excursion | ||
| 416 | (let ((buff (get-buffer-create "*Semanticdb Delete*"))) | ||
| 417 | (with-current-buffer buff | ||
| 418 | (erase-buffer) | ||
| 419 | (insert "The following Cache files appear to be obsolete.\n\n") | ||
| 420 | (dolist (F to-delete) | ||
| 421 | (insert F "\n"))) | ||
| 422 | (pop-to-buffer buff t t) | ||
| 423 | (fit-window-to-buffer (get-buffer-window buff) nil 1) | ||
| 424 | (when (y-or-n-p "Delete Old Cache Files? ") | ||
| 425 | (mapc (lambda (F) | ||
| 426 | (message "Deleting to %s..." F) | ||
| 427 | (delete-file F)) | ||
| 428 | to-delete) | ||
| 429 | (message "done.")) | ||
| 430 | )) | ||
| 431 | ;; No files to delete | ||
| 432 | (when (not noerror) | ||
| 433 | (message "No obsolete semanticdb.cache files.")) | ||
| 434 | )))) | ||
| 435 | |||
| 436 | (provide 'semantic/db-file) | ||
| 437 | |||
| 438 | ;;; semanticdb-file.el ends here | ||
diff --git a/lisp/cedet/semantic/db-javascript.el b/lisp/cedet/semantic/db-javascript.el new file mode 100644 index 00000000000..dca2c38d4a6 --- /dev/null +++ b/lisp/cedet/semantic/db-javascript.el | |||
| @@ -0,0 +1,310 @@ | |||
| 1 | ;;; db-javascript.el --- Semantic database extensions for javascript | ||
| 2 | |||
| 3 | ;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 | ||
| 4 | ;;; Free Software Foundation, Inc. | ||
| 5 | |||
| 6 | ;; Author: Joakim Verona | ||
| 7 | |||
| 8 | ;; This file is part of GNU Emacs. | ||
| 9 | |||
| 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
| 11 | ;; it under the terms of the GNU General Public License as published by | ||
| 12 | ;; the Free Software Foundation, either version 3 of the License, or | ||
| 13 | ;; (at your option) any later version. | ||
| 14 | |||
| 15 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 18 | ;; GNU General Public License for more details. | ||
| 19 | |||
| 20 | ;; You should have received a copy of the GNU General Public License | ||
| 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | ||
| 22 | |||
| 23 | ;;; Commentary: | ||
| 24 | ;; | ||
| 25 | ;; Semanticdb database for Javascript. | ||
| 26 | ;; | ||
| 27 | ;; This is an omniscient database with a hard-coded list of symbols for | ||
| 28 | ;; Javascript. See the doc at the end of this file for adding or modifying | ||
| 29 | ;; the list of tags. | ||
| 30 | ;; | ||
| 31 | |||
| 32 | (require 'semantic/db-search) | ||
| 33 | (eval-when-compile | ||
| 34 | ;; For generic function searching. | ||
| 35 | (require 'eieio) | ||
| 36 | (require 'eieio-opt) | ||
| 37 | ) | ||
| 38 | ;;; Code: | ||
| 39 | (defvar semanticdb-javascript-tags | ||
| 40 | '(("eval" function | ||
| 41 | (:arguments | ||
| 42 | (("x" variable nil nil nil))) | ||
| 43 | nil nil) | ||
| 44 | ("parseInt" function | ||
| 45 | (:arguments | ||
| 46 | (("string" variable nil nil nil) | ||
| 47 | ("radix" variable nil nil nil))) | ||
| 48 | nil nil) | ||
| 49 | ("parseFloat" function | ||
| 50 | (:arguments | ||
| 51 | (("string" variable nil nil nil))) | ||
| 52 | nil nil) | ||
| 53 | ("isNaN" function | ||
| 54 | (:arguments | ||
| 55 | (("number" variable nil nil nil))) | ||
| 56 | nil nil) | ||
| 57 | ("isFinite" function | ||
| 58 | (:arguments | ||
| 59 | (("number" variable nil nil nil))) | ||
| 60 | nil nil) | ||
| 61 | ("decodeURI" function | ||
| 62 | (:arguments | ||
| 63 | (("encodedURI" variable nil nil nil))) | ||
| 64 | nil nil) | ||
| 65 | ("decodeURIComponent" function | ||
| 66 | (:arguments | ||
| 67 | (("encodedURIComponent" variable nil nil nil))) | ||
| 68 | nil nil) | ||
| 69 | ("encodeURI" function | ||
| 70 | (:arguments | ||
| 71 | (("uri" variable nil nil nil))) | ||
| 72 | nil nil) | ||
| 73 | ("encodeURIComponent" function | ||
| 74 | (:arguments | ||
| 75 | (("uriComponent" variable nil nil nil))) | ||
| 76 | nil nil)) | ||
| 77 | "Hard-coded list of javascript tags for semanticdb. | ||
| 78 | See bottom of this file for instruction on managing this list.") | ||
| 79 | |||
| 80 | ;;; Classes: | ||
| 81 | (defclass semanticdb-table-javascript (semanticdb-search-results-table) | ||
| 82 | ((major-mode :initform javascript-mode) | ||
| 83 | ) | ||
| 84 | "A table for returning search results from javascript.") | ||
| 85 | |||
| 86 | (defclass semanticdb-project-database-javascript | ||
| 87 | (semanticdb-project-database | ||
| 88 | eieio-singleton ;this db is for js globals, so singleton is apropriate | ||
| 89 | ) | ||
| 90 | ((new-table-class :initform semanticdb-table-javascript | ||
| 91 | :type class | ||
| 92 | :documentation | ||
| 93 | "New tables created for this database are of this class.") | ||
| 94 | ) | ||
| 95 | "Database representing javascript.") | ||
| 96 | |||
| 97 | ;; Create the database, and add it to searchable databases for javascript mode. | ||
| 98 | (defvar-mode-local javascript-mode semanticdb-project-system-databases | ||
| 99 | (list | ||
| 100 | (semanticdb-project-database-javascript "Javascript")) | ||
| 101 | "Search javascript for symbols.") | ||
| 102 | |||
| 103 | ;; NOTE: Be sure to modify this to the best advantage of your | ||
| 104 | ;; language. | ||
| 105 | (defvar-mode-local javascript-mode semanticdb-find-default-throttle | ||
| 106 | '(project omniscience) | ||
| 107 | "Search project files, then search this omniscience database. | ||
| 108 | It is not necessary to to system or recursive searching because of | ||
| 109 | the omniscience database.") | ||
| 110 | |||
| 111 | ;;; Filename based methods | ||
| 112 | ;; | ||
| 113 | (defmethod semanticdb-get-database-tables ((obj semanticdb-project-database-javascript)) | ||
| 114 | "For a javascript database, there are no explicit tables. | ||
| 115 | Create one of our special tables that can act as an intermediary." | ||
| 116 | ;; NOTE: This method overrides an accessor for the `tables' slot in | ||
| 117 | ;; a database. You can either construct your own (like tmp here | ||
| 118 | ;; or you can manage any number of tables. | ||
| 119 | |||
| 120 | ;; We need to return something since there is always the "master table" | ||
| 121 | ;; The table can then answer file name type questions. | ||
| 122 | (when (not (slot-boundp obj 'tables)) | ||
| 123 | (let ((newtable (semanticdb-table-javascript "tmp"))) | ||
| 124 | (oset obj tables (list newtable)) | ||
| 125 | (oset newtable parent-db obj) | ||
| 126 | (oset newtable tags nil) | ||
| 127 | )) | ||
| 128 | (call-next-method) | ||
| 129 | ) | ||
| 130 | |||
| 131 | (defmethod semanticdb-file-table ((obj semanticdb-project-database-javascript) filename) | ||
| 132 | "From OBJ, return FILENAME's associated table object." | ||
| 133 | ;; NOTE: See not for `semanticdb-get-database-tables'. | ||
| 134 | (car (semanticdb-get-database-tables obj)) | ||
| 135 | ) | ||
| 136 | |||
| 137 | (defmethod semanticdb-get-tags ((table semanticdb-table-javascript )) | ||
| 138 | "Return the list of tags belonging to TABLE." | ||
| 139 | ;; NOTE: Omniscient databases probably don't want to keep large tabes | ||
| 140 | ;; lolly-gagging about. Keep internal Emacs tables empty and | ||
| 141 | ;; refer to alternate databases when you need something. | ||
| 142 | semanticdb-javascript-tags) | ||
| 143 | |||
| 144 | (defmethod semanticdb-equivalent-mode ((table semanticdb-table-javascript) &optional buffer) | ||
| 145 | "Return non-nil if TABLE's mode is equivalent to BUFFER. | ||
| 146 | Equivalent modes are specified by by `semantic-equivalent-major-modes' | ||
| 147 | local variable." | ||
| 148 | (save-excursion | ||
| 149 | (set-buffer buffer) | ||
| 150 | (eq (or mode-local-active-mode major-mode) 'javascript-mode))) | ||
| 151 | |||
| 152 | ;;; Usage | ||
| 153 | ;; | ||
| 154 | ;; Unlike other tables, an omniscent database does not need to | ||
| 155 | ;; be associated with a path. Use this routine to always add ourselves | ||
| 156 | ;; to a search list. | ||
| 157 | (define-mode-local-override semanticdb-find-translate-path javascript-mode | ||
| 158 | (path brutish) | ||
| 159 | "Return a list of semanticdb tables asociated with PATH. | ||
| 160 | If brutish, do the default action. | ||
| 161 | If not brutish, do the default action, and append the system | ||
| 162 | database (if available.)" | ||
| 163 | (let ((default | ||
| 164 | ;; When we recurse, disable searching of system databases | ||
| 165 | ;; so that our Javascript database only shows up once when | ||
| 166 | ;; we append it in this iteration. | ||
| 167 | (let ((semanticdb-search-system-databases nil) | ||
| 168 | ) | ||
| 169 | (semanticdb-find-translate-path-default path brutish)))) | ||
| 170 | ;; Don't add anything if BRUTISH is on (it will be added in that fcn) | ||
| 171 | ;; or if we aren't supposed to search the system. | ||
| 172 | (if (or brutish (not semanticdb-search-system-databases)) | ||
| 173 | default | ||
| 174 | (let ((tables (apply #'append | ||
| 175 | (mapcar | ||
| 176 | (lambda (db) (semanticdb-get-database-tables db)) | ||
| 177 | semanticdb-project-system-databases)))) | ||
| 178 | (append default tables))))) | ||
| 179 | |||
| 180 | ;;; Search Overrides | ||
| 181 | ;; | ||
| 182 | ;; NOTE WHEN IMPLEMENTING: Be sure to add doc-string updates explaining | ||
| 183 | ;; how your new search routines are implemented. | ||
| 184 | ;; | ||
| 185 | (defun semanticdb-javascript-regexp-search (regexp) | ||
| 186 | "Search for REGEXP in our fixed list of javascript tags." | ||
| 187 | (let* ((tags semanticdb-javascript-tags) | ||
| 188 | (result nil)) | ||
| 189 | (while tags | ||
| 190 | (if (string-match regexp (caar tags)) | ||
| 191 | (setq result (cons (car tags) result))) | ||
| 192 | (setq tags (cdr tags))) | ||
| 193 | result)) | ||
| 194 | |||
| 195 | (defmethod semanticdb-find-tags-by-name-method | ||
| 196 | ((table semanticdb-table-javascript) name &optional tags) | ||
| 197 | "Find all tags named NAME in TABLE. | ||
| 198 | Return a list of tags." | ||
| 199 | (if tags | ||
| 200 | ;; If TAGS are passed in, then we don't need to do work here. | ||
| 201 | (call-next-method) | ||
| 202 | (assoc-string name semanticdb-javascript-tags) | ||
| 203 | )) | ||
| 204 | |||
| 205 | (defmethod semanticdb-find-tags-by-name-regexp-method | ||
| 206 | ((table semanticdb-table-javascript) regex &optional tags) | ||
| 207 | "Find all tags with name matching REGEX in TABLE. | ||
| 208 | Optional argument TAGS is a list of tags to search. | ||
| 209 | Return a list of tags." | ||
| 210 | (if tags (call-next-method) | ||
| 211 | ;; YOUR IMPLEMENTATION HERE | ||
| 212 | (semanticdb-javascript-regexp-search regex) | ||
| 213 | |||
| 214 | )) | ||
| 215 | |||
| 216 | (defmethod semanticdb-find-tags-for-completion-method | ||
| 217 | ((table semanticdb-table-javascript) prefix &optional tags) | ||
| 218 | "In TABLE, find all occurances of tags matching PREFIX. | ||
| 219 | Optional argument TAGS is a list of tags to search. | ||
| 220 | Returns a table of all matching tags." | ||
| 221 | (if tags (call-next-method) | ||
| 222 | ;; YOUR IMPLEMENTATION HERE | ||
| 223 | (semanticdb-javascript-regexp-search (concat "^" prefix ".*")) | ||
| 224 | )) | ||
| 225 | |||
| 226 | (defmethod semanticdb-find-tags-by-class-method | ||
| 227 | ((table semanticdb-table-javascript) class &optional tags) | ||
| 228 | "In TABLE, find all occurances of tags of CLASS. | ||
| 229 | Optional argument TAGS is a list of tags to search. | ||
| 230 | Returns a table of all matching tags." | ||
| 231 | (if tags (call-next-method) | ||
| 232 | ;; YOUR IMPLEMENTATION HERE | ||
| 233 | ;; | ||
| 234 | ;; Note: This search method could be considered optional in an | ||
| 235 | ;; omniscient database. It may be unwise to return all tags | ||
| 236 | ;; that exist for a language that are a variable or function. | ||
| 237 | ;; | ||
| 238 | ;; If it is optional, you can just delete this method. | ||
| 239 | nil)) | ||
| 240 | |||
| 241 | ;;; Deep Searches | ||
| 242 | ;; | ||
| 243 | ;; If your language does not have a `deep' concept, these can be left | ||
| 244 | ;; alone, otherwise replace with implementations similar to those | ||
| 245 | ;; above. | ||
| 246 | ;; | ||
| 247 | (defmethod semanticdb-deep-find-tags-by-name-method | ||
| 248 | ((table semanticdb-table-javascript) name &optional tags) | ||
| 249 | "Find all tags name NAME in TABLE. | ||
| 250 | Optional argument TAGS is a list of tags t | ||
| 251 | Like `semanticdb-find-tags-by-name-method' for javascript." | ||
| 252 | (semanticdb-find-tags-by-name-method table name tags)) | ||
| 253 | |||
| 254 | (defmethod semanticdb-deep-find-tags-by-name-regexp-method | ||
| 255 | ((table semanticdb-table-javascript) regex &optional tags) | ||
| 256 | "Find all tags with name matching REGEX in TABLE. | ||
| 257 | Optional argument TAGS is a list of tags to search. | ||
| 258 | Like `semanticdb-find-tags-by-name-method' for javascript." | ||
| 259 | (semanticdb-find-tags-by-name-regexp-method table regex tags)) | ||
| 260 | |||
| 261 | (defmethod semanticdb-deep-find-tags-for-completion-method | ||
| 262 | ((table semanticdb-table-javascript) prefix &optional tags) | ||
| 263 | "In TABLE, find all occurances of tags matching PREFIX. | ||
| 264 | Optional argument TAGS is a list of tags to search. | ||
| 265 | Like `semanticdb-find-tags-for-completion-method' for javascript." | ||
| 266 | (semanticdb-find-tags-for-completion-method table prefix tags)) | ||
| 267 | |||
| 268 | ;;; Advanced Searches | ||
| 269 | ;; | ||
| 270 | (defmethod semanticdb-find-tags-external-children-of-type-method | ||
| 271 | ((table semanticdb-table-javascript) type &optional tags) | ||
| 272 | "Find all nonterminals which are child elements of TYPE | ||
| 273 | Optional argument TAGS is a list of tags to search. | ||
| 274 | Return a list of tags." | ||
| 275 | (if tags (call-next-method) | ||
| 276 | ;; YOUR IMPLEMENTATION HERE | ||
| 277 | ;; | ||
| 278 | ;; OPTIONAL: This could be considered an optional function. It is | ||
| 279 | ;; used for `semantic-adopt-external-members' and may not | ||
| 280 | ;; be possible to do in your language. | ||
| 281 | ;; | ||
| 282 | ;; If it is optional, you can just delete this method. | ||
| 283 | )) | ||
| 284 | |||
| 285 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | ||
| 286 | (defun semanticdb-javascript-strip-tags (tags) | ||
| 287 | "Strip TAGS from overlays and reparse symbols." | ||
| 288 | (cond ((and (consp tags) (eq 'reparse-symbol (car tags))) | ||
| 289 | nil) | ||
| 290 | ((overlayp tags) nil) | ||
| 291 | ((atom tags) tags) | ||
| 292 | (t (cons (semanticdb-javascript-strip-tags | ||
| 293 | (car tags)) (semanticdb-javascript-strip-tags | ||
| 294 | (cdr tags)))))) | ||
| 295 | |||
| 296 | ;this list was made from a javascript file, and the above function | ||
| 297 | ;; function eval(x){} | ||
| 298 | ;; function parseInt(string,radix){} | ||
| 299 | ;; function parseFloat(string){} | ||
| 300 | ;; function isNaN(number){} | ||
| 301 | ;; function isFinite(number){} | ||
| 302 | ;; function decodeURI(encodedURI){} | ||
| 303 | ;; function decodeURIComponent (encodedURIComponent){} | ||
| 304 | ;; function encodeURI (uri){} | ||
| 305 | ;; function encodeURIComponent (uriComponent){} | ||
| 306 | |||
| 307 | |||
| 308 | (provide 'semantic/db-el) | ||
| 309 | |||
| 310 | ;;; semanticdb-el.el ends here | ||
diff --git a/lisp/cedet/semantic/db-search.el b/lisp/cedet/semantic/db-search.el new file mode 100644 index 00000000000..acfb788fe16 --- /dev/null +++ b/lisp/cedet/semantic/db-search.el | |||
| @@ -0,0 +1,451 @@ | |||
| 1 | ;;; db-search.el --- Searching through semantic databases. | ||
| 2 | |||
| 3 | ;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2008, 2009 | ||
| 4 | ;;; Free Software Foundation, Inc. | ||
| 5 | |||
| 6 | ;; Author: Eric M. Ludlam <zappo@gnu.org> | ||
| 7 | |||
| 8 | ;; This file is part of GNU Emacs. | ||
| 9 | |||
| 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
| 11 | ;; it under the terms of the GNU General Public License as published by | ||
| 12 | ;; the Free Software Foundation, either version 3 of the License, or | ||
| 13 | ;; (at your option) any later version. | ||
| 14 | |||
| 15 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 18 | ;; GNU General Public License for more details. | ||
| 19 | |||
| 20 | ;; You should have received a copy of the GNU General Public License | ||
| 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | ||
| 22 | |||
| 23 | ;;; Commentary: | ||
| 24 | ;; | ||
| 25 | ;; NOTE: THESE APIs ARE OBSOLETE: | ||
| 26 | ;; | ||
| 27 | ;; Databases of various forms can all be searched. These routines | ||
| 28 | ;; cover many common forms of searching. | ||
| 29 | ;; | ||
| 30 | ;; There are three types of searches that can be implemented: | ||
| 31 | ;; | ||
| 32 | ;; Basic Search: | ||
| 33 | ;; These searches allow searching on specific attributes of tags, | ||
| 34 | ;; such as name or type. | ||
| 35 | ;; | ||
| 36 | ;; Advanced Search: | ||
| 37 | ;; These are searches that were needed to accomplish some tasks | ||
| 38 | ;; during in utilities. Advanced searches include matching methods | ||
| 39 | ;; defined outside some parent class. | ||
| 40 | ;; | ||
| 41 | ;; The reason for advanced searches are so that external | ||
| 42 | ;; repositories such as the Emacs obarray, or java .class files can | ||
| 43 | ;; quickly answer these needed questions without dumping the entire | ||
| 44 | ;; symbol list into Emacs for a regular semanticdb search. | ||
| 45 | ;; | ||
| 46 | ;; Generic Search: | ||
| 47 | ;; The generic search, `semanticdb-find-nonterminal-by-function' | ||
| 48 | ;; accepts a Emacs Lisp predicate that tests tags in Semantic | ||
| 49 | ;; format. Most external searches cannot perform this search. | ||
| 50 | |||
| 51 | (require 'semantic/db) | ||
| 52 | (require 'semantic/find) | ||
| 53 | |||
| 54 | ;;; Code: | ||
| 55 | ;; | ||
| 56 | ;;; Classes: | ||
| 57 | |||
| 58 | ;; @TODO MOVE THIS CLASS? | ||
| 59 | (defclass semanticdb-search-results-table (semanticdb-abstract-table) | ||
| 60 | ( | ||
| 61 | ) | ||
| 62 | "Table used for search results when there is no file or table association. | ||
| 63 | Examples include search results from external sources such as from | ||
| 64 | Emacs' own symbol table, or from external libraries.") | ||
| 65 | |||
| 66 | (defmethod semanticdb-refresh-table ((obj semanticdb-search-results-table) &optional force) | ||
| 67 | "If the tag list associated with OBJ is loaded, refresh it. | ||
| 68 | This will call `semantic-fetch-tags' if that file is in memory." | ||
| 69 | nil) | ||
| 70 | |||
| 71 | ;;; Utils | ||
| 72 | ;; | ||
| 73 | ;; Convenience routines for searches | ||
| 74 | (defun semanticdb-collect-find-results (result-in-databases | ||
| 75 | result-finding-function | ||
| 76 | ignore-system | ||
| 77 | find-file-on-match) | ||
| 78 | "OBSOLETE: | ||
| 79 | Collect results across RESULT-IN-DATABASES for RESULT-FINDING-FUNCTION. | ||
| 80 | If RESULT-IN-DATABASES is nil, search a range of associated databases | ||
| 81 | calculated by `semanticdb-current-database-list'. | ||
| 82 | RESULT-IN-DATABASES is a list of variable `semanticdb-project-database' | ||
| 83 | objects. | ||
| 84 | RESULT-FINDING-FUNCTION should accept one argument, the database being searched. | ||
| 85 | Argument IGNORE-SYSTEM specifies if any available system databases should | ||
| 86 | be ignored, or searched. | ||
| 87 | Argument FIND-FILE-ON-MATCH indicates that the found databases | ||
| 88 | should be capable of doing so." | ||
| 89 | (if (not (listp result-in-databases)) | ||
| 90 | (signal 'wrong-type-argument (list 'listp result-in-databases))) | ||
| 91 | (let* ((semanticdb-search-system-databases | ||
| 92 | (if ignore-system | ||
| 93 | nil | ||
| 94 | semanticdb-search-system-databases)) | ||
| 95 | (dbs (or result-in-databases | ||
| 96 | ;; Calculate what database to use. | ||
| 97 | ;; Something simple and dumb for now. | ||
| 98 | (or (semanticdb-current-database-list) | ||
| 99 | (list (semanticdb-current-database))))) | ||
| 100 | (case-fold-search semantic-case-fold) | ||
| 101 | (res (mapcar | ||
| 102 | (lambda (db) | ||
| 103 | (if (or (not find-file-on-match) | ||
| 104 | (not (child-of-class-p | ||
| 105 | (oref db new-table-class) | ||
| 106 | semanticdb-search-results-table))) | ||
| 107 | (funcall result-finding-function db))) | ||
| 108 | dbs)) | ||
| 109 | out) | ||
| 110 | ;; Flatten the list. The DB is unimportant at this stage. | ||
| 111 | (setq res (apply 'append res)) | ||
| 112 | (setq out nil) | ||
| 113 | ;; Move across results, and throw out empties. | ||
| 114 | (while res | ||
| 115 | (if (car res) | ||
| 116 | (setq out (cons (car res) out))) | ||
| 117 | (setq res (cdr res))) | ||
| 118 | ;; Results | ||
| 119 | out)) | ||
| 120 | |||
| 121 | ;;; Programatic interfaces | ||
| 122 | ;; | ||
| 123 | ;; These routines all perform different types of searches, and are | ||
| 124 | ;; interfaces to the database methods used to also perform those searches. | ||
| 125 | |||
| 126 | (defun semanticdb-find-nonterminal-by-token | ||
| 127 | (token &optional databases search-parts search-includes diff-mode find-file-match ignore-system) | ||
| 128 | "OBSOLETE: | ||
| 129 | Find all occurances of nonterminals with token TOKEN in databases. | ||
| 130 | See `semanticdb-find-nonterminal-by-function' for details on DATABASES, | ||
| 131 | SEARCH-PARTS, SEARCH-INCLUDES, DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM. | ||
| 132 | Return a list ((DB-TABLE . TOKEN-LIST) ...)." | ||
| 133 | (semanticdb-collect-find-results | ||
| 134 | databases | ||
| 135 | (lambda (db) | ||
| 136 | (semanticdb-find-nonterminal-by-token-method | ||
| 137 | db token search-parts search-includes diff-mode find-file-match)) | ||
| 138 | ignore-system | ||
| 139 | find-file-match)) | ||
| 140 | (make-obsolete 'semanticdb-find-nonterminal-by-token | ||
| 141 | "Please don't use this function") | ||
| 142 | |||
| 143 | (defun semanticdb-find-nonterminal-by-name | ||
| 144 | (name &optional databases search-parts search-includes diff-mode find-file-match ignore-system) | ||
| 145 | "OBSOLETE: | ||
| 146 | Find all occurances of nonterminals with name NAME in databases. | ||
| 147 | See `semanticdb-find-nonterminal-by-function' for details on DATABASES, | ||
| 148 | SEARCH-PARTS, SEARCH-INCLUDES, DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM. | ||
| 149 | Return a list ((DB-TABLE . TOKEN) ...)." | ||
| 150 | (semanticdb-collect-find-results | ||
| 151 | databases | ||
| 152 | (lambda (db) | ||
| 153 | (semanticdb-find-nonterminal-by-name-method | ||
| 154 | db name search-parts search-includes diff-mode find-file-match)) | ||
| 155 | ignore-system | ||
| 156 | find-file-match)) | ||
| 157 | (make-obsolete 'semanticdb-find-nonterminal-by-name | ||
| 158 | "Please don't use this function") | ||
| 159 | |||
| 160 | (defun semanticdb-find-nonterminal-by-name-regexp | ||
| 161 | (regex &optional databases search-parts search-includes diff-mode find-file-match ignore-system) | ||
| 162 | "OBSOLETE: | ||
| 163 | Find all occurances of nonterminals with name matching REGEX in databases. | ||
| 164 | See `semanticdb-find-nonterminal-by-function' for details on DATABASES, | ||
| 165 | SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM. | ||
| 166 | Return a list ((DB-TABLE . TOKEN-LIST) ...)." | ||
| 167 | (semanticdb-collect-find-results | ||
| 168 | databases | ||
| 169 | (lambda (db) | ||
| 170 | (semanticdb-find-nonterminal-by-name-regexp-method | ||
| 171 | db regex search-parts search-includes diff-mode find-file-match)) | ||
| 172 | ignore-system | ||
| 173 | find-file-match)) | ||
| 174 | (make-obsolete 'semanticdb-find-nonterminal-by-name-regexp | ||
| 175 | "Please don't use this function") | ||
| 176 | |||
| 177 | |||
| 178 | (defun semanticdb-find-nonterminal-by-type | ||
| 179 | (type &optional databases search-parts search-includes diff-mode find-file-match ignore-system) | ||
| 180 | "OBSOLETE: | ||
| 181 | Find all nonterminals with a type of TYPE in databases. | ||
| 182 | See `semanticdb-find-nonterminal-by-function' for details on DATABASES, | ||
| 183 | SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM. | ||
| 184 | Return a list ((DB-TABLE . TOKEN-LIST) ...)." | ||
| 185 | (semanticdb-collect-find-results | ||
| 186 | databases | ||
| 187 | (lambda (db) | ||
| 188 | (semanticdb-find-nonterminal-by-type-method | ||
| 189 | db type search-parts search-includes diff-mode find-file-match)) | ||
| 190 | ignore-system | ||
| 191 | find-file-match)) | ||
| 192 | (make-obsolete 'semanticdb-find-nonterminal-by-type | ||
| 193 | "Please don't use this function") | ||
| 194 | |||
| 195 | |||
| 196 | (defun semanticdb-find-nonterminal-by-property | ||
| 197 | (property value &optional databases search-parts search-includes diff-mode find-file-match ignore-system) | ||
| 198 | "OBSOLETE: | ||
| 199 | Find all nonterminals with a PROPERTY equal to VALUE in databases. | ||
| 200 | See `semanticdb-find-nonterminal-by-function' for details on DATABASES, | ||
| 201 | SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM. | ||
| 202 | Return a list ((DB-TABLE . TOKEN-LIST) ...)." | ||
| 203 | (semanticdb-collect-find-results | ||
| 204 | databases | ||
| 205 | (lambda (db) | ||
| 206 | (semanticdb-find-nonterminal-by-property-method | ||
| 207 | db property value search-parts search-includes diff-mode find-file-match)) | ||
| 208 | ignore-system | ||
| 209 | find-file-match)) | ||
| 210 | (make-obsolete 'semanticdb-find-nonterminal-by-property | ||
| 211 | "Please don't use this function") | ||
| 212 | |||
| 213 | (defun semanticdb-find-nonterminal-by-extra-spec | ||
| 214 | (spec &optional databases search-parts search-includes diff-mode find-file-match ignore-system) | ||
| 215 | "OBSOLETE: | ||
| 216 | Find all nonterminals with a SPEC in databases. | ||
| 217 | See `semanticdb-find-nonterminal-by-function' for details on DATABASES, | ||
| 218 | SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM. | ||
| 219 | Return a list ((DB-TABLE . TOKEN-LIST) ...)." | ||
| 220 | (semanticdb-collect-find-results | ||
| 221 | databases | ||
| 222 | (lambda (db) | ||
| 223 | (semanticdb-find-nonterminal-by-extra-spec-method | ||
| 224 | db spec search-parts search-includes diff-mode find-file-match)) | ||
| 225 | ignore-system | ||
| 226 | find-file-match)) | ||
| 227 | (make-obsolete 'semanticdb-find-nonterminal-by-extra-spec | ||
| 228 | "Please don't use this function") | ||
| 229 | |||
| 230 | (defun semanticdb-find-nonterminal-by-extra-spec-value | ||
| 231 | (spec value &optional databases search-parts search-includes diff-mode find-file-match ignore-system) | ||
| 232 | "OBSOLETE: | ||
| 233 | Find all nonterminals with a SPEC equal to VALUE in databases. | ||
| 234 | See `semanticdb-find-nonterminal-by-function' for details on DATABASES, | ||
| 235 | SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM. | ||
| 236 | Return a list ((DB-TABLE . TOKEN-LIST) ...)." | ||
| 237 | (semanticdb-collect-find-results | ||
| 238 | databases | ||
| 239 | (lambda (db) | ||
| 240 | (semanticdb-find-nonterminal-by-extra-spec-value-method | ||
| 241 | db spec value search-parts search-includes diff-mode find-file-match)) | ||
| 242 | ignore-system | ||
| 243 | find-file-match)) | ||
| 244 | (make-obsolete 'semanticdb-find-nonterminal-by-extra-spec-value | ||
| 245 | "Please don't use this function") | ||
| 246 | |||
| 247 | ;;; Advanced Search Routines | ||
| 248 | ;; | ||
| 249 | (defun semanticdb-find-nonterminal-external-children-of-type | ||
| 250 | (type &optional databases search-parts search-includes diff-mode find-file-match ignore-system) | ||
| 251 | "OBSOLETE: | ||
| 252 | Find all nonterminals which are child elements of TYPE. | ||
| 253 | See `semanticdb-find-nonterminal-by-function' for details on DATABASES, | ||
| 254 | SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM. | ||
| 255 | Return a list ((DB-TABLE . TOKEN-LIST) ...)." | ||
| 256 | (semanticdb-collect-find-results | ||
| 257 | databases | ||
| 258 | (lambda (db) | ||
| 259 | (semanticdb-find-nonterminal-external-children-of-type-method | ||
| 260 | db type search-parts search-includes diff-mode find-file-match)) | ||
| 261 | ignore-system | ||
| 262 | find-file-match)) | ||
| 263 | |||
| 264 | ;;; Generic Search routine | ||
| 265 | ;; | ||
| 266 | |||
| 267 | (defun semanticdb-find-nonterminal-by-function | ||
| 268 | (function &optional databases search-parts search-includes diff-mode find-file-match ignore-system) | ||
| 269 | "OBSOLETE: | ||
| 270 | Find all occurances of nonterminals which match FUNCTION. | ||
| 271 | Search in all DATABASES. If DATABASES is nil, search a range of | ||
| 272 | associated databases calculated `semanticdb-current-database-list' and | ||
| 273 | DATABASES is a list of variable `semanticdb-project-database' objects. | ||
| 274 | When SEARCH-PARTS is non-nil the search will include children of tags. | ||
| 275 | When SEARCH-INCLUDES is non-nil, the search will include dependency files. | ||
| 276 | When DIFF-MODE is non-nil, search databases which are of a different mode. | ||
| 277 | A Mode is the `major-mode' that file was in when it was last parsed. | ||
| 278 | When FIND-FILE-MATCH is non-nil, the make sure any found token's file is | ||
| 279 | in an Emacs buffer. | ||
| 280 | When IGNORE-SYSTEM is non-nil, system libraries are not searched. | ||
| 281 | Return a list ((DB-TABLE . TOKEN-OR-TOKEN-LIST) ...)." | ||
| 282 | (semanticdb-collect-find-results | ||
| 283 | databases | ||
| 284 | (lambda (db) | ||
| 285 | (semanticdb-find-nonterminal-by-function-method | ||
| 286 | db function search-parts search-includes diff-mode find-file-match)) | ||
| 287 | ignore-system | ||
| 288 | find-file-match)) | ||
| 289 | |||
| 290 | ;;; Search Methods | ||
| 291 | ;; | ||
| 292 | ;; These are the base routines for searching semantic databases. | ||
| 293 | ;; Overload these with your subclasses to participate in the searching | ||
| 294 | ;; mechanism. | ||
| 295 | (defmethod semanticdb-find-nonterminal-by-token-method | ||
| 296 | ((database semanticdb-project-database) token search-parts search-includes diff-mode find-file-match) | ||
| 297 | "OBSOLETE: | ||
| 298 | In DB, find all occurances of nonterminals with token TOKEN in databases. | ||
| 299 | See `semanticdb-find-nonterminal-by-function-method' for details on, | ||
| 300 | SEARCH-PARTS, SEARCH-INCLUDES, DIFF-MODE, and FIND-FILE-MATCH. | ||
| 301 | Return a list ((DB-TABLE . TOKEN-LIST) ...)." | ||
| 302 | (let ((goofy-token-name token)) | ||
| 303 | (semanticdb-find-nonterminal-by-function-method | ||
| 304 | database (lambda (stream sp si) | ||
| 305 | (semantic-brute-find-tag-by-class goofy-token-name stream sp si)) | ||
| 306 | search-parts search-includes diff-mode find-file-match))) | ||
| 307 | |||
| 308 | (defmethod semanticdb-find-nonterminal-by-name-method | ||
| 309 | ((database semanticdb-project-database) name search-parts search-includes diff-mode find-file-match) | ||
| 310 | "OBSOLETE: | ||
| 311 | Find all occurances of nonterminals with name NAME in databases. | ||
| 312 | See `semanticdb-find-nonterminal-by-function' for details on DATABASES, | ||
| 313 | SEARCH-PARTS, SEARCH-INCLUDES, DIFF-MODE, and FIND-FILE-MATCH. | ||
| 314 | Return a list ((DB-TABLE . TOKEN) ...)." | ||
| 315 | (semanticdb-find-nonterminal-by-function-method | ||
| 316 | database | ||
| 317 | (lambda (stream sp si) | ||
| 318 | (semantic-brute-find-first-tag-by-name name stream sp si)) | ||
| 319 | search-parts search-includes diff-mode find-file-match)) | ||
| 320 | |||
| 321 | (defmethod semanticdb-find-nonterminal-by-name-regexp-method | ||
| 322 | ((database semanticdb-project-database) regex search-parts search-includes diff-mode find-file-match) | ||
| 323 | "OBSOLETE: | ||
| 324 | Find all occurances of nonterminals with name matching REGEX in databases. | ||
| 325 | See `semanticdb-find-nonterminal-by-function' for details on DATABASES, | ||
| 326 | SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, and FIND-FILE-MATCH. | ||
| 327 | Return a list ((DB-TABLE . TOKEN-LIST) ...)." | ||
| 328 | (semanticdb-find-nonterminal-by-function-method | ||
| 329 | database | ||
| 330 | (lambda (stream sp si) | ||
| 331 | (semantic-brute-find-tag-by-name-regexp regex stream sp si)) | ||
| 332 | search-parts search-includes diff-mode find-file-match)) | ||
| 333 | |||
| 334 | (defmethod semanticdb-find-nonterminal-by-type-method | ||
| 335 | ((database semanticdb-project-database) type search-parts search-includes diff-mode find-file-match) | ||
| 336 | "OBSOLETE: | ||
| 337 | Find all nonterminals with a type of TYPE in databases. | ||
| 338 | See `semanticdb-find-nonterminal-by-function' for details on DATABASES, | ||
| 339 | SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, and FIND-FILE-MATCH. | ||
| 340 | Return a list ((DB-TABLE . TOKEN-LIST) ...)." | ||
| 341 | (semanticdb-find-nonterminal-by-function-method | ||
| 342 | database | ||
| 343 | (lambda (stream sp si) | ||
| 344 | (semantic-brute-find-tag-by-type type stream sp si)) | ||
| 345 | search-parts search-includes diff-mode find-file-match)) | ||
| 346 | |||
| 347 | (defmethod semanticdb-find-nonterminal-by-property-method | ||
| 348 | ((database semanticdb-project-database) property value search-parts search-includes diff-mode find-file-match) | ||
| 349 | "OBSOLETE: | ||
| 350 | Find all nonterminals with a PROPERTY equal to VALUE in databases. | ||
| 351 | See `semanticdb-find-nonterminal-by-function' for details on DATABASES, | ||
| 352 | SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, and FIND-FILE-MATCH. | ||
| 353 | Return a list ((DB-TABLE . TOKEN-LIST) ...)." | ||
| 354 | (semanticdb-find-nonterminal-by-function-method | ||
| 355 | database | ||
| 356 | (lambda (stream sp si) | ||
| 357 | (semantic-brute-find-tag-by-property property value stream sp si)) | ||
| 358 | search-parts search-includes diff-mode find-file-match)) | ||
| 359 | |||
| 360 | (defmethod semanticdb-find-nonterminal-by-extra-spec-method | ||
| 361 | ((database semanticdb-project-database) spec search-parts search-includes diff-mode find-file-match) | ||
| 362 | "OBSOLETE: | ||
| 363 | Find all nonterminals with a SPEC in databases. | ||
| 364 | See `semanticdb-find-nonterminal-by-function' for details on DATABASES, | ||
| 365 | SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, and FIND-FILE-MATCH. | ||
| 366 | Return a list ((DB-TABLE . TOKEN-LIST) ...)." | ||
| 367 | (semanticdb-find-nonterminal-by-function-method | ||
| 368 | database | ||
| 369 | (lambda (stream sp si) | ||
| 370 | (semantic-brute-find-tag-by-attribute spec stream sp si)) | ||
| 371 | search-parts search-includes diff-mode find-file-match)) | ||
| 372 | |||
| 373 | (defmethod semanticdb-find-nonterminal-by-extra-spec-value-method | ||
| 374 | ((database semanticdb-project-database) spec value search-parts search-includes diff-mode find-file-match) | ||
| 375 | "OBSOLETE: | ||
| 376 | Find all nonterminals with a SPEC equal to VALUE in databases. | ||
| 377 | See `semanticdb-find-nonterminal-by-function' for details on DATABASES, | ||
| 378 | SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, and FIND-FILE-MATCH. | ||
| 379 | Return a list ((DB-TABLE . TOKEN-LIST) ...)." | ||
| 380 | (semanticdb-find-nonterminal-by-function-method | ||
| 381 | database | ||
| 382 | (lambda (stream sp si) | ||
| 383 | (semantic-brute-find-tag-by-attribute-value spec value stream sp si)) | ||
| 384 | search-parts search-includes diff-mode find-file-match)) | ||
| 385 | |||
| 386 | ;;; Advanced Searches | ||
| 387 | ;; | ||
| 388 | (defmethod semanticdb-find-nonterminal-external-children-of-type-method | ||
| 389 | ((database semanticdb-project-database) type search-parts search-includes diff-mode find-file-match) | ||
| 390 | "OBSOLETE: | ||
| 391 | Find all nonterminals which are child elements of TYPE | ||
| 392 | See `semanticdb-find-nonterminal-by-function' for details on DATABASES, | ||
| 393 | SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM. | ||
| 394 | Return a list ((DB-TABLE . TOKEN-LIST) ...)." | ||
| 395 | (semanticdb-find-nonterminal-by-function-method | ||
| 396 | database | ||
| 397 | `(lambda (stream sp si) | ||
| 398 | (semantic-brute-find-tag-by-function | ||
| 399 | (lambda (tok) | ||
| 400 | (let ((p (semantic-nonterminal-external-member-parent tok))) | ||
| 401 | (and (stringp p) (string= ,type p))) | ||
| 402 | ) | ||
| 403 | stream sp si)) | ||
| 404 | nil nil t)) | ||
| 405 | |||
| 406 | ;;; Generic Search | ||
| 407 | ;; | ||
| 408 | (defmethod semanticdb-find-nonterminal-by-function-method | ||
| 409 | ((database semanticdb-project-database) | ||
| 410 | function &optional search-parts search-includes diff-mode find-file-match) | ||
| 411 | "OBSOLETE: | ||
| 412 | In DATABASE, find all occurances of nonterminals which match FUNCTION. | ||
| 413 | When SEARCH-PARTS is non-nil the search will include children of tags. | ||
| 414 | When SEARCH-INCLUDES is non-nil, the search will include dependency files. | ||
| 415 | When DIFF-MODE is non-nil, search databases which are of a different mode. | ||
| 416 | A mode is the `major-mode' that file was in when it was last parsed. | ||
| 417 | When FIND-FILE-MATCH is non-nil, the make sure any found token's file is | ||
| 418 | in an Emacs buffer. | ||
| 419 | Return a list of matches." | ||
| 420 | (let* ((ret nil) | ||
| 421 | (files (semanticdb-get-database-tables database)) | ||
| 422 | (found nil) | ||
| 423 | (orig-buffer (current-buffer))) | ||
| 424 | (while files | ||
| 425 | (when (or diff-mode | ||
| 426 | (semanticdb-equivalent-mode (car files) orig-buffer)) | ||
| 427 | ;; This can cause unneeded refreshes while typing with | ||
| 428 | ;; senator-eldoc mode. | ||
| 429 | ;;(semanticdb-refresh-table (car files)) | ||
| 430 | (setq found (funcall function | ||
| 431 | (semanticdb-get-tags (car files)) | ||
| 432 | search-parts | ||
| 433 | search-includes | ||
| 434 | ))) | ||
| 435 | (if found | ||
| 436 | (progn | ||
| 437 | ;; When something is found, make sure we read in that buffer if it | ||
| 438 | ;; had not already been loaded. | ||
| 439 | (if find-file-match | ||
| 440 | (save-excursion (semanticdb-set-buffer (car files)))) | ||
| 441 | ;; In theory, the database is up-to-date with what is in the file, and | ||
| 442 | ;; these tags are ready to go. | ||
| 443 | ;; There is a bug lurking here I don't have time to fix. | ||
| 444 | (setq ret (cons (cons (car files) found) ret)) | ||
| 445 | (setq found nil))) | ||
| 446 | (setq files (cdr files))) | ||
| 447 | (nreverse ret))) | ||
| 448 | |||
| 449 | (provide 'semantic/db-search) | ||
| 450 | |||
| 451 | ;;; semanticdb-search.el ends here | ||
diff --git a/lisp/cedet/semantic/db-typecache.el b/lisp/cedet/semantic/db-typecache.el new file mode 100644 index 00000000000..689e6d903f0 --- /dev/null +++ b/lisp/cedet/semantic/db-typecache.el | |||
| @@ -0,0 +1,585 @@ | |||
| 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/db) | ||
| 32 | (require 'semantic/db-find) | ||
| 33 | |||
| 34 | ;;; Code: | ||
| 35 | |||
| 36 | |||
| 37 | ;;; TABLE TYPECACHE | ||
| 38 | (defclass semanticdb-typecache () | ||
| 39 | ((filestream :initform nil | ||
| 40 | :documentation | ||
| 41 | "Fully sorted/merged list of tags within this buffer.") | ||
| 42 | (includestream :initform nil | ||
| 43 | :documentation | ||
| 44 | "Fully sorted/merged list of tags from this file's includes list.") | ||
| 45 | (stream :initform nil | ||
| 46 | :documentation | ||
| 47 | "The searchable tag stream for this cache. | ||
| 48 | NOTE: Can I get rid of this? Use a hashtable instead?") | ||
| 49 | (dependants :initform nil | ||
| 50 | :documentation | ||
| 51 | "Any other object that is dependent on typecache results. | ||
| 52 | Said object must support `semantic-reset' methods.") | ||
| 53 | ;; @todo - add some sort of fast-hash. | ||
| 54 | ;; @note - Rebuilds in large projects already take a while, and the | ||
| 55 | ;; actual searches are pretty fast. Really needed? | ||
| 56 | ) | ||
| 57 | "Structure for maintaining a typecache.") | ||
| 58 | |||
| 59 | (defmethod semantic-reset ((tc semanticdb-typecache)) | ||
| 60 | "Reset the object IDX." | ||
| 61 | (oset tc filestream nil) | ||
| 62 | (oset tc includestream nil) | ||
| 63 | |||
| 64 | (oset tc stream nil) | ||
| 65 | |||
| 66 | (mapc 'semantic-reset (oref tc dependants)) | ||
| 67 | (oset tc dependants nil) | ||
| 68 | ) | ||
| 69 | |||
| 70 | (defmethod semanticdb-typecache-notify-reset ((tc semanticdb-typecache)) | ||
| 71 | "Do a reset from a notify from a table we depend on." | ||
| 72 | (oset tc includestream nil) | ||
| 73 | (mapc 'semantic-reset (oref tc dependants)) | ||
| 74 | (oset tc dependants nil) | ||
| 75 | ) | ||
| 76 | |||
| 77 | (defmethod semanticdb-partial-synchronize ((tc semanticdb-typecache) | ||
| 78 | new-tags) | ||
| 79 | "Reset the typecache based on a partial reparse." | ||
| 80 | (when (semantic-find-tags-by-class 'include new-tags) | ||
| 81 | (oset tc includestream nil) | ||
| 82 | (mapc 'semantic-reset (oref tc dependants)) | ||
| 83 | (oset tc dependants nil) | ||
| 84 | ) | ||
| 85 | |||
| 86 | (when (semantic-find-tags-by-class 'type new-tags) | ||
| 87 | ;; Reset our index | ||
| 88 | (oset tc filestream nil) | ||
| 89 | t ;; Return true, our core file tags have changed in a relavant way. | ||
| 90 | ) | ||
| 91 | |||
| 92 | ;; NO CODE HERE | ||
| 93 | ) | ||
| 94 | |||
| 95 | (defun semanticdb-typecache-add-dependant (dep) | ||
| 96 | "Add into the local typecache a dependant DEP." | ||
| 97 | (let* ((table semanticdb-current-table) | ||
| 98 | ;;(idx (semanticdb-get-table-index table)) | ||
| 99 | (cache (semanticdb-get-typecache table)) | ||
| 100 | ) | ||
| 101 | (object-add-to-list cache 'dependants dep))) | ||
| 102 | |||
| 103 | (defun semanticdb-typecache-length(thing) | ||
| 104 | "How long is THING? | ||
| 105 | Debugging function." | ||
| 106 | (cond ((semanticdb-typecache-child-p thing) | ||
| 107 | (length (oref thing stream))) | ||
| 108 | ((semantic-tag-p thing) | ||
| 109 | (length (semantic-tag-type-members thing))) | ||
| 110 | ((and (listp thing) (semantic-tag-p (car thing))) | ||
| 111 | (length thing)) | ||
| 112 | ((null thing) | ||
| 113 | 0) | ||
| 114 | (t -1) )) | ||
| 115 | |||
| 116 | |||
| 117 | (defmethod semanticdb-get-typecache ((table semanticdb-abstract-table)) | ||
| 118 | "Retrieve the typecache from the semanticdb TABLE. | ||
| 119 | If there is no table, create one, and fill it in." | ||
| 120 | (semanticdb-refresh-table table) | ||
| 121 | (let* ((idx (semanticdb-get-table-index table)) | ||
| 122 | (cache (oref idx type-cache)) | ||
| 123 | ) | ||
| 124 | |||
| 125 | ;; Make sure we have a cache object in the DB index. | ||
| 126 | (when (not cache) | ||
| 127 | ;; The object won't change as we fill it with stuff. | ||
| 128 | (setq cache (semanticdb-typecache (semanticdb-full-filename table))) | ||
| 129 | (oset idx type-cache cache)) | ||
| 130 | |||
| 131 | cache)) | ||
| 132 | |||
| 133 | (defmethod semanticdb-have-typecache-p ((table semanticdb-abstract-table)) | ||
| 134 | "Return non-nil (the typecache) if TABLE has a pre-calculated typecache." | ||
| 135 | (let* ((idx (semanticdb-get-table-index table))) | ||
| 136 | (oref idx type-cache))) | ||
| 137 | |||
| 138 | |||
| 139 | ;;; DATABASE TYPECACHE | ||
| 140 | ;; | ||
| 141 | ;; A full database can cache the types across its files. | ||
| 142 | ;; | ||
| 143 | ;; Unlike file based caches, this one is a bit simpler, and just needs | ||
| 144 | ;; to get reset when a table gets updated. | ||
| 145 | |||
| 146 | (defclass semanticdb-database-typecache (semanticdb-abstract-db-cache) | ||
| 147 | ((stream :initform nil | ||
| 148 | :documentation | ||
| 149 | "The searchable tag stream for this cache.") | ||
| 150 | ) | ||
| 151 | "Structure for maintaining a typecache.") | ||
| 152 | |||
| 153 | (defmethod semantic-reset ((tc semanticdb-database-typecache)) | ||
| 154 | "Reset the object IDX." | ||
| 155 | (oset tc stream nil) | ||
| 156 | ) | ||
| 157 | |||
| 158 | (defmethod semanticdb-synchronize ((cache semanticdb-database-typecache) | ||
| 159 | new-tags) | ||
| 160 | "Synchronize a CACHE with some NEW-TAGS." | ||
| 161 | ) | ||
| 162 | |||
| 163 | (defmethod semanticdb-partial-synchronize ((cache semanticdb-database-typecache) | ||
| 164 | new-tags) | ||
| 165 | "Synchronize a CACHE with some changed NEW-TAGS." | ||
| 166 | ) | ||
| 167 | |||
| 168 | (defmethod semanticdb-get-typecache ((db semanticdb-project-database)) | ||
| 169 | "Retrieve the typecache from the semantic database DB. | ||
| 170 | If there is no table, create one, and fill it in." | ||
| 171 | (semanticdb-cache-get db semanticdb-database-typecache) | ||
| 172 | ) | ||
| 173 | |||
| 174 | |||
| 175 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | ||
| 176 | |||
| 177 | ;;; MERGING | ||
| 178 | ;; | ||
| 179 | ;; Managing long streams of tags representing data types. | ||
| 180 | ;; | ||
| 181 | (defun semanticdb-typecache-apply-filename (file stream) | ||
| 182 | "Apply the filename FILE to all tags in STREAM." | ||
| 183 | (let ((new nil)) | ||
| 184 | (while stream | ||
| 185 | (setq new (cons (semantic-tag-copy (car stream) nil file) | ||
| 186 | new)) | ||
| 187 | ;The below is handled by the tag-copy fcn. | ||
| 188 | ;(semantic--tag-put-property (car new) :filename file) | ||
| 189 | (setq stream (cdr stream))) | ||
| 190 | (nreverse new))) | ||
| 191 | |||
| 192 | |||
| 193 | (defsubst semanticdb-typecache-safe-tag-members (tag) | ||
| 194 | "Return a list of members for TAG that are safe to permute." | ||
| 195 | (let ((mem (semantic-tag-type-members tag)) | ||
| 196 | (fname (semantic-tag-file-name tag))) | ||
| 197 | (if fname | ||
| 198 | (setq mem (semanticdb-typecache-apply-filename fname mem)) | ||
| 199 | (copy-sequence mem)))) | ||
| 200 | |||
| 201 | (defsubst semanticdb-typecache-safe-tag-list (tags table) | ||
| 202 | "Make the tag list TAGS found in TABLE safe for the typecache. | ||
| 203 | Adds a filename and copies the tags." | ||
| 204 | (semanticdb-typecache-apply-filename | ||
| 205 | (semanticdb-full-filename table) | ||
| 206 | tags)) | ||
| 207 | |||
| 208 | (defun semanticdb-typecache-merge-streams (cache1 cache2) | ||
| 209 | "Merge into CACHE1 and CACHE2 together. The Caches will be merged in place." | ||
| 210 | (if (or (and (not cache1) (not cache2)) | ||
| 211 | (and (not (cdr cache1)) (not cache2)) | ||
| 212 | (and (not cache1) (not (cdr cache2)))) | ||
| 213 | ;; If all caches are empty OR | ||
| 214 | ;; cache1 is length 1 and no cache2 OR | ||
| 215 | ;; no cache1 and length 1 cache2 | ||
| 216 | ;; | ||
| 217 | ;; then just return the cache, and skip all this merging stuff. | ||
| 218 | (or cache1 cache2) | ||
| 219 | |||
| 220 | ;; Assume we always have datatypes, as this typecache isn't really | ||
| 221 | ;; useful without a typed language. | ||
| 222 | (let ((S (semantic-sort-tags-by-name-then-type-increasing | ||
| 223 | ;; I used to use append, but it copied cache1 but not cache2. | ||
| 224 | ;; Since sort was permuting cache2, I already had to make sure | ||
| 225 | ;; the caches were permute-safe. Might as well use nconc here. | ||
| 226 | (nconc cache1 cache2))) | ||
| 227 | (ans nil) | ||
| 228 | (next nil) | ||
| 229 | (prev nil) | ||
| 230 | (type nil)) | ||
| 231 | ;; With all the tags in order, we can loop over them, and when | ||
| 232 | ;; two have the same name, we can either throw one away, or construct | ||
| 233 | ;; a fresh new tag merging the items together. | ||
| 234 | (while S | ||
| 235 | (setq prev (car ans)) | ||
| 236 | (setq next (car S)) | ||
| 237 | (if (or | ||
| 238 | ;; CASE 1 - First item | ||
| 239 | (null prev) | ||
| 240 | ;; CASE 2 - New name | ||
| 241 | (not (string= (semantic-tag-name next) | ||
| 242 | (semantic-tag-name prev)))) | ||
| 243 | (setq ans (cons next ans)) | ||
| 244 | ;; ELSE - We have a NAME match. | ||
| 245 | (setq type (semantic-tag-type next)) | ||
| 246 | (if (semantic-tag-of-type-p prev type) ; Are they the same datatype | ||
| 247 | ;; Same Class, we can do a merge. | ||
| 248 | (cond | ||
| 249 | ((and (semantic-tag-of-class-p next 'type) | ||
| 250 | (string= type "namespace")) | ||
| 251 | ;; Namespaces - merge the children together. | ||
| 252 | (setcar ans | ||
| 253 | (semantic-tag-new-type | ||
| 254 | (semantic-tag-name prev) ; - they are the same | ||
| 255 | "namespace" ; - we know this as fact | ||
| 256 | (semanticdb-typecache-merge-streams | ||
| 257 | (semanticdb-typecache-safe-tag-members prev) | ||
| 258 | (semanticdb-typecache-safe-tag-members next)) | ||
| 259 | nil ; - no attributes | ||
| 260 | )) | ||
| 261 | ;; Make sure we mark this as a fake tag. | ||
| 262 | (semantic-tag-set-faux (car ans)) | ||
| 263 | ) | ||
| 264 | ((semantic-tag-prototype-p next) | ||
| 265 | ;; NEXT is a prototype... so keep previous. | ||
| 266 | nil ; - keep prev, do nothing | ||
| 267 | ) | ||
| 268 | ((semantic-tag-prototype-p prev) | ||
| 269 | ;; PREV is a prototype, but not next.. so keep NEXT. | ||
| 270 | ;; setcar - set by side-effect on top of prev | ||
| 271 | (setcar ans next) | ||
| 272 | ) | ||
| 273 | (t | ||
| 274 | ;;(message "Don't know how to merge %s. Keeping first entry." (semantic-tag-name next)) | ||
| 275 | )) | ||
| 276 | ;; Not same class... but same name | ||
| 277 | ;(message "Same name, different type: %s, %s!=%s" | ||
| 278 | ; (semantic-tag-name next) | ||
| 279 | ; (semantic-tag-type next) | ||
| 280 | ; (semantic-tag-type prev)) | ||
| 281 | (setq ans (cons next ans)) | ||
| 282 | )) | ||
| 283 | (setq S (cdr S))) | ||
| 284 | (nreverse ans)))) | ||
| 285 | |||
| 286 | ;;; Refresh / Query API | ||
| 287 | ;; | ||
| 288 | ;; Queries that can be made for the typecache. | ||
| 289 | (defmethod semanticdb-typecache-file-tags ((table semanticdb-abstract-table)) | ||
| 290 | "No tags available from non-file based tables." | ||
| 291 | nil) | ||
| 292 | |||
| 293 | (defmethod semanticdb-typecache-file-tags ((table semanticdb-table)) | ||
| 294 | "Update the typecache for TABLE, and return the file-tags. | ||
| 295 | File-tags are those that belong to this file only, and excludes | ||
| 296 | all included files." | ||
| 297 | (let* (;(idx (semanticdb-get-table-index table)) | ||
| 298 | (cache (semanticdb-get-typecache table)) | ||
| 299 | ) | ||
| 300 | |||
| 301 | ;; Make sure our file-tags list is up to date. | ||
| 302 | (when (not (oref cache filestream)) | ||
| 303 | (let ((tags (semantic-find-tags-by-class 'type table))) | ||
| 304 | (when tags | ||
| 305 | (setq tags (semanticdb-typecache-safe-tag-list tags table)) | ||
| 306 | (oset cache filestream (semanticdb-typecache-merge-streams tags nil))))) | ||
| 307 | |||
| 308 | ;; Return our cache. | ||
| 309 | (oref cache filestream) | ||
| 310 | )) | ||
| 311 | |||
| 312 | (defmethod semanticdb-typecache-include-tags ((table semanticdb-abstract-table)) | ||
| 313 | "No tags available from non-file based tables." | ||
| 314 | nil) | ||
| 315 | |||
| 316 | (defmethod semanticdb-typecache-include-tags ((table semanticdb-table)) | ||
| 317 | "Update the typecache for TABLE, and return the merged types from the include tags. | ||
| 318 | Include-tags are the tags brought in via includes, all merged together into | ||
| 319 | a master list." | ||
| 320 | (let* ((cache (semanticdb-get-typecache table)) | ||
| 321 | ) | ||
| 322 | |||
| 323 | ;; Make sure our file-tags list is up to date. | ||
| 324 | (when (not (oref cache includestream)) | ||
| 325 | (let (;; Calc the path first. This will have a nice side -effect of | ||
| 326 | ;; getting the cache refreshed if a refresh is needed. Most of the | ||
| 327 | ;; time this value is itself cached, so the query is fast. | ||
| 328 | (incpath (semanticdb-find-translate-path table nil)) | ||
| 329 | (incstream nil)) | ||
| 330 | ;; Get the translated path, and extract all the type tags, then merge | ||
| 331 | ;; them all together. | ||
| 332 | (dolist (i incpath) | ||
| 333 | ;; don't include ourselves in this crazy list. | ||
| 334 | (when (and i (not (eq i table)) | ||
| 335 | ;; @todo - This eieio fcn can be slow! Do I need it? | ||
| 336 | ;; (semanticdb-table-child-p i) | ||
| 337 | ) | ||
| 338 | (setq incstream | ||
| 339 | (semanticdb-typecache-merge-streams | ||
| 340 | incstream | ||
| 341 | ;; Getting the cache from this table will also cause this | ||
| 342 | ;; file to update it's cache from it's decendants. | ||
| 343 | ;; | ||
| 344 | ;; In theory, caches are only built for most includes | ||
| 345 | ;; only once (in the loop before this one), so this ends | ||
| 346 | ;; up being super fast as we edit our file. | ||
| 347 | (copy-sequence | ||
| 348 | (semanticdb-typecache-file-tags i)))) | ||
| 349 | )) | ||
| 350 | |||
| 351 | ;; Save... | ||
| 352 | (oset cache includestream incstream))) | ||
| 353 | |||
| 354 | ;; Return our cache. | ||
| 355 | (oref cache includestream) | ||
| 356 | )) | ||
| 357 | |||
| 358 | |||
| 359 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | ||
| 360 | |||
| 361 | ;;; Search Routines | ||
| 362 | ;; | ||
| 363 | (define-overloadable-function semanticdb-typecache-find (type &optional path find-file-match) | ||
| 364 | "Search the typecache for TYPE in PATH. | ||
| 365 | If type is a string, split the string, and search for the parts. | ||
| 366 | If type is a list, treat the type as a pre-split string. | ||
| 367 | PATH can be nil for the current buffer, or a semanticdb table. | ||
| 368 | FIND-FILE-MATCH is non-nil to force all found tags to be loaded into a buffer.") | ||
| 369 | |||
| 370 | (defun semanticdb-typecache-find-default (type &optional path find-file-match) | ||
| 371 | "Default implementation of `semanticdb-typecache-find'. | ||
| 372 | TYPE is the datatype to find. | ||
| 373 | PATH is the search path.. which should be one table object. | ||
| 374 | If FIND-FILE-MATCH is non-nil, then force the file belonging to the | ||
| 375 | found tag to be loaded." | ||
| 376 | (semanticdb-typecache-find-method (or path semanticdb-current-table) | ||
| 377 | type find-file-match)) | ||
| 378 | |||
| 379 | (defun semanticdb-typecache-find-by-name-helper (name table) | ||
| 380 | "Find the tag with NAME in TABLE, which is from a typecache. | ||
| 381 | If more than one tag has NAME in TABLE, we will prefer the tag that | ||
| 382 | is of class 'type." | ||
| 383 | (let* ((names (semantic-find-tags-by-name name table)) | ||
| 384 | (types (semantic-find-tags-by-class 'type names))) | ||
| 385 | (or (car-safe types) (car-safe names)))) | ||
| 386 | |||
| 387 | (defmethod semanticdb-typecache-find-method ((table semanticdb-abstract-table) | ||
| 388 | type find-file-match) | ||
| 389 | "Search the typecache in TABLE for the datatype TYPE. | ||
| 390 | If type is a string, split the string, and search for the parts. | ||
| 391 | If type is a list, treat the type as a pre-split string. | ||
| 392 | If FIND-FILE-MATCH is non-nil, then force the file belonging to the | ||
| 393 | found tag to be loaded." | ||
| 394 | ;; convert string to a list. | ||
| 395 | (when (stringp type) (setq type (semantic-analyze-split-name type))) | ||
| 396 | (when (stringp type) (setq type (list type))) | ||
| 397 | |||
| 398 | ;; Search for the list in our typecache. | ||
| 399 | (let* ((file (semanticdb-typecache-file-tags table)) | ||
| 400 | (inc (semanticdb-typecache-include-tags table)) | ||
| 401 | (stream nil) | ||
| 402 | (f-ans nil) | ||
| 403 | (i-ans nil) | ||
| 404 | (ans nil) | ||
| 405 | (notdone t) | ||
| 406 | (lastfile nil) | ||
| 407 | (thisfile nil) | ||
| 408 | (lastans nil) | ||
| 409 | (calculated-scope nil) | ||
| 410 | ) | ||
| 411 | ;; 1) Find first symbol in the two master lists and then merge | ||
| 412 | ;; the found streams. | ||
| 413 | |||
| 414 | ;; We stripped duplicates, so these will be super-fast! | ||
| 415 | (setq f-ans (semantic-find-first-tag-by-name (car type) file)) | ||
| 416 | (setq i-ans (semantic-find-first-tag-by-name (car type) inc)) | ||
| 417 | (if (and f-ans i-ans) | ||
| 418 | (progn | ||
| 419 | ;; This trick merges the two identified tags, making sure our lists are | ||
| 420 | ;; complete. The second find then gets the new 'master' from the list of 2. | ||
| 421 | (setq ans (semanticdb-typecache-merge-streams (list f-ans) (list i-ans))) | ||
| 422 | (setq ans (semantic-find-first-tag-by-name (car type) ans)) | ||
| 423 | ) | ||
| 424 | |||
| 425 | ;; The answers are already sorted and merged, so if one misses, | ||
| 426 | ;; no need to do any special work. | ||
| 427 | (setq ans (or f-ans i-ans))) | ||
| 428 | |||
| 429 | ;; 2) Loop over the remaining parts. | ||
| 430 | (while (and type notdone) | ||
| 431 | |||
| 432 | ;; For pass > 1, stream will be non-nil, so do a search, otherwise | ||
| 433 | ;; ans is from outside the loop. | ||
| 434 | (when stream | ||
| 435 | (setq ans (semanticdb-typecache-find-by-name-helper (car type) stream)) | ||
| 436 | |||
| 437 | ;; NOTE: The below test to make sure we get a type is only relevant | ||
| 438 | ;; for the SECOND pass or later. The first pass can only ever | ||
| 439 | ;; find a type/namespace because everything else is excluded. | ||
| 440 | |||
| 441 | ;; If this is not the last entry from the list, then it | ||
| 442 | ;; must be a type or a namespace. Lets double check. | ||
| 443 | (when (cdr type) | ||
| 444 | |||
| 445 | ;; From above, there is only one tag in ans, and we prefer | ||
| 446 | ;; types. | ||
| 447 | (when (not (semantic-tag-of-class-p ans 'type)) | ||
| 448 | |||
| 449 | (setq ans nil))) | ||
| 450 | ) | ||
| 451 | |||
| 452 | (push ans calculated-scope) | ||
| 453 | |||
| 454 | ;; Track most recent file. | ||
| 455 | (setq thisfile (semantic-tag-file-name ans)) | ||
| 456 | (when (and thisfile (stringp thisfile)) | ||
| 457 | (setq lastfile thisfile)) | ||
| 458 | |||
| 459 | ;; If we have a miss, exit, otherwise, update the stream to | ||
| 460 | ;; the next set of members. | ||
| 461 | (if (not ans) | ||
| 462 | (setq notdone nil) | ||
| 463 | (setq stream (semantic-tag-type-members ans))) | ||
| 464 | |||
| 465 | (setq lastans ans | ||
| 466 | ans nil | ||
| 467 | type (cdr type))) | ||
| 468 | |||
| 469 | (if (or type (not notdone)) | ||
| 470 | ;; If there is stuff left over, then we failed. Just return | ||
| 471 | ;; nothing. | ||
| 472 | nil | ||
| 473 | |||
| 474 | ;; We finished, so return everything. | ||
| 475 | |||
| 476 | (if (and find-file-match lastfile) | ||
| 477 | ;; This won't liven up the tag since we have a copy, but | ||
| 478 | ;; we ought to be able to get there and go to the right line. | ||
| 479 | (find-file-noselect lastfile) | ||
| 480 | ;; We don't want to find-file match, so instead lets | ||
| 481 | ;; push the filename onto the return tag. | ||
| 482 | (when lastans | ||
| 483 | (setq lastans (semantic-tag-copy lastans nil lastfile)) | ||
| 484 | ;; We used to do the below, but we would erroneously be putting | ||
| 485 | ;; attributes on tags being shred with other lists. | ||
| 486 | ;;(semantic--tag-put-property lastans :filename lastfile) | ||
| 487 | ) | ||
| 488 | ) | ||
| 489 | |||
| 490 | (if (and lastans calculated-scope) | ||
| 491 | |||
| 492 | ;; Put our discovered scope into the tag if we have a tag | ||
| 493 | (semantic-scope-tag-clone-with-scope | ||
| 494 | lastans (reverse (cdr calculated-scope))) | ||
| 495 | |||
| 496 | ;; Else, just return | ||
| 497 | lastans | ||
| 498 | )))) | ||
| 499 | |||
| 500 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | ||
| 501 | |||
| 502 | ;;; BRUTISH Typecache | ||
| 503 | ;; | ||
| 504 | ;; Routines for a typecache that crosses all tables in a given database | ||
| 505 | ;; for a matching major-mode. | ||
| 506 | (defmethod semanticdb-typecache-for-database ((db semanticdb-project-database) | ||
| 507 | &optional mode) | ||
| 508 | "Return the typecache for the project database DB. | ||
| 509 | If there isn't one, create it. | ||
| 510 | " | ||
| 511 | (let ((lmode (or mode major-mode)) | ||
| 512 | (cache (semanticdb-get-typecache db)) | ||
| 513 | (stream nil) | ||
| 514 | ) | ||
| 515 | (dolist (table (semanticdb-get-database-tables db)) | ||
| 516 | (when (eq lmode (oref table :major-mode)) | ||
| 517 | (setq stream | ||
| 518 | (semanticdb-typecache-merge-streams | ||
| 519 | stream | ||
| 520 | (copy-sequence | ||
| 521 | (semanticdb-typecache-file-tags table)))) | ||
| 522 | )) | ||
| 523 | (oset cache stream stream) | ||
| 524 | cache)) | ||
| 525 | |||
| 526 | (defun semanticdb-typecache-refresh-for-buffer (buffer) | ||
| 527 | "Refresh the typecache for BUFFER." | ||
| 528 | (save-excursion | ||
| 529 | (set-buffer buffer) | ||
| 530 | (let* ((tab semanticdb-current-table) | ||
| 531 | ;(idx (semanticdb-get-table-index tab)) | ||
| 532 | (tc (semanticdb-get-typecache tab))) | ||
| 533 | (semanticdb-typecache-file-tags tab) | ||
| 534 | (semanticdb-typecache-include-tags tab) | ||
| 535 | tc))) | ||
| 536 | |||
| 537 | |||
| 538 | ;;; DEBUG | ||
| 539 | ;; | ||
| 540 | (defun semanticdb-typecache-complete-flush () | ||
| 541 | "Flush all typecaches referenced by the current buffer." | ||
| 542 | (interactive) | ||
| 543 | (let* ((path (semanticdb-find-translate-path nil nil))) | ||
| 544 | (dolist (P path) | ||
| 545 | (oset P pointmax nil) | ||
| 546 | (semantic-reset (semanticdb-get-typecache P))))) | ||
| 547 | |||
| 548 | (defun semanticdb-typecache-dump () | ||
| 549 | "Dump the typecache for the current buffer." | ||
| 550 | (interactive) | ||
| 551 | (require 'data-debug) | ||
| 552 | (let* ((start (current-time)) | ||
| 553 | (tc (semanticdb-typecache-refresh-for-buffer (current-buffer))) | ||
| 554 | (end (current-time)) | ||
| 555 | ) | ||
| 556 | (data-debug-new-buffer "*TypeCache ADEBUG*") | ||
| 557 | (message "Calculating Cache took %.2f seconds." | ||
| 558 | (semantic-elapsed-time start end)) | ||
| 559 | |||
| 560 | (data-debug-insert-thing tc "]" "") | ||
| 561 | |||
| 562 | )) | ||
| 563 | |||
| 564 | (defun semanticdb-db-typecache-dump () | ||
| 565 | "Dump the typecache for the current buffer's database." | ||
| 566 | (interactive) | ||
| 567 | (require 'data-debug) | ||
| 568 | (let* ((tab semanticdb-current-table) | ||
| 569 | (idx (semanticdb-get-table-index tab)) | ||
| 570 | (junk (oset idx type-cache nil)) ;; flush! | ||
| 571 | (start (current-time)) | ||
| 572 | (tc (semanticdb-typecache-for-database (oref tab parent-db))) | ||
| 573 | (end (current-time)) | ||
| 574 | ) | ||
| 575 | (data-debug-new-buffer "*TypeCache ADEBUG*") | ||
| 576 | (message "Calculating Cache took %.2f seconds." | ||
| 577 | (semantic-elapsed-time start end)) | ||
| 578 | |||
| 579 | (data-debug-insert-thing tc "]" "") | ||
| 580 | |||
| 581 | )) | ||
| 582 | |||
| 583 | |||
| 584 | (provide 'semantic/db-typecache) | ||
| 585 | ;;; semanticdb-typecache.el ends here | ||
diff --git a/lisp/cedet/semantic/dep.el b/lisp/cedet/semantic/dep.el new file mode 100644 index 00000000000..4c67c6674f2 --- /dev/null +++ b/lisp/cedet/semantic/dep.el | |||
| @@ -0,0 +1,228 @@ | |||
| 1 | ;;; dep.el --- Methods for tracking dependencies (include files) | ||
| 2 | |||
| 3 | ;;; Copyright (C) 2006, 2007, 2008, 2009 Free Software Foundation, Inc. | ||
| 4 | |||
| 5 | ;; Author: Eric M. Ludlam <zappo@gnu.org> | ||
| 6 | ;; Keywords: syntax | ||
| 7 | |||
| 8 | ;; This file is part of GNU Emacs. | ||
| 9 | |||
| 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
| 11 | ;; it under the terms of the GNU General Public License as published by | ||
| 12 | ;; the Free Software Foundation, either version 3 of the License, or | ||
| 13 | ;; (at your option) any later version. | ||
| 14 | |||
| 15 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 18 | ;; GNU General Public License for more details. | ||
| 19 | |||
| 20 | ;; You should have received a copy of the GNU General Public License | ||
| 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | ||
| 22 | |||
| 23 | ;;; Commentary: | ||
| 24 | ;; | ||
| 25 | ;; Include tags (dependencies for a given source file) usually have | ||
| 26 | ;; some short name. The target file that it is dependent on is | ||
| 27 | ;; generally found on some sort of path controlled by the compiler or | ||
| 28 | ;; project. | ||
| 29 | ;; | ||
| 30 | ;; EDE or even ECB can control our project dependencies, and help us | ||
| 31 | ;; find file within the setting of a given project. For system | ||
| 32 | ;; dependencies, we need to depend on user supplied lists, which can | ||
| 33 | ;; manifest themselves in the form of system datatabases (from | ||
| 34 | ;; semanticdb.) | ||
| 35 | ;; | ||
| 36 | ;; Provide ways to track these different files here. | ||
| 37 | |||
| 38 | (require 'semantic/tag) | ||
| 39 | |||
| 40 | ;;; Code: | ||
| 41 | |||
| 42 | (defvar semantic-dependency-include-path nil | ||
| 43 | "Defines the include path used when searching for files. | ||
| 44 | This should be a list of directories to search which is specific | ||
| 45 | to the file being included. | ||
| 46 | |||
| 47 | If `semantic-dependency-tag-file' is overridden for a given | ||
| 48 | language, this path is most likely ignored. | ||
| 49 | |||
| 50 | The above function, reguardless of being overriden, caches the | ||
| 51 | located dependency file location in the tag property | ||
| 52 | `dependency-file'. If you override this function, you do not | ||
| 53 | need to implement your own cache. Each time the buffer is fully | ||
| 54 | reparsed, the cache will be reset. | ||
| 55 | |||
| 56 | TODO: use ffap.el to locate such items? | ||
| 57 | |||
| 58 | NOTE: Obsolete this, or use as special user") | ||
| 59 | (make-variable-buffer-local `semantic-dependency-include-path) | ||
| 60 | |||
| 61 | (defvar semantic-dependency-system-include-path nil | ||
| 62 | "Defines the system include path. | ||
| 63 | This should be set with either `defvar-mode-local', or with | ||
| 64 | `semantic-add-system-include'. | ||
| 65 | |||
| 66 | For mode authors, use | ||
| 67 | `defcustom-mode-local-semantic-dependency-system-include-path' | ||
| 68 | to create a mode-specific variable to control this. | ||
| 69 | |||
| 70 | When searching for a file associated with a name found in an tag of | ||
| 71 | class include, this path will be inspected for includes of type | ||
| 72 | `system'. Some include tags are agnostic to this setting and will | ||
| 73 | check both the project and system directories.") | ||
| 74 | (make-variable-buffer-local `semantic-dependency-system-include-path) | ||
| 75 | |||
| 76 | (defmacro defcustom-mode-local-semantic-dependency-system-include-path | ||
| 77 | (mode name value &optional docstring) | ||
| 78 | "Create a mode-local value of the system-dependency include path. | ||
| 79 | MODE is the `major-mode' this name/value pairs is for. | ||
| 80 | NAME is the name of the customizable value users will use. | ||
| 81 | VALUE is the path (a list of strings) to add. | ||
| 82 | DOCSTRING is a documentation string applied to the variable NAME | ||
| 83 | users will customize. | ||
| 84 | |||
| 85 | Creates a customizable variable users can customize that will | ||
| 86 | keep semantic data structures up to date." | ||
| 87 | `(progn | ||
| 88 | ;; Create a variable users can customize. | ||
| 89 | (defcustom ,name ,value | ||
| 90 | ,docstring | ||
| 91 | :group (quote ,(intern (car (split-string (symbol-name mode) "-")))) | ||
| 92 | :group 'semantic | ||
| 93 | :type '(repeat (directory :tag "Directory")) | ||
| 94 | :set (lambda (sym val) | ||
| 95 | (set-default sym val) | ||
| 96 | (setq-mode-local ,mode | ||
| 97 | semantic-dependency-system-include-path | ||
| 98 | val) | ||
| 99 | (when (fboundp | ||
| 100 | 'semantic-decoration-unparsed-include-do-reset) | ||
| 101 | (mode-local-map-mode-buffers | ||
| 102 | 'semantic-decoration-unparsed-include-do-reset | ||
| 103 | (quote ,mode)))) | ||
| 104 | ) | ||
| 105 | ;; Set the variable to the default value. | ||
| 106 | (defvar-mode-local ,mode semantic-dependency-system-include-path | ||
| 107 | ,name | ||
| 108 | "System path to search for include files.") | ||
| 109 | ;; Bind NAME onto our variable so tools can customize it | ||
| 110 | ;; without knowing about it. | ||
| 111 | (put 'semantic-dependency-system-include-path | ||
| 112 | (quote ,mode) (quote ,name)) | ||
| 113 | )) | ||
| 114 | |||
| 115 | ;;; PATH MANAGEMENT | ||
| 116 | ;; | ||
| 117 | ;; Some fcns to manage paths for a give mode. | ||
| 118 | (defun semantic-add-system-include (dir &optional mode) | ||
| 119 | "Add a system include DIR to path for MODE. | ||
| 120 | Modifies a mode-local version of `semantic-dependency-system-include-path'. | ||
| 121 | |||
| 122 | Changes made by this function are not persistent." | ||
| 123 | (interactive "DNew Include Directory: ") | ||
| 124 | (if (not mode) (setq mode major-mode)) | ||
| 125 | (let ((dirtmp (file-name-as-directory dir)) | ||
| 126 | (value | ||
| 127 | (mode-local-value mode 'semantic-dependency-system-include-path)) | ||
| 128 | ) | ||
| 129 | (add-to-list 'value dirtmp t) | ||
| 130 | (eval `(setq-mode-local ,mode | ||
| 131 | semantic-dependency-system-include-path value)) | ||
| 132 | )) | ||
| 133 | |||
| 134 | (defun semantic-remove-system-include (dir &optional mode) | ||
| 135 | "Add a system include DIR to path for MODE. | ||
| 136 | Modifies a mode-local version of`semantic-dependency-system-include-path'. | ||
| 137 | |||
| 138 | Changes made by this function are not persistent." | ||
| 139 | (interactive (list | ||
| 140 | (completing-read | ||
| 141 | "Include Directory to Remove: " | ||
| 142 | semantic-dependency-system-include-path)) | ||
| 143 | ) | ||
| 144 | (if (not mode) (setq mode major-mode)) | ||
| 145 | (let ((dirtmp (file-name-as-directory dir)) | ||
| 146 | (value | ||
| 147 | (mode-local-value mode 'semantic-dependency-system-include-path)) | ||
| 148 | ) | ||
| 149 | (setq value (delete dirtmp value)) | ||
| 150 | (eval `(setq-mode-local ,mode semantic-dependency-system-include-path | ||
| 151 | value)) | ||
| 152 | )) | ||
| 153 | |||
| 154 | (defun semantic-reset-system-include (&optional mode) | ||
| 155 | "Reset the system include list to empty for MODE. | ||
| 156 | Modifies a mode-local version of | ||
| 157 | `semantic-dependency-system-include-path'." | ||
| 158 | (interactive) | ||
| 159 | (if (not mode) (setq mode major-mode)) | ||
| 160 | (eval `(setq-mode-local ,mode semantic-dependency-system-include-path | ||
| 161 | nil)) | ||
| 162 | ) | ||
| 163 | |||
| 164 | (defun semantic-customize-system-include-path (&optional mode) | ||
| 165 | "Customize the include path for this `major-mode'. | ||
| 166 | To create a customizable include path for a major MODE, use the | ||
| 167 | macro `defcustom-mode-local-semantic-dependency-system-include-path'." | ||
| 168 | (interactive) | ||
| 169 | (let ((ips (get 'semantic-dependency-system-include-path | ||
| 170 | (or mode major-mode)))) | ||
| 171 | ;; Do we have one? | ||
| 172 | (when (not ips) | ||
| 173 | (error "There is no customizable includepath variable for %s" | ||
| 174 | (or mode major-mode))) | ||
| 175 | ;; Customize it. | ||
| 176 | (customize-variable ips))) | ||
| 177 | |||
| 178 | ;;; PATH SEARCH | ||
| 179 | ;; | ||
| 180 | ;; methods for finding files on a provided path. | ||
| 181 | (if (fboundp 'locate-file) | ||
| 182 | (defsubst semantic--dependency-find-file-on-path (file path) | ||
| 183 | "Return an expanded file name for FILE on PATH." | ||
| 184 | (locate-file file path)) | ||
| 185 | |||
| 186 | ;; Else, older version of Emacs. | ||
| 187 | |||
| 188 | (defsubst semantic--dependency-find-file-on-path (file path) | ||
| 189 | "Return an expanded file name for FILE on PATH." | ||
| 190 | (let ((p path) | ||
| 191 | (found nil)) | ||
| 192 | (while (and p (not found)) | ||
| 193 | (let ((f (expand-file-name file (car p)))) | ||
| 194 | (if (file-exists-p f) | ||
| 195 | (setq found f))) | ||
| 196 | (setq p (cdr p))) | ||
| 197 | found)) | ||
| 198 | |||
| 199 | ) | ||
| 200 | |||
| 201 | (defun semantic-dependency-find-file-on-path (file systemp &optional mode) | ||
| 202 | "Return an expanded file name for FILE on available paths. | ||
| 203 | If SYSTEMP is true, then only search system paths. | ||
| 204 | If optional argument MODE is non-nil, then derive paths from the | ||
| 205 | provided mode, not from the current major mode." | ||
| 206 | (if (not mode) (setq mode major-mode)) | ||
| 207 | (let ((sysp (mode-local-value | ||
| 208 | mode 'semantic-dependency-system-include-path)) | ||
| 209 | (edesys (when (and (featurep 'ede) ede-minor-mode | ||
| 210 | ede-object) | ||
| 211 | (ede-system-include-path ede-object))) | ||
| 212 | (locp (mode-local-value | ||
| 213 | mode 'semantic-dependency-include-path)) | ||
| 214 | (found nil)) | ||
| 215 | (when (file-exists-p file) | ||
| 216 | (setq found file)) | ||
| 217 | (when (and (not found) (not systemp)) | ||
| 218 | (setq found (semantic--dependency-find-file-on-path file locp))) | ||
| 219 | (when (and (not found) edesys) | ||
| 220 | (setq found (semantic--dependency-find-file-on-path file edesys))) | ||
| 221 | (when (not found) | ||
| 222 | (setq found (semantic--dependency-find-file-on-path file sysp))) | ||
| 223 | (if found (expand-file-name found)))) | ||
| 224 | |||
| 225 | |||
| 226 | (provide 'semantic/dep) | ||
| 227 | |||
| 228 | ;;; semantic-dep.el ends here | ||
diff --git a/lisp/cedet/semantic/ia.el b/lisp/cedet/semantic/ia.el new file mode 100644 index 00000000000..eadf89439ab --- /dev/null +++ b/lisp/cedet/semantic/ia.el | |||
| @@ -0,0 +1,439 @@ | |||
| 1 | ;;; ia.el --- Interactive Analysis functions | ||
| 2 | |||
| 3 | ;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, | ||
| 4 | ;;; 2008, 2009 Free Software Foundation, Inc. | ||
| 5 | |||
| 6 | ;; Author: Eric M. Ludlam <zappo@gnu.org> | ||
| 7 | ;; Keywords: syntax | ||
| 8 | |||
| 9 | ;; This file is part of GNU Emacs. | ||
| 10 | |||
| 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
| 12 | ;; it under the terms of the GNU General Public License as published by | ||
| 13 | ;; the Free Software Foundation, either version 3 of the License, or | ||
| 14 | ;; (at your option) any later version. | ||
| 15 | |||
| 16 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 19 | ;; GNU General Public License for more details. | ||
| 20 | |||
| 21 | ;; You should have received a copy of the GNU General Public License | ||
| 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | ||
| 23 | |||
| 24 | ;;; Commentary: | ||
| 25 | ;; | ||
| 26 | ;; Interactive access to `semantic-analyze'. | ||
| 27 | ;; | ||
| 28 | ;; These routines are fairly simple, and show how to use the Semantic | ||
| 29 | ;; analyzer to provide things such as completion lists, summaries, | ||
| 30 | ;; locations, or documentation. | ||
| 31 | ;; | ||
| 32 | |||
| 33 | ;;; TODO | ||
| 34 | ;; | ||
| 35 | ;; fast-jump. For a virtual method, offer some of the possible | ||
| 36 | ;; implementations in various sub-classes. | ||
| 37 | |||
| 38 | (require 'senator) | ||
| 39 | (require 'semantic/analyze) | ||
| 40 | (require 'pulse) | ||
| 41 | (eval-when-compile | ||
| 42 | (require 'semantic/analyze) | ||
| 43 | (require 'semantic/analyze/refs)) | ||
| 44 | |||
| 45 | ;;; Code: | ||
| 46 | |||
| 47 | ;;; COMPLETION | ||
| 48 | ;; | ||
| 49 | ;; This set of routines provides some simplisting completion | ||
| 50 | ;; functions. | ||
| 51 | |||
| 52 | (defcustom semantic-ia-completion-format-tag-function | ||
| 53 | 'semantic-prototype-nonterminal | ||
| 54 | "*Function used to convert a tag to a string during completion." | ||
| 55 | :group 'semantic | ||
| 56 | :type semantic-format-tag-custom-list) | ||
| 57 | |||
| 58 | (defvar semantic-ia-cache nil | ||
| 59 | "Cache of the last completion request. | ||
| 60 | Of the form ( POINT . COMPLETIONS ) where POINT is a location in the | ||
| 61 | buffer where the completion was requested. COMPLETONS is the list | ||
| 62 | of semantic tag names that provide logical completions from that | ||
| 63 | location.") | ||
| 64 | (make-variable-buffer-local 'semantic-ia-cache) | ||
| 65 | |||
| 66 | (defun semantic-ia-get-completions (context point) | ||
| 67 | "Fetch the completion of CONTEXT at POINT. | ||
| 68 | Supports caching." | ||
| 69 | ;; Cache the current set of symbols so that we can get at | ||
| 70 | ;; them quickly the second time someone presses the | ||
| 71 | ;; complete button. | ||
| 72 | (let ((symbols | ||
| 73 | (if (and semantic-ia-cache | ||
| 74 | (= point (car semantic-ia-cache))) | ||
| 75 | (cdr semantic-ia-cache) | ||
| 76 | (semantic-analyze-possible-completions context)))) | ||
| 77 | ;; Set the cache | ||
| 78 | (setq semantic-ia-cache (cons point symbols)) | ||
| 79 | symbols)) | ||
| 80 | |||
| 81 | (defun semantic-ia-complete-symbol (point) | ||
| 82 | "Complete the current symbol at POINT. | ||
| 83 | Completion options are calculated with `semantic-analyze-possible-completions'." | ||
| 84 | (interactive "d") | ||
| 85 | ;; Calculating completions is a two step process. | ||
| 86 | ;; | ||
| 87 | ;; The first analyzer the current context, which finds tags | ||
| 88 | ;; for all the stuff that may be references by the code around | ||
| 89 | ;; POINT. | ||
| 90 | ;; | ||
| 91 | ;; The second step derives completions from that context. | ||
| 92 | (let* ((a (semantic-analyze-current-context point)) | ||
| 93 | (syms (semantic-ia-get-completions a point)) | ||
| 94 | (pre (car (reverse (oref a prefix)))) | ||
| 95 | ) | ||
| 96 | ;; If PRE was actually an already completed symbol, it doesn't | ||
| 97 | ;; come in as a string, but as a tag instead. | ||
| 98 | (if (semantic-tag-p pre) | ||
| 99 | ;; We will try completions on it anyway. | ||
| 100 | (setq pre (semantic-tag-name pre))) | ||
| 101 | ;; Complete this symbol. | ||
| 102 | (if (null syms) | ||
| 103 | (progn | ||
| 104 | ;(message "No smart completions found. Trying senator-complete-symbol.") | ||
| 105 | (if (semantic-analyze-context-p a) | ||
| 106 | ;; This is a clever hack. If we were unable to find any | ||
| 107 | ;; smart completions, lets divert to how senator derives | ||
| 108 | ;; completions. | ||
| 109 | ;; | ||
| 110 | ;; This is a way of making this fcn more useful since the | ||
| 111 | ;; smart completion engine sometimes failes. | ||
| 112 | (senator-complete-symbol) | ||
| 113 | )) | ||
| 114 | ;; Use try completion to seek a common substring. | ||
| 115 | (let ((tc (try-completion (or pre "") syms))) | ||
| 116 | (if (and (stringp tc) (not (string= tc (or pre "")))) | ||
| 117 | (let ((tok (semantic-find-first-tag-by-name | ||
| 118 | tc syms))) | ||
| 119 | ;; Delete what came before... | ||
| 120 | (when (and (car (oref a bounds)) (cdr (oref a bounds))) | ||
| 121 | (delete-region (car (oref a bounds)) | ||
| 122 | (cdr (oref a bounds))) | ||
| 123 | (goto-char (car (oref a bounds)))) | ||
| 124 | ;; We have some new text. Stick it in. | ||
| 125 | (if tok | ||
| 126 | (semantic-ia-insert-tag tok) | ||
| 127 | (insert tc))) | ||
| 128 | ;; We don't have new text. Show all completions. | ||
| 129 | (when (cdr (oref a bounds)) | ||
| 130 | (goto-char (cdr (oref a bounds)))) | ||
| 131 | (with-output-to-temp-buffer "*Completions*" | ||
| 132 | (display-completion-list | ||
| 133 | (mapcar semantic-ia-completion-format-tag-function syms)) | ||
| 134 | )))))) | ||
| 135 | |||
| 136 | (defcustom semantic-ia-completion-menu-format-tag-function | ||
| 137 | 'semantic-uml-concise-prototype-nonterminal | ||
| 138 | "*Function used to convert a tag to a string during completion." | ||
| 139 | :group 'semantic | ||
| 140 | :type semantic-format-tag-custom-list) | ||
| 141 | |||
| 142 | (defun semantic-ia-complete-symbol-menu (point) | ||
| 143 | "Complete the current symbol via a menu based at POINT. | ||
| 144 | Completion options are calculated with `semantic-analyze-possible-completions'." | ||
| 145 | (interactive "d") | ||
| 146 | (let* ((a (semantic-analyze-current-context point)) | ||
| 147 | (syms (semantic-ia-get-completions a point)) | ||
| 148 | ) | ||
| 149 | ;; Complete this symbol. | ||
| 150 | (if (not syms) | ||
| 151 | (progn | ||
| 152 | (message "No smart completions found. Trying Senator.") | ||
| 153 | (when (semantic-analyze-context-p a) | ||
| 154 | ;; This is a quick way of getting a nice completion list | ||
| 155 | ;; in the menu if the regular context mechanism fails. | ||
| 156 | (senator-completion-menu-popup))) | ||
| 157 | |||
| 158 | (let* ((menu | ||
| 159 | (mapcar | ||
| 160 | (lambda (tag) | ||
| 161 | (cons | ||
| 162 | (funcall semantic-ia-completion-menu-format-tag-function tag) | ||
| 163 | (vector tag))) | ||
| 164 | syms)) | ||
| 165 | (ans | ||
| 166 | (imenu--mouse-menu | ||
| 167 | ;; XEmacs needs that the menu has at least 2 items. So, | ||
| 168 | ;; include a nil item that will be ignored by imenu. | ||
| 169 | (cons nil menu) | ||
| 170 | (senator-completion-menu-point-as-event) | ||
| 171 | "Completions"))) | ||
| 172 | (when ans | ||
| 173 | (if (not (semantic-tag-p ans)) | ||
| 174 | (setq ans (aref (cdr ans) 0))) | ||
| 175 | (delete-region (car (oref a bounds)) (cdr (oref a bounds))) | ||
| 176 | (semantic-ia-insert-tag ans)) | ||
| 177 | )))) | ||
| 178 | |||
| 179 | ;;; COMPLETION HELPER | ||
| 180 | ;; | ||
| 181 | ;; This overload function handles inserting a tag | ||
| 182 | ;; into a buffer for these local completion routines. | ||
| 183 | ;; | ||
| 184 | ;; By creating the functions as overloadable, it can be | ||
| 185 | ;; customized. For example, the default will put a paren "(" | ||
| 186 | ;; character after function names. For Lisp, it might check | ||
| 187 | ;; to put a "(" in front of a function name. | ||
| 188 | |||
| 189 | (define-overloadable-function semantic-ia-insert-tag (tag) | ||
| 190 | "Insert TAG into the current buffer based on completion.") | ||
| 191 | |||
| 192 | (defun semantic-ia-insert-tag-default (tag) | ||
| 193 | "Insert TAG into the current buffer based on completion." | ||
| 194 | (insert (semantic-tag-name tag)) | ||
| 195 | (let ((tt (semantic-tag-class tag))) | ||
| 196 | (cond ((eq tt 'function) | ||
| 197 | (insert "(")) | ||
| 198 | (t nil)))) | ||
| 199 | |||
| 200 | ;;; Completions Tip | ||
| 201 | ;; | ||
| 202 | ;; This functions shows how to get the list of completions, | ||
| 203 | ;; to place in a tooltip. It doesn't actually do any completion. | ||
| 204 | |||
| 205 | (defun semantic-ia-complete-tip (point) | ||
| 206 | "Pop up a tooltip for completion at POINT." | ||
| 207 | (interactive "d") | ||
| 208 | (let* ((a (semantic-analyze-current-context point)) | ||
| 209 | (syms (semantic-ia-get-completions a point)) | ||
| 210 | (x (mod (- (current-column) (window-hscroll)) | ||
| 211 | (window-width))) | ||
| 212 | (y (save-excursion | ||
| 213 | (save-restriction | ||
| 214 | (widen) | ||
| 215 | (narrow-to-region (window-start) (point)) | ||
| 216 | (goto-char (point-min)) | ||
| 217 | (1+ (vertical-motion (buffer-size)))))) | ||
| 218 | (str (mapconcat #'semantic-tag-name | ||
| 219 | syms | ||
| 220 | "\n")) | ||
| 221 | ) | ||
| 222 | (cond ((fboundp 'x-show-tip) | ||
| 223 | (x-show-tip str | ||
| 224 | (selected-frame) | ||
| 225 | nil | ||
| 226 | nil | ||
| 227 | x y) | ||
| 228 | ) | ||
| 229 | (t (message str)) | ||
| 230 | ))) | ||
| 231 | |||
| 232 | ;;; Summary | ||
| 233 | ;; | ||
| 234 | ;; Like idle-summary-mode, this shows how to get something to | ||
| 235 | ;; show a summary on. | ||
| 236 | |||
| 237 | (defun semantic-ia-show-summary (point) | ||
| 238 | "Display a summary for the symbol under POINT." | ||
| 239 | (interactive "P") | ||
| 240 | (let* ((ctxt (semantic-analyze-current-context point)) | ||
| 241 | (pf (when ctxt | ||
| 242 | ;; The CTXT is an EIEIO object. The below | ||
| 243 | ;; method will attempt to pick the most interesting | ||
| 244 | ;; tag associated with the current context. | ||
| 245 | (semantic-analyze-interesting-tag ctxt))) | ||
| 246 | ) | ||
| 247 | (when pf | ||
| 248 | (message "%s" (semantic-format-tag-summarize pf nil t))))) | ||
| 249 | |||
| 250 | ;;; FAST Jump | ||
| 251 | ;; | ||
| 252 | ;; Jump to a destination based on the local context. | ||
| 253 | ;; | ||
| 254 | ;; This shows how to use the analyzer context, and the | ||
| 255 | ;; analyer references objects to choose a good destination. | ||
| 256 | |||
| 257 | (defun semantic-ia--fast-jump-helper (dest) | ||
| 258 | "Jump to DEST, a Semantic tag. | ||
| 259 | This helper manages the mark, buffer switching, and pulsing." | ||
| 260 | ;; We have a tag, but in C++, we usually get a prototype instead | ||
| 261 | ;; because of header files. Lets try to find the actual | ||
| 262 | ;; implementaion instead. | ||
| 263 | (when (semantic-tag-prototype-p dest) | ||
| 264 | (let* ((refs (semantic-analyze-tag-references dest)) | ||
| 265 | (impl (semantic-analyze-refs-impl refs t)) | ||
| 266 | ) | ||
| 267 | (when impl (setq dest (car impl))))) | ||
| 268 | |||
| 269 | ;; Make sure we have a place to go... | ||
| 270 | (if (not (and (or (semantic-tag-with-position-p dest) | ||
| 271 | (semantic-tag-get-attribute dest :line)) | ||
| 272 | (semantic-tag-file-name dest))) | ||
| 273 | (error "Tag %s has no buffer information" | ||
| 274 | (semantic-format-tag-name dest))) | ||
| 275 | |||
| 276 | ;; Once we have the tag, we can jump to it. Here | ||
| 277 | ;; are the key bits to the jump: | ||
| 278 | |||
| 279 | ;; 1) Push the mark, so you can pop global mark back, or | ||
| 280 | ;; use semantic-mru-bookmark mode to do so. | ||
| 281 | (push-mark) | ||
| 282 | (when (fboundp 'push-tag-mark) | ||
| 283 | (push-tag-mark)) | ||
| 284 | ;; 2) Visits the tag. | ||
| 285 | (semantic-go-to-tag dest) | ||
| 286 | ;; 3) go-to-tag doesn't switch the buffer in the current window, | ||
| 287 | ;; so it is like find-file-noselect. Bring it forward. | ||
| 288 | (switch-to-buffer (current-buffer)) | ||
| 289 | ;; 4) Fancy pulsing. | ||
| 290 | (pulse-momentary-highlight-one-line (point)) | ||
| 291 | ) | ||
| 292 | |||
| 293 | (defun semantic-ia-fast-jump (point) | ||
| 294 | "Jump to the tag referred to by the code at POINT. | ||
| 295 | Uses `semantic-analyze-current-context' output to identify an accurate | ||
| 296 | origin of the code at point." | ||
| 297 | (interactive "d") | ||
| 298 | (let* ((ctxt (semantic-analyze-current-context point)) | ||
| 299 | (pf (and ctxt (reverse (oref ctxt prefix)))) | ||
| 300 | ;; In the analyzer context, the PREFIX is the list of items | ||
| 301 | ;; that makes up the code context at point. Thus the c++ code | ||
| 302 | ;; this.that().theothe | ||
| 303 | ;; would make a list: | ||
| 304 | ;; ( ("this" variable ..) ("that" function ...) "theothe") | ||
| 305 | ;; Where the first two elements are the semantic tags of the prefix. | ||
| 306 | ;; | ||
| 307 | ;; PF is the reverse of this list. If the first item is a string, | ||
| 308 | ;; then it is an incomplete symbol, thus we pick the second. | ||
| 309 | ;; The second cannot be a string, as that would have been an error. | ||
| 310 | (first (car pf)) | ||
| 311 | (second (nth 1 pf)) | ||
| 312 | ) | ||
| 313 | (cond | ||
| 314 | ((semantic-tag-p first) | ||
| 315 | ;; We have a match. Just go there. | ||
| 316 | (semantic-ia--fast-jump-helper first)) | ||
| 317 | |||
| 318 | ((semantic-tag-p second) | ||
| 319 | ;; Because FIRST failed, we should visit our second tag. | ||
| 320 | ;; HOWEVER, the tag we actually want that was only an unfound | ||
| 321 | ;; string may be related to some take in the datatype that belongs | ||
| 322 | ;; to SECOND. Thus, instead of visiting second directly, we | ||
| 323 | ;; can offer to find the type of SECOND, and go there. | ||
| 324 | (let ((secondclass (car (reverse (oref ctxt prefixtypes))))) | ||
| 325 | (cond | ||
| 326 | ((and (semantic-tag-with-position-p secondclass) | ||
| 327 | (y-or-n-p (format "Could not find `%s'. Jump to %s? " | ||
| 328 | first (semantic-tag-name secondclass)))) | ||
| 329 | (semantic-ia--fast-jump-helper secondclass) | ||
| 330 | ) | ||
| 331 | ;; If we missed out on the class of the second item, then | ||
| 332 | ;; just visit SECOND. | ||
| 333 | ((and (semantic-tag-p second) | ||
| 334 | (y-or-n-p (format "Could not find `%s'. Jump to %s? " | ||
| 335 | first (semantic-tag-name second)))) | ||
| 336 | (semantic-ia--fast-jump-helper second) | ||
| 337 | )))) | ||
| 338 | |||
| 339 | ((semantic-tag-of-class-p (semantic-current-tag) 'include) | ||
| 340 | ;; Just borrow this cool fcn. | ||
| 341 | (semantic-decoration-include-visit) | ||
| 342 | ) | ||
| 343 | |||
| 344 | (t | ||
| 345 | (error "Could not find suitable jump point for %s" | ||
| 346 | first)) | ||
| 347 | ))) | ||
| 348 | |||
| 349 | (defun semantic-ia-fast-mouse-jump (evt) | ||
| 350 | "Jump to the tag referred to by the point clicked on. | ||
| 351 | See `semantic-ia-fast-jump' for details on how it works. | ||
| 352 | This command is meant to be bound to a mouse event." | ||
| 353 | (interactive "e") | ||
| 354 | (semantic-ia-fast-jump | ||
| 355 | (save-excursion | ||
| 356 | (posn-set-point (event-end evt)) | ||
| 357 | (point)))) | ||
| 358 | |||
| 359 | ;;; DOC/DESCRIBE | ||
| 360 | ;; | ||
| 361 | ;; These routines show how to get additional information about a tag | ||
| 362 | ;; for purposes of describing or showing documentation about them. | ||
| 363 | (defun semantic-ia-show-doc (point) | ||
| 364 | "Display the code-level documentation for the symbol at POINT." | ||
| 365 | (interactive "d") | ||
| 366 | (let* ((ctxt (semantic-analyze-current-context point)) | ||
| 367 | (pf (reverse (oref ctxt prefix))) | ||
| 368 | ) | ||
| 369 | ;; If PF, the prefix is non-nil, then the last element is either | ||
| 370 | ;; a string (incomplete type), or a semantic TAG. If it is a TAG | ||
| 371 | ;; then we should be able to find DOC for it. | ||
| 372 | (cond | ||
| 373 | ((stringp (car pf)) | ||
| 374 | (message "Incomplete symbol name.")) | ||
| 375 | ((semantic-tag-p (car pf)) | ||
| 376 | ;; The `semantic-documentation-for-tag' fcn is language | ||
| 377 | ;; specific. If it doesn't return what you expect, you may | ||
| 378 | ;; need to implement something for your language. | ||
| 379 | ;; | ||
| 380 | ;; The default tries to find a comment in front of the tag | ||
| 381 | ;; and then strings off comment prefixes. | ||
| 382 | (let ((doc (semantic-documentation-for-tag (car pf)))) | ||
| 383 | (with-output-to-temp-buffer "*TAG DOCUMENTATION*" | ||
| 384 | (princ "Tag: ") | ||
| 385 | (princ (semantic-format-tag-prototype (car pf))) | ||
| 386 | (princ "\n") | ||
| 387 | (princ "\n") | ||
| 388 | (princ "Snarfed Documentation: ") | ||
| 389 | (princ "\n") | ||
| 390 | (princ "\n") | ||
| 391 | (if doc | ||
| 392 | (princ doc) | ||
| 393 | (princ " Documentation unavailable.")) | ||
| 394 | ))) | ||
| 395 | (t | ||
| 396 | (message "Unknown tag."))) | ||
| 397 | )) | ||
| 398 | |||
| 399 | (defun semantic-ia-describe-class (typename) | ||
| 400 | "Display all known parts for the datatype TYPENAME. | ||
| 401 | If the type in question is a class, all methods and other accessible | ||
| 402 | parts of the parent classes are displayed." | ||
| 403 | ;; @todo - use a fancy completing reader. | ||
| 404 | (interactive "sType Name: ") | ||
| 405 | |||
| 406 | ;; When looking for a tag of any name there are a couple ways to do | ||
| 407 | ;; it. The simple `semanticdb-find-tag-by-...' are simple, and | ||
| 408 | ;; you need to pass it the exact name you want. | ||
| 409 | ;; | ||
| 410 | ;; The analyzer function `semantic-analyze-tag-name' will take | ||
| 411 | ;; more complex names, such as the cpp symbol foo::bar::baz, | ||
| 412 | ;; and break it up, and dive through the namespaces. | ||
| 413 | (let ((class (semantic-analyze-find-tag typename))) | ||
| 414 | |||
| 415 | (when (not (semantic-tag-p class)) | ||
| 416 | (error "Cannot find class %s" class)) | ||
| 417 | (with-output-to-temp-buffer "*TAG DOCUMENTATION*" | ||
| 418 | ;; There are many semantic-format-tag-* fcns. | ||
| 419 | ;; The summarize routine is a fairly generic one. | ||
| 420 | (princ (semantic-format-tag-summarize class)) | ||
| 421 | (princ "\n") | ||
| 422 | (princ " Type Members:\n") | ||
| 423 | ;; The type tag contains all the parts of the type. | ||
| 424 | ;; In complex languages with inheritance, not all the | ||
| 425 | ;; parts are in the tag. This analyzer fcn will traverse | ||
| 426 | ;; the inheritance tree, and find all the pieces that | ||
| 427 | ;; are inherited. | ||
| 428 | (let ((parts (semantic-analyze-scoped-type-parts class))) | ||
| 429 | (while parts | ||
| 430 | (princ " ") | ||
| 431 | (princ (semantic-format-tag-summarize (car parts))) | ||
| 432 | (princ "\n") | ||
| 433 | (setq parts (cdr parts))) | ||
| 434 | ) | ||
| 435 | ))) | ||
| 436 | |||
| 437 | (provide 'semantic/ia) | ||
| 438 | |||
| 439 | ;;; semantic-ia.el ends here | ||
diff --git a/lisp/cedet/semantic/tag-file.el b/lisp/cedet/semantic/tag-file.el new file mode 100644 index 00000000000..4187d3c0302 --- /dev/null +++ b/lisp/cedet/semantic/tag-file.el | |||
| @@ -0,0 +1,202 @@ | |||
| 1 | ;;; tag-file.el --- Routines that find files based on tags. | ||
| 2 | |||
| 3 | ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, | ||
| 4 | ;;; 2008, 2009 Free Software Foundation, Inc. | ||
| 5 | |||
| 6 | ;; Author: Eric M. Ludlam <zappo@gnu.org> | ||
| 7 | ;; Keywords: syntax | ||
| 8 | |||
| 9 | ;; This file is part of GNU Emacs. | ||
| 10 | |||
| 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
| 12 | ;; it under the terms of the GNU General Public License as published by | ||
| 13 | ;; the Free Software Foundation, either version 3 of the License, or | ||
| 14 | ;; (at your option) any later version. | ||
| 15 | |||
| 16 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 19 | ;; GNU General Public License for more details. | ||
| 20 | |||
| 21 | ;; You should have received a copy of the GNU General Public License | ||
| 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | ||
| 23 | |||
| 24 | ;;; Commentary: | ||
| 25 | ;; | ||
| 26 | ;; A tag, by itself, can have representations in several files. | ||
| 27 | ;; These routines will find those files. | ||
| 28 | |||
| 29 | (require 'semantic/tag) | ||
| 30 | |||
| 31 | ;;; Code: | ||
| 32 | |||
| 33 | ;;; Location a TAG came from. | ||
| 34 | ;; | ||
| 35 | (define-overloadable-function semantic-go-to-tag (tag &optional parent) | ||
| 36 | "Go to the location of TAG. | ||
| 37 | TAG may be a stripped element, in which case PARENT specifies a | ||
| 38 | parent tag that has position information. | ||
| 39 | PARENT can also be a `semanticdb-table' object." | ||
| 40 | (:override | ||
| 41 | (cond ((semantic-tag-in-buffer-p tag) | ||
| 42 | ;; We have a linked tag, go to that buffer. | ||
| 43 | (set-buffer (semantic-tag-buffer tag))) | ||
| 44 | ((semantic-tag-file-name tag) | ||
| 45 | ;; If it didn't have a buffer, but does have a file | ||
| 46 | ;; name, then we need to get to that file so the tag | ||
| 47 | ;; location is made accurate. | ||
| 48 | (set-buffer (find-file-noselect (semantic-tag-file-name tag)))) | ||
| 49 | ((and parent (semantic-tag-p parent) (semantic-tag-in-buffer-p parent)) | ||
| 50 | ;; The tag had nothing useful, but we have a parent with | ||
| 51 | ;; a buffer, then go there. | ||
| 52 | (set-buffer (semantic-tag-buffer parent))) | ||
| 53 | ((and parent (semantic-tag-p parent) (semantic-tag-file-name parent)) | ||
| 54 | ;; Tag had nothing, and the parent only has a file-name, then | ||
| 55 | ;; find that file, and switch to that buffer. | ||
| 56 | (set-buffer (find-file-noselect (semantic-tag-file-name parent)))) | ||
| 57 | ((and parent (semanticdb-table-child-p parent)) | ||
| 58 | (set-buffer (semanticdb-get-buffer parent))) | ||
| 59 | (t | ||
| 60 | ;; Well, just assume things are in the current buffer. | ||
| 61 | nil | ||
| 62 | )) | ||
| 63 | ;; We should be in the correct buffer now, try and figure out | ||
| 64 | ;; where the tag is. | ||
| 65 | (cond ((semantic-tag-with-position-p tag) | ||
| 66 | ;; If it's a number, go there | ||
| 67 | (goto-char (semantic-tag-start tag))) | ||
| 68 | ((semantic-tag-with-position-p parent) | ||
| 69 | ;; Otherwise, it's a trimmed vector, such as a parameter, | ||
| 70 | ;; or a structure part. If there is a parent, we can use it | ||
| 71 | ;; as a bounds for searching. | ||
| 72 | (goto-char (semantic-tag-start parent)) | ||
| 73 | ;; Here we make an assumption that the text returned by | ||
| 74 | ;; the parser and concocted by us actually exists | ||
| 75 | ;; in the buffer. | ||
| 76 | (re-search-forward (semantic-tag-name tag) | ||
| 77 | (semantic-tag-end parent) | ||
| 78 | t)) | ||
| 79 | ((semantic-tag-get-attribute tag :line) | ||
| 80 | ;; The tag has a line number in it. Go there. | ||
| 81 | (goto-line (semantic-tag-get-attribute tag :line))) | ||
| 82 | ((and (semantic-tag-p parent) (semantic-tag-get-attribute parent :line)) | ||
| 83 | ;; The tag has a line number in it. Go there. | ||
| 84 | (goto-line (semantic-tag-get-attribute parent :line)) | ||
| 85 | (re-search-forward (semantic-tag-name tag) nil t) | ||
| 86 | ) | ||
| 87 | (t | ||
| 88 | ;; Take a guess that the tag has a unique name, and just | ||
| 89 | ;; search for it from the beginning of the buffer. | ||
| 90 | (goto-char (point-min)) | ||
| 91 | (re-search-forward (semantic-tag-name tag) nil t))) | ||
| 92 | ) | ||
| 93 | ) | ||
| 94 | |||
| 95 | (make-obsolete-overload 'semantic-find-nonterminal | ||
| 96 | 'semantic-go-to-tag) | ||
| 97 | |||
| 98 | ;;; Dependencies | ||
| 99 | ;; | ||
| 100 | ;; A tag which is of type 'include specifies a dependency. | ||
| 101 | ;; Dependencies usually represent a file of some sort. | ||
| 102 | ;; Find the file described by a dependency. | ||
| 103 | |||
| 104 | (define-overloadable-function semantic-dependency-tag-file (&optional tag) | ||
| 105 | "Find the filename represented from TAG. | ||
| 106 | Depends on `semantic-dependency-include-path' for searching. Always searches | ||
| 107 | `.' first, then searches additional paths." | ||
| 108 | (or tag (setq tag (car (semantic-find-tag-by-overlay nil)))) | ||
| 109 | (unless (semantic-tag-of-class-p tag 'include) | ||
| 110 | (signal 'wrong-type-argument (list tag 'include))) | ||
| 111 | (save-excursion | ||
| 112 | (let ((result nil) | ||
| 113 | (default-directory default-directory) | ||
| 114 | (edefind nil) | ||
| 115 | (tag-fname nil)) | ||
| 116 | (cond ((semantic-tag-in-buffer-p tag) | ||
| 117 | ;; If the tag has an overlay and buffer associated with it, | ||
| 118 | ;; switch to that buffer so that we get the right override metohds. | ||
| 119 | (set-buffer (semantic-tag-buffer tag))) | ||
| 120 | ((semantic-tag-file-name tag) | ||
| 121 | ;; If it didn't have a buffer, but does have a file | ||
| 122 | ;; name, then we need to get to that file so the tag | ||
| 123 | ;; location is made accurate. | ||
| 124 | ;;(set-buffer (find-file-noselect (semantic-tag-file-name tag))) | ||
| 125 | ;; | ||
| 126 | ;; 2/3/08 | ||
| 127 | ;; The above causes unnecessary buffer loads all over the place. Ick! | ||
| 128 | ;; All we really need is for 'default-directory' to be set correctly. | ||
| 129 | (setq default-directory (file-name-directory (semantic-tag-file-name tag))) | ||
| 130 | )) | ||
| 131 | ;; Setup the filename represented by this include | ||
| 132 | (setq tag-fname (semantic-tag-include-filename tag)) | ||
| 133 | |||
| 134 | ;; First, see if this file exists in the current EDE project | ||
| 135 | (if (and (fboundp 'ede-expand-filename) ede-minor-mode | ||
| 136 | (setq edefind | ||
| 137 | (condition-case nil | ||
| 138 | (let ((proj (ede-toplevel))) | ||
| 139 | (when proj | ||
| 140 | (ede-expand-filename proj tag-fname))) | ||
| 141 | (error nil)))) | ||
| 142 | (setq result edefind)) | ||
| 143 | (if (not result) | ||
| 144 | (setq result | ||
| 145 | ;; I don't have a plan for refreshing tags with a dependency | ||
| 146 | ;; stuck on them somehow. I'm thinking that putting a cache | ||
| 147 | ;; onto the dependancy finding with a hash table might be best. | ||
| 148 | ;;(if (semantic--tag-get-property tag 'dependency-file) | ||
| 149 | ;; (semantic--tag-get-property tag 'dependency-file) | ||
| 150 | (:override | ||
| 151 | (save-excursion | ||
| 152 | (semantic-dependency-find-file-on-path | ||
| 153 | tag-fname (semantic-tag-include-system-p tag)))) | ||
| 154 | ;; ) | ||
| 155 | )) | ||
| 156 | (if (stringp result) | ||
| 157 | (progn | ||
| 158 | (semantic--tag-put-property tag 'dependency-file result) | ||
| 159 | result) | ||
| 160 | ;; @todo: Do something to make this get flushed w/ | ||
| 161 | ;; when the path is changed. | ||
| 162 | ;; @undo: Just eliminate | ||
| 163 | ;; (semantic--tag-put-property tag 'dependency-file 'none) | ||
| 164 | nil) | ||
| 165 | ))) | ||
| 166 | |||
| 167 | (make-obsolete-overload 'semantic-find-dependency | ||
| 168 | 'semantic-dependency-tag-file) | ||
| 169 | |||
| 170 | ;;; PROTOTYPE FILE | ||
| 171 | ;; | ||
| 172 | ;; In C, a function in the .c file often has a representation in a | ||
| 173 | ;; corresponding .h file. This routine attempts to find the | ||
| 174 | ;; prototype file a given source file would be associated with. | ||
| 175 | ;; This can be used by prototype manager programs. | ||
| 176 | (define-overloadable-function semantic-prototype-file (buffer) | ||
| 177 | "Return a file in which prototypes belonging to BUFFER should be placed. | ||
| 178 | Default behavior (if not overridden) looks for a token specifying the | ||
| 179 | prototype file, or the existence of an EDE variable indicating which | ||
| 180 | file prototypes belong in." | ||
| 181 | (:override | ||
| 182 | ;; Perform some default behaviors | ||
| 183 | (if (and (fboundp 'ede-header-file) ede-minor-mode) | ||
| 184 | (save-excursion | ||
| 185 | (set-buffer buffer) | ||
| 186 | (ede-header-file)) | ||
| 187 | ;; No EDE options for a quick answer. Search. | ||
| 188 | (save-excursion | ||
| 189 | (set-buffer buffer) | ||
| 190 | (if (re-search-forward "::Header:: \\([a-zA-Z0-9.]+\\)" nil t) | ||
| 191 | (match-string 1)))))) | ||
| 192 | |||
| 193 | (semantic-alias-obsolete 'semantic-find-nonterminal | ||
| 194 | 'semantic-go-to-tag) | ||
| 195 | |||
| 196 | (semantic-alias-obsolete 'semantic-find-dependency | ||
| 197 | 'semantic-dependency-tag-file) | ||
| 198 | |||
| 199 | |||
| 200 | (provide 'semantic/tag-file) | ||
| 201 | |||
| 202 | ;;; semantic-tag-file.el ends here | ||
diff --git a/lisp/cedet/semantic/tag-ls.el b/lisp/cedet/semantic/tag-ls.el new file mode 100644 index 00000000000..634c41cf093 --- /dev/null +++ b/lisp/cedet/semantic/tag-ls.el | |||
| @@ -0,0 +1,276 @@ | |||
| 1 | ;;; tag-ls.el --- Language Specific override functions for tags | ||
| 2 | |||
| 3 | ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008 | ||
| 4 | ;;; Free Software Foundation, Inc. | ||
| 5 | |||
| 6 | ;; Author: Eric M. Ludlam <zappo@gnu.org> | ||
| 7 | |||
| 8 | ;; This file is part of GNU Emacs. | ||
| 9 | |||
| 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
| 11 | ;; it under the terms of the GNU General Public License as published by | ||
| 12 | ;; the Free Software Foundation, either version 3 of the License, or | ||
| 13 | ;; (at your option) any later version. | ||
| 14 | |||
| 15 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 18 | ;; GNU General Public License for more details. | ||
| 19 | |||
| 20 | ;; You should have received a copy of the GNU General Public License | ||
| 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | ||
| 22 | |||
| 23 | ;;; Commentary: | ||
| 24 | ;; | ||
| 25 | ;; There are some features of tags that are too langauge dependent to | ||
| 26 | ;; put in the core `semantic-tag' functionality. For instance, the | ||
| 27 | ;; protection of a tag (as specified by UML) could be almost anything. | ||
| 28 | ;; In Java, it is a type specifier. In C, there is a label. This | ||
| 29 | ;; informatin can be derived, and thus should not be stored in the tag | ||
| 30 | ;; itself. These are the functions that languages can use to derive | ||
| 31 | ;; the information. | ||
| 32 | |||
| 33 | (require 'semantic/tag) | ||
| 34 | |||
| 35 | ;;; Code: | ||
| 36 | |||
| 37 | ;;; UML features: | ||
| 38 | ;; | ||
| 39 | ;; UML can represent several types of features of a tag | ||
| 40 | ;; such as the `protection' of a symbol, or if it is abstract, | ||
| 41 | ;; leaf, etc. Learn about UML to catch onto the lingo. | ||
| 42 | |||
| 43 | (define-overloadable-function semantic-tag-calculate-parent (tag) | ||
| 44 | "Attempt to calculate the parent of TAG. | ||
| 45 | The default behavior (if not overriden with `tag-calculate-parent') | ||
| 46 | is to search a buffer found with TAG, and if externally defined, | ||
| 47 | search locally, then semanticdb for that tag (when enabled.)") | ||
| 48 | |||
| 49 | (defun semantic-tag-calculate-parent-default (tag) | ||
| 50 | "Attempt to calculate the parent of TAG." | ||
| 51 | (when (semantic-tag-in-buffer-p tag) | ||
| 52 | (save-excursion | ||
| 53 | (set-buffer (semantic-tag-buffer tag)) | ||
| 54 | (save-excursion | ||
| 55 | (goto-char (semantic-tag-start tag)) | ||
| 56 | (semantic-current-tag-parent)) | ||
| 57 | ))) | ||
| 58 | |||
| 59 | (define-overloadable-function semantic-tag-protection (tag &optional parent) | ||
| 60 | "Return protection information about TAG with optional PARENT. | ||
| 61 | This function returns on of the following symbols: | ||
| 62 | nil - No special protection. Language dependent. | ||
| 63 | 'public - Anyone can access this TAG. | ||
| 64 | 'private - Only methods in the local scope can access TAG. | ||
| 65 | 'protected - Like private for outside scopes, like public for child | ||
| 66 | classes. | ||
| 67 | Some languages may choose to provide additional return symbols specific | ||
| 68 | to themselves. Use of this function should allow for this. | ||
| 69 | |||
| 70 | The default behavior (if not overridden with `tag-protection' | ||
| 71 | is to return a symbol based on type modifiers." | ||
| 72 | (and (not parent) | ||
| 73 | (semantic-tag-overlay tag) | ||
| 74 | (semantic-tag-in-buffer-p tag) | ||
| 75 | (setq parent (semantic-tag-calculate-parent tag))) | ||
| 76 | (:override)) | ||
| 77 | |||
| 78 | (make-obsolete-overload 'semantic-nonterminal-protection | ||
| 79 | 'semantic-tag-protection) | ||
| 80 | |||
| 81 | (defun semantic-tag-protection-default (tag &optional parent) | ||
| 82 | "Return the protection of TAG as a child of PARENT default action. | ||
| 83 | See `semantic-tag-protection'." | ||
| 84 | (let ((mods (semantic-tag-modifiers tag)) | ||
| 85 | (prot nil)) | ||
| 86 | (while (and (not prot) mods) | ||
| 87 | (if (stringp (car mods)) | ||
| 88 | (let ((s (car mods))) | ||
| 89 | (setq prot | ||
| 90 | ;; A few silly defaults to get things started. | ||
| 91 | (cond ((or (string= s "public") | ||
| 92 | (string= s "extern") | ||
| 93 | (string= s "export")) | ||
| 94 | 'public) | ||
| 95 | ((string= s "private") | ||
| 96 | 'private) | ||
| 97 | ((string= s "protected") | ||
| 98 | 'protected))))) | ||
| 99 | (setq mods (cdr mods))) | ||
| 100 | prot)) | ||
| 101 | |||
| 102 | (defun semantic-tag-protected-p (tag protection &optional parent) | ||
| 103 | "Non-nil if TAG is is protected. | ||
| 104 | PROTECTION is a symbol which can be returned by the method | ||
| 105 | `semantic-tag-protection'. | ||
| 106 | PARENT is the parent data type which contains TAG. | ||
| 107 | |||
| 108 | For these PROTECTIONs, true is returned if TAG is: | ||
| 109 | @table @asis | ||
| 110 | @item nil | ||
| 111 | Always true | ||
| 112 | @item private | ||
| 113 | True if nil. | ||
| 114 | @item protected | ||
| 115 | True if private or nil. | ||
| 116 | @item public | ||
| 117 | True if private, protected, or nil. | ||
| 118 | @end table" | ||
| 119 | (if (null protection) | ||
| 120 | t | ||
| 121 | (let ((tagpro (semantic-tag-protection tag parent))) | ||
| 122 | (or (and (eq protection 'private) | ||
| 123 | (null tagpro)) | ||
| 124 | (and (eq protection 'protected) | ||
| 125 | (or (null tagpro) | ||
| 126 | (eq tagpro 'private))) | ||
| 127 | (and (eq protection 'public) | ||
| 128 | (not (eq tagpro 'public))))) | ||
| 129 | )) | ||
| 130 | |||
| 131 | (define-overloadable-function semantic-tag-abstract-p (tag &optional parent) | ||
| 132 | "Return non nil if TAG is abstract. | ||
| 133 | Optional PARENT is the parent tag of TAG. | ||
| 134 | In UML, abstract methods and classes have special meaning and behavior | ||
| 135 | in how methods are overridden. In UML, abstract methods are italicized. | ||
| 136 | |||
| 137 | The default behavior (if not overridden with `tag-abstract-p' | ||
| 138 | is to return true if `abstract' is in the type modifiers.") | ||
| 139 | |||
| 140 | (make-obsolete-overload 'semantic-nonterminal-abstract | ||
| 141 | 'semantic-tag-abstract-p) | ||
| 142 | |||
| 143 | (defun semantic-tag-abstract-p-default (tag &optional parent) | ||
| 144 | "Return non-nil if TAG is abstract as a child of PARENT default action. | ||
| 145 | See `semantic-tag-abstract-p'." | ||
| 146 | (let ((mods (semantic-tag-modifiers tag)) | ||
| 147 | (abs nil)) | ||
| 148 | (while (and (not abs) mods) | ||
| 149 | (if (stringp (car mods)) | ||
| 150 | (setq abs (or (string= (car mods) "abstract") | ||
| 151 | (string= (car mods) "virtual")))) | ||
| 152 | (setq mods (cdr mods))) | ||
| 153 | abs)) | ||
| 154 | |||
| 155 | (define-overloadable-function semantic-tag-leaf-p (tag &optional parent) | ||
| 156 | "Return non nil if TAG is leaf. | ||
| 157 | Optional PARENT is the parent tag of TAG. | ||
| 158 | In UML, leaf methods and classes have special meaning and behavior. | ||
| 159 | |||
| 160 | The default behavior (if not overridden with `tag-leaf-p' | ||
| 161 | is to return true if `leaf' is in the type modifiers.") | ||
| 162 | |||
| 163 | (make-obsolete-overload 'semantic-nonterminal-leaf | ||
| 164 | 'semantic-tag-leaf-p) | ||
| 165 | |||
| 166 | (defun semantic-tag-leaf-p-default (tag &optional parent) | ||
| 167 | "Return non-nil if TAG is leaf as a child of PARENT default action. | ||
| 168 | See `semantic-tag-leaf-p'." | ||
| 169 | (let ((mods (semantic-tag-modifiers tag)) | ||
| 170 | (leaf nil)) | ||
| 171 | (while (and (not leaf) mods) | ||
| 172 | (if (stringp (car mods)) | ||
| 173 | ;; Use java FINAL as example default. There is none | ||
| 174 | ;; for C/C++ | ||
| 175 | (setq leaf (string= (car mods) "final"))) | ||
| 176 | (setq mods (cdr mods))) | ||
| 177 | leaf)) | ||
| 178 | |||
| 179 | (define-overloadable-function semantic-tag-static-p (tag &optional parent) | ||
| 180 | "Return non nil if TAG is static. | ||
| 181 | Optional PARENT is the parent tag of TAG. | ||
| 182 | In UML, static methods and attributes mean that they are allocated | ||
| 183 | in the parent class, and are not instance specific. | ||
| 184 | UML notation specifies that STATIC entries are underlined.") | ||
| 185 | |||
| 186 | (defun semantic-tag-static-p-default (tag &optional parent) | ||
| 187 | "Return non-nil if TAG is static as a child of PARENT default action. | ||
| 188 | See `semantic-tag-static-p'." | ||
| 189 | (let ((mods (semantic-tag-modifiers tag)) | ||
| 190 | (static nil)) | ||
| 191 | (while (and (not static) mods) | ||
| 192 | (if (stringp (car mods)) | ||
| 193 | (setq static (string= (car mods) "static"))) | ||
| 194 | (setq mods (cdr mods))) | ||
| 195 | static)) | ||
| 196 | |||
| 197 | (define-overloadable-function semantic-tag-prototype-p (tag) | ||
| 198 | "Return non nil if TAG is a prototype. | ||
| 199 | For some laguages, such as C, a prototype is a declaration of | ||
| 200 | something without an implementation." | ||
| 201 | ) | ||
| 202 | |||
| 203 | (defun semantic-tag-prototype-p-default (tag) | ||
| 204 | "Non-nil if TAG is a prototype." | ||
| 205 | (let ((p (semantic-tag-get-attribute tag :prototype-flag))) | ||
| 206 | (cond | ||
| 207 | ;; Trust the parser author. | ||
| 208 | (p p) | ||
| 209 | ;; Empty types might be a prototype. | ||
| 210 | ;; @todo - make this better. | ||
| 211 | ((eq (semantic-tag-class tag) 'type) | ||
| 212 | (not (semantic-tag-type-members tag))) | ||
| 213 | ;; No other heuristics. | ||
| 214 | (t nil)) | ||
| 215 | )) | ||
| 216 | |||
| 217 | ;;; FULL NAMES | ||
| 218 | ;; | ||
| 219 | ;; For programmer convenience, a full name is not specified in source | ||
| 220 | ;; code. Instead some abbreviation is made, and the local environment | ||
| 221 | ;; will contain the info needed to determine the full name. | ||
| 222 | |||
| 223 | (define-overloadable-function semantic-tag-full-name (tag &optional stream-or-buffer) | ||
| 224 | "Return the fully qualified name of TAG in the package hierarchy. | ||
| 225 | STREAM-OR-BUFFER can be anything convertable by `semantic-something-to-stream', | ||
| 226 | but must be a toplevel semantic tag stream that contains TAG. | ||
| 227 | A Package Hierarchy is defined in UML by the way classes and methods | ||
| 228 | are organized on disk. Some language use this concept such that a | ||
| 229 | class can be accessed via it's fully qualified name, (such as Java.) | ||
| 230 | Other languages qualify names within a Namespace (such as C++) which | ||
| 231 | result in a different package like structure. Languages which do not | ||
| 232 | override this function with `tag-full-name' will use | ||
| 233 | `semantic-tag-name'. Override functions only need to handle | ||
| 234 | STREAM-OR-BUFFER with a tag stream value, or nil." | ||
| 235 | (let ((stream (semantic-something-to-tag-table | ||
| 236 | (or stream-or-buffer tag)))) | ||
| 237 | (:override-with-args (tag stream)))) | ||
| 238 | |||
| 239 | (make-obsolete-overload 'semantic-nonterminal-full-name | ||
| 240 | 'semantic-tag-full-name) | ||
| 241 | |||
| 242 | (defun semantic-tag-full-name-default (tag stream) | ||
| 243 | "Default method for `semantic-tag-full-name'. | ||
| 244 | Return the name of TAG found in the toplevel STREAM." | ||
| 245 | (semantic-tag-name tag)) | ||
| 246 | |||
| 247 | ;;; Compatibility aliases. | ||
| 248 | ;; | ||
| 249 | (semantic-alias-obsolete 'semantic-nonterminal-protection | ||
| 250 | 'semantic-tag-protection) | ||
| 251 | (semantic-alias-obsolete 'semantic-nonterminal-protection-default | ||
| 252 | 'semantic-tag-protection-default) | ||
| 253 | (semantic-alias-obsolete 'semantic-nonterminal-abstract | ||
| 254 | 'semantic-tag-abstract-p) | ||
| 255 | (semantic-alias-obsolete 'semantic-nonterminal-abstract-default | ||
| 256 | 'semantic-tag-abstract-p-default) | ||
| 257 | (semantic-alias-obsolete 'semantic-nonterminal-leaf | ||
| 258 | 'semantic-tag-leaf-p) | ||
| 259 | (semantic-alias-obsolete 'semantic-nonterminal-leaf-default | ||
| 260 | 'semantic-tag-leaf-p-default) | ||
| 261 | (semantic-alias-obsolete 'semantic-nonterminal-static-default | ||
| 262 | 'semantic-tag-static-p-default) | ||
| 263 | (semantic-alias-obsolete 'semantic-nonterminal-full-name | ||
| 264 | 'semantic-tag-full-name) | ||
| 265 | (semantic-alias-obsolete 'semantic-nonterminal-full-name-default | ||
| 266 | 'semantic-tag-full-name-default) | ||
| 267 | |||
| 268 | ;; TEMPORARY within betas of CEDET 1.0 | ||
| 269 | (semantic-alias-obsolete 'semantic-tag-static 'semantic-tag-static-p) | ||
| 270 | (semantic-alias-obsolete 'semantic-tag-leaf 'semantic-tag-leaf-p) | ||
| 271 | (semantic-alias-obsolete 'semantic-tag-abstract 'semantic-tag-abstract-p) | ||
| 272 | |||
| 273 | |||
| 274 | (provide 'semantic/tag-ls) | ||
| 275 | |||
| 276 | ;;; semantic-tag-ls.el ends here | ||