diff options
| author | Chong Yidong | 2009-08-28 19:18:35 +0000 |
|---|---|---|
| committer | Chong Yidong | 2009-08-28 19:18:35 +0000 |
| commit | 1bd955357097f15170e159d24b4e20b3173b8335 (patch) | |
| tree | 78dad743284d2f2daee6a139196e32bc98180d5f | |
| parent | 994e5ceab00ab6f3127ca3b2f5eef1dda375e1de (diff) | |
| download | emacs-1bd955357097f15170e159d24b4e20b3173b8335.tar.gz emacs-1bd955357097f15170e159d24b4e20b3173b8335.zip | |
cedet/semantic/ctxt.el, cedet/semantic/db-find.el,
cedet/semantic/db-ref.el, cedet/semantic/find.el,
cedet/semantic/format.el, cedet/semantic/sort.el: New files.
| -rw-r--r-- | lisp/cedet/semantic/ctxt.el | 613 | ||||
| -rw-r--r-- | lisp/cedet/semantic/db-find.el | 1353 | ||||
| -rw-r--r-- | lisp/cedet/semantic/db-ref.el | 161 | ||||
| -rw-r--r-- | lisp/cedet/semantic/find.el | 795 | ||||
| -rw-r--r-- | lisp/cedet/semantic/format.el | 774 | ||||
| -rw-r--r-- | lisp/cedet/semantic/sort.el | 592 |
6 files changed, 4288 insertions, 0 deletions
diff --git a/lisp/cedet/semantic/ctxt.el b/lisp/cedet/semantic/ctxt.el new file mode 100644 index 00000000000..270b9964031 --- /dev/null +++ b/lisp/cedet/semantic/ctxt.el | |||
| @@ -0,0 +1,613 @@ | |||
| 1 | ;;; ctxt.el --- Context calculations for Semantic tools. | ||
| 2 | |||
| 3 | ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, | ||
| 4 | ;;; 2007, 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 | ;; Semantic, as a tool, provides a nice list of searchable tags. | ||
| 27 | ;; That information can provide some very accurate answers if the current | ||
| 28 | ;; context of a position is known. | ||
| 29 | ;; | ||
| 30 | ;; This library provides the hooks needed for a language to specify how | ||
| 31 | ;; the current context is calculated. | ||
| 32 | ;; | ||
| 33 | (require 'semantic) | ||
| 34 | (eval-when-compile (require 'semantic/db)) | ||
| 35 | |||
| 36 | ;;; Code: | ||
| 37 | (defvar semantic-command-separation-character | ||
| 38 | ";" | ||
| 39 | "String which indicates the end of a command. | ||
| 40 | Used for identifying the end of a single command.") | ||
| 41 | (make-variable-buffer-local 'semantic-command-separation-character) | ||
| 42 | |||
| 43 | (defvar semantic-function-argument-separation-character | ||
| 44 | "," | ||
| 45 | "String which indicates the end of an argument. | ||
| 46 | Used for identifying arguments to functions.") | ||
| 47 | (make-variable-buffer-local 'semantic-function-argument-separation-character) | ||
| 48 | |||
| 49 | ;;; Local Contexts | ||
| 50 | ;; | ||
| 51 | ;; These context are nested blocks of code, such as code in an | ||
| 52 | ;; if clause | ||
| 53 | (define-overloadable-function semantic-up-context (&optional point bounds-type) | ||
| 54 | "Move point up one context from POINT. | ||
| 55 | Return non-nil if there are no more context levels. | ||
| 56 | Overloaded functions using `up-context' take no parameters. | ||
| 57 | BOUNDS-TYPE is a symbol representing a tag class to restrict | ||
| 58 | movement to. If this is nil, 'function is used. | ||
| 59 | This will find the smallest tag of that class (function, variable, | ||
| 60 | type, etc) and make sure non-nil is returned if you cannot | ||
| 61 | go up past the bounds of that tag." | ||
| 62 | (if point (goto-char point)) | ||
| 63 | (let ((nar (semantic-current-tag-of-class (or bounds-type 'function)))) | ||
| 64 | (if nar | ||
| 65 | (semantic-with-buffer-narrowed-to-tag nar (:override-with-args ())) | ||
| 66 | (when bounds-type | ||
| 67 | (error "No context of type %s to advance in" bounds-type)) | ||
| 68 | (:override-with-args ())))) | ||
| 69 | |||
| 70 | (defun semantic-up-context-default () | ||
| 71 | "Move the point up and out one context level. | ||
| 72 | Works with languages that use parenthetical grouping." | ||
| 73 | ;; By default, assume that the language uses some form of parenthetical | ||
| 74 | ;; do dads for their context. | ||
| 75 | (condition-case nil | ||
| 76 | (progn | ||
| 77 | (up-list -1) | ||
| 78 | nil) | ||
| 79 | (error t))) | ||
| 80 | |||
| 81 | (define-overloadable-function semantic-beginning-of-context (&optional point) | ||
| 82 | "Move POINT to the beginning of the current context. | ||
| 83 | Return non-nil if there is no upper context. | ||
| 84 | The default behavior uses `semantic-up-context'.") | ||
| 85 | |||
| 86 | (defun semantic-beginning-of-context-default (&optional point) | ||
| 87 | "Move POINT to the beginning of the current context via parenthisis. | ||
| 88 | Return non-nil if there is no upper context." | ||
| 89 | (if point (goto-char point)) | ||
| 90 | (if (semantic-up-context) | ||
| 91 | t | ||
| 92 | (forward-char 1) | ||
| 93 | nil)) | ||
| 94 | |||
| 95 | (define-overloadable-function semantic-end-of-context (&optional point) | ||
| 96 | "Move POINT to the end of the current context. | ||
| 97 | Return non-nil if there is no upper context. | ||
| 98 | Be default, this uses `semantic-up-context', and assumes parenthetical | ||
| 99 | block delimiters.") | ||
| 100 | |||
| 101 | (defun semantic-end-of-context-default (&optional point) | ||
| 102 | "Move POINT to the end of the current context via parenthisis. | ||
| 103 | Return non-nil if there is no upper context." | ||
| 104 | (if point (goto-char point)) | ||
| 105 | (let ((start (point))) | ||
| 106 | (if (semantic-up-context) | ||
| 107 | t | ||
| 108 | ;; Go over the list, and back over the end parenthisis. | ||
| 109 | (condition-case nil | ||
| 110 | (progn | ||
| 111 | (forward-sexp 1) | ||
| 112 | (forward-char -1)) | ||
| 113 | (error | ||
| 114 | ;; If an error occurs, get the current tag from the cache, | ||
| 115 | ;; and just go to the end of that. Make sure we end up at least | ||
| 116 | ;; where start was so parse-region type calls work. | ||
| 117 | (if (semantic-current-tag) | ||
| 118 | (progn | ||
| 119 | (goto-char (semantic-tag-end (semantic-current-tag))) | ||
| 120 | (when (< (point) start) | ||
| 121 | (goto-char start))) | ||
| 122 | (goto-char start)) | ||
| 123 | t))) | ||
| 124 | nil)) | ||
| 125 | |||
| 126 | (defun semantic-narrow-to-context () | ||
| 127 | "Narrow the buffer to the extent of the current context." | ||
| 128 | (let (b e) | ||
| 129 | (save-excursion | ||
| 130 | (if (semantic-beginning-of-context) | ||
| 131 | nil | ||
| 132 | (setq b (point)))) | ||
| 133 | (save-excursion | ||
| 134 | (if (semantic-end-of-context) | ||
| 135 | nil | ||
| 136 | (setq e (point)))) | ||
| 137 | (if (and b e) (narrow-to-region b e)))) | ||
| 138 | |||
| 139 | (defmacro semantic-with-buffer-narrowed-to-context (&rest body) | ||
| 140 | "Execute BODY with the buffer narrowed to the current context." | ||
| 141 | `(save-restriction | ||
| 142 | (semantic-narrow-to-context) | ||
| 143 | ,@body)) | ||
| 144 | (put 'semantic-with-buffer-narrowed-to-context 'lisp-indent-function 0) | ||
| 145 | (add-hook 'edebug-setup-hook | ||
| 146 | (lambda () | ||
| 147 | (def-edebug-spec semantic-with-buffer-narrowed-to-context | ||
| 148 | (def-body)))) | ||
| 149 | |||
| 150 | ;;; Local Variables | ||
| 151 | ;; | ||
| 152 | ;; | ||
| 153 | (define-overloadable-function semantic-get-local-variables (&optional point) | ||
| 154 | "Get the local variables based on POINT's context. | ||
| 155 | Local variables are returned in Semantic tag format. | ||
| 156 | This can be overriden with `get-local-variables'." | ||
| 157 | ;; The working status is to let the parser work properly | ||
| 158 | (working-status-forms | ||
| 159 | (semantic-parser-working-message "Local") | ||
| 160 | "done" | ||
| 161 | (save-excursion | ||
| 162 | (if point (goto-char point)) | ||
| 163 | (let* ((semantic-working-type nil) | ||
| 164 | ;; Disable parsing messages | ||
| 165 | (working-status-dynamic-type nil) | ||
| 166 | (case-fold-search semantic-case-fold)) | ||
| 167 | (:override-with-args ()))))) | ||
| 168 | |||
| 169 | (defun semantic-get-local-variables-default () | ||
| 170 | "Get local values from a specific context. | ||
| 171 | Uses the bovinator with the special top-symbol `bovine-inner-scope' | ||
| 172 | to collect tags, such as local variables or prototypes." | ||
| 173 | ;; This assumes a bovine parser. Make sure we don't do | ||
| 174 | ;; anything in that case. | ||
| 175 | (when (and semantic--parse-table (not (eq semantic--parse-table t)) | ||
| 176 | (not (semantic-parse-tree-unparseable-p))) | ||
| 177 | (let ((vars (semantic-get-cache-data 'get-local-variables))) | ||
| 178 | (if vars | ||
| 179 | (progn | ||
| 180 | ;;(message "Found cached vars.") | ||
| 181 | vars) | ||
| 182 | (let ((vars2 nil) | ||
| 183 | ;; We want nothing to do with funny syntaxing while doing this. | ||
| 184 | (semantic-unmatched-syntax-hook nil) | ||
| 185 | (start (point)) | ||
| 186 | (firstusefulstart nil) | ||
| 187 | ) | ||
| 188 | (while (not (semantic-up-context (point) 'function)) | ||
| 189 | (when (not vars) | ||
| 190 | (setq firstusefulstart (point))) | ||
| 191 | (save-excursion | ||
| 192 | (forward-char 1) | ||
| 193 | (setq vars | ||
| 194 | ;; Note to self: semantic-parse-region returns cooked | ||
| 195 | ;; but unlinked tags. File information is lost here | ||
| 196 | ;; and is added next. | ||
| 197 | (append (semantic-parse-region | ||
| 198 | (point) | ||
| 199 | (save-excursion (semantic-end-of-context) (point)) | ||
| 200 | 'bovine-inner-scope | ||
| 201 | nil | ||
| 202 | t) | ||
| 203 | vars)))) | ||
| 204 | ;; Modify the tags in place. | ||
| 205 | (setq vars2 vars) | ||
| 206 | (while vars2 | ||
| 207 | (semantic--tag-put-property (car vars2) :filename (buffer-file-name)) | ||
| 208 | (setq vars2 (cdr vars2))) | ||
| 209 | ;; Hash our value into the first context that produced useful results. | ||
| 210 | (when (and vars firstusefulstart) | ||
| 211 | (let ((end (save-excursion | ||
| 212 | (goto-char firstusefulstart) | ||
| 213 | (save-excursion | ||
| 214 | (unless (semantic-end-of-context) | ||
| 215 | (point)))))) | ||
| 216 | ;;(message "Caching values %d->%d." firstusefulstart end) | ||
| 217 | (semantic-cache-data-to-buffer | ||
| 218 | (current-buffer) firstusefulstart | ||
| 219 | (or end | ||
| 220 | ;; If the end-of-context fails, | ||
| 221 | ;; just use our cursor starting | ||
| 222 | ;; position. | ||
| 223 | start) | ||
| 224 | vars 'get-local-variables 'exit-cache-zone)) | ||
| 225 | ) | ||
| 226 | ;; Return our list. | ||
| 227 | vars))))) | ||
| 228 | |||
| 229 | (define-overloadable-function semantic-get-local-arguments (&optional point) | ||
| 230 | "Get arguments (variables) from the current context at POINT. | ||
| 231 | Parameters are available if the point is in a function or method. | ||
| 232 | Return a list of tags unlinked from the originating buffer. | ||
| 233 | Arguments are obtained by overriding `get-local-arguments', or by the | ||
| 234 | default function `semantic-get-local-arguments-default'. This, must | ||
| 235 | return a list of tags, or a list of strings that will be converted to | ||
| 236 | tags." | ||
| 237 | (save-excursion | ||
| 238 | (if point (goto-char point)) | ||
| 239 | (let* ((case-fold-search semantic-case-fold) | ||
| 240 | (args (:override-with-args ())) | ||
| 241 | arg tags) | ||
| 242 | ;; Convert unsafe arguments to the right thing. | ||
| 243 | (while args | ||
| 244 | (setq arg (car args) | ||
| 245 | args (cdr args) | ||
| 246 | tags (cons (cond | ||
| 247 | ((semantic-tag-p arg) | ||
| 248 | ;; Return a copy of tag without overlay. | ||
| 249 | ;; The overlay is preserved. | ||
| 250 | (semantic-tag-copy arg nil t)) | ||
| 251 | ((stringp arg) | ||
| 252 | (semantic--tag-put-property | ||
| 253 | (semantic-tag-new-variable arg nil nil) | ||
| 254 | :filename (buffer-file-name))) | ||
| 255 | (t | ||
| 256 | (error "Unknown parameter element %S" arg))) | ||
| 257 | tags))) | ||
| 258 | (nreverse tags)))) | ||
| 259 | |||
| 260 | (defun semantic-get-local-arguments-default () | ||
| 261 | "Get arguments (variables) from the current context. | ||
| 262 | Parameters are available if the point is in a function or method." | ||
| 263 | (let ((tag (semantic-current-tag))) | ||
| 264 | (if (and tag (semantic-tag-of-class-p tag 'function)) | ||
| 265 | (semantic-tag-function-arguments tag)))) | ||
| 266 | |||
| 267 | (define-overloadable-function semantic-get-all-local-variables (&optional point) | ||
| 268 | "Get all local variables for this context, and parent contexts. | ||
| 269 | Local variables are returned in Semantic tag format. | ||
| 270 | Be default, this gets local variables, and local arguments. | ||
| 271 | Optional argument POINT is the location to start getting the variables from.") | ||
| 272 | |||
| 273 | (defun semantic-get-all-local-variables-default (&optional point) | ||
| 274 | "Get all local variables for this context. | ||
| 275 | Optional argument POINT is the location to start getting the variables from. | ||
| 276 | That is a cons (LOCAL-ARGUMENTS . LOCAL-VARIABLES) where: | ||
| 277 | |||
| 278 | - LOCAL-ARGUMENTS is collected by `semantic-get-local-arguments'. | ||
| 279 | - LOCAL-VARIABLES is collected by `semantic-get-local-variables'." | ||
| 280 | (save-excursion | ||
| 281 | (if point (goto-char point)) | ||
| 282 | (let ((case-fold-search semantic-case-fold)) | ||
| 283 | (append (semantic-get-local-arguments) | ||
| 284 | (semantic-get-local-variables))))) | ||
| 285 | |||
| 286 | ;;; Local context parsing | ||
| 287 | ;; | ||
| 288 | ;; Context parsing assumes a series of language independent commonalities. | ||
| 289 | ;; These terms are used to describe those contexts: | ||
| 290 | ;; | ||
| 291 | ;; command - One command in the language. | ||
| 292 | ;; symbol - The symbol the cursor is on. | ||
| 293 | ;; This would include a series of type/field when applicable. | ||
| 294 | ;; assignment - The variable currently being assigned to | ||
| 295 | ;; function - The function call the cursor is on/in | ||
| 296 | ;; argument - The index to the argument the cursor is on. | ||
| 297 | ;; | ||
| 298 | ;; | ||
| 299 | (define-overloadable-function semantic-end-of-command () | ||
| 300 | "Move to the end of the current command. | ||
| 301 | Be default, uses `semantic-command-separation-character'.") | ||
| 302 | |||
| 303 | (defun semantic-end-of-command-default () | ||
| 304 | "Move to the end of the current command. | ||
| 305 | Depends on `semantic-command-separation-character' to find the | ||
| 306 | beginning and end of a command." | ||
| 307 | (semantic-with-buffer-narrowed-to-context | ||
| 308 | (let ((case-fold-search semantic-case-fold)) | ||
| 309 | (with-syntax-table semantic-lex-syntax-table | ||
| 310 | |||
| 311 | (if (re-search-forward (regexp-quote semantic-command-separation-character) | ||
| 312 | nil t) | ||
| 313 | (forward-char -1) | ||
| 314 | ;; If there wasn't a command after this, we are the last | ||
| 315 | ;; command, and we are incomplete. | ||
| 316 | (goto-char (point-max))))))) | ||
| 317 | |||
| 318 | (define-overloadable-function semantic-beginning-of-command () | ||
| 319 | "Move to the beginning of the current command. | ||
| 320 | Be default, uses `semantic-command-separation-character'.") | ||
| 321 | |||
| 322 | (defun semantic-beginning-of-command-default () | ||
| 323 | "Move to the beginning of the current command. | ||
| 324 | Depends on `semantic-command-separation-character' to find the | ||
| 325 | beginning and end of a command." | ||
| 326 | (semantic-with-buffer-narrowed-to-context | ||
| 327 | (with-syntax-table semantic-lex-syntax-table | ||
| 328 | (let ((case-fold-search semantic-case-fold)) | ||
| 329 | (skip-chars-backward semantic-command-separation-character) | ||
| 330 | (if (re-search-backward (regexp-quote semantic-command-separation-character) | ||
| 331 | nil t) | ||
| 332 | (goto-char (match-end 0)) | ||
| 333 | ;; If there wasn't a command after this, we are the last | ||
| 334 | ;; command, and we are incomplete. | ||
| 335 | (goto-char (point-min))) | ||
| 336 | (skip-chars-forward " \t\n") | ||
| 337 | )))) | ||
| 338 | |||
| 339 | |||
| 340 | (defsubst semantic-point-at-beginning-of-command () | ||
| 341 | "Return the point at the beginning of the current command." | ||
| 342 | (save-excursion (semantic-beginning-of-command) (point))) | ||
| 343 | |||
| 344 | (defsubst semantic-point-at-end-of-command () | ||
| 345 | "Return the point at the beginning of the current command." | ||
| 346 | (save-excursion (semantic-end-of-command) (point))) | ||
| 347 | |||
| 348 | (defsubst semantic-narrow-to-command () | ||
| 349 | "Narrow the current buffer to the current command." | ||
| 350 | (narrow-to-region (semantic-point-at-beginning-of-command) | ||
| 351 | (semantic-point-at-end-of-command))) | ||
| 352 | |||
| 353 | (defmacro semantic-with-buffer-narrowed-to-command (&rest body) | ||
| 354 | "Execute BODY with the buffer narrowed to the current command." | ||
| 355 | `(save-restriction | ||
| 356 | (semantic-narrow-to-command) | ||
| 357 | ,@body)) | ||
| 358 | (put 'semantic-with-buffer-narrowed-to-command 'lisp-indent-function 0) | ||
| 359 | (add-hook 'edebug-setup-hook | ||
| 360 | (lambda () | ||
| 361 | (def-edebug-spec semantic-with-buffer-narrowed-to-command | ||
| 362 | (def-body)))) | ||
| 363 | |||
| 364 | |||
| 365 | (define-overloadable-function semantic-ctxt-current-symbol (&optional point) | ||
| 366 | "Return the current symbol the cursor is on at POINT in a list. | ||
| 367 | The symbol includes all logical parts of a complex reference. | ||
| 368 | For example, in C the statement: | ||
| 369 | this.that().entry | ||
| 370 | |||
| 371 | Would be object `this' calling method `that' which returns some structure | ||
| 372 | whose field `entry' is being reference. In this case, this function | ||
| 373 | would return the list: | ||
| 374 | ( \"this\" \"that\" \"entry\" )") | ||
| 375 | |||
| 376 | (defun semantic-ctxt-current-symbol-default (&optional point) | ||
| 377 | "Return the current symbol the cursor is on at POINT in a list. | ||
| 378 | This will include a list of type/field names when applicable. | ||
| 379 | Depends on `semantic-type-relation-separator-character'." | ||
| 380 | (save-excursion | ||
| 381 | (if point (goto-char point)) | ||
| 382 | (let* ((fieldsep1 (mapconcat (lambda (a) (regexp-quote a)) | ||
| 383 | semantic-type-relation-separator-character | ||
| 384 | "\\|")) | ||
| 385 | ;; NOTE: The [ \n] expression below should used \\s-, but that | ||
| 386 | ;; doesn't work in C since \n means end-of-comment, and isn't | ||
| 387 | ;; really whitespace. | ||
| 388 | (fieldsep (concat "[ \t\n\r]*\\(" fieldsep1 "\\)[ \t\n\r]*\\(\\w\\|\\s_\\)")) | ||
| 389 | (case-fold-search semantic-case-fold) | ||
| 390 | (symlist nil) | ||
| 391 | end) | ||
| 392 | (with-syntax-table semantic-lex-syntax-table | ||
| 393 | (save-excursion | ||
| 394 | (cond ((looking-at "\\w\\|\\s_") | ||
| 395 | ;; In the middle of a symbol, move to the end. | ||
| 396 | (forward-sexp 1)) | ||
| 397 | ((looking-at fieldsep1) | ||
| 398 | ;; We are in a find spot.. do nothing. | ||
| 399 | nil | ||
| 400 | ) | ||
| 401 | ((save-excursion | ||
| 402 | (and (condition-case nil | ||
| 403 | (progn (forward-sexp -1) | ||
| 404 | (forward-sexp 1) | ||
| 405 | t) | ||
| 406 | (error nil)) | ||
| 407 | (looking-at fieldsep1))) | ||
| 408 | (setq symlist (list "")) | ||
| 409 | (forward-sexp -1) | ||
| 410 | ;; Skip array expressions. | ||
| 411 | (while (looking-at "\\s(") (forward-sexp -1)) | ||
| 412 | (forward-sexp 1)) | ||
| 413 | ) | ||
| 414 | ;; Set our end point. | ||
| 415 | (setq end (point)) | ||
| 416 | |||
| 417 | ;; Now that we have gotten started, lets do the rest. | ||
| 418 | (condition-case nil | ||
| 419 | (while (save-excursion | ||
| 420 | (forward-char -1) | ||
| 421 | (looking-at "\\w\\|\\s_")) | ||
| 422 | ;; We have a symbol.. Do symbol things | ||
| 423 | (forward-sexp -1) | ||
| 424 | (setq symlist (cons (buffer-substring-no-properties (point) end) | ||
| 425 | symlist)) | ||
| 426 | ;; Skip the next syntactic expression backwards, then go forwards. | ||
| 427 | (let ((cp (point))) | ||
| 428 | (forward-sexp -1) | ||
| 429 | (forward-sexp 1) | ||
| 430 | ;; If we end up at the same place we started, we are at the | ||
| 431 | ;; beginning of a buffer, or narrowed to a command and | ||
| 432 | ;; have to stop. | ||
| 433 | (if (<= cp (point)) (error nil))) | ||
| 434 | (if (looking-at fieldsep) | ||
| 435 | (progn | ||
| 436 | (forward-sexp -1) | ||
| 437 | ;; Skip array expressions. | ||
| 438 | (while (and (looking-at "\\s(") (not (bobp))) | ||
| 439 | (forward-sexp -1)) | ||
| 440 | (forward-sexp 1) | ||
| 441 | (setq end (point))) | ||
| 442 | (error nil)) | ||
| 443 | ) | ||
| 444 | (error nil))) | ||
| 445 | symlist)))) | ||
| 446 | |||
| 447 | |||
| 448 | (define-overloadable-function semantic-ctxt-current-symbol-and-bounds (&optional point) | ||
| 449 | "Return the current symbol and bounds the cursor is on at POINT. | ||
| 450 | The symbol should be the same as returned by `semantic-ctxt-current-symbol'. | ||
| 451 | Return (PREFIX ENDSYM BOUNDS).") | ||
| 452 | |||
| 453 | (defun semantic-ctxt-current-symbol-and-bounds-default (&optional point) | ||
| 454 | "Return the current symbol and bounds the cursor is on at POINT. | ||
| 455 | Uses `semantic-ctxt-current-symbol' to calculate the symbol. | ||
| 456 | Return (PREFIX ENDSYM BOUNDS)." | ||
| 457 | (save-excursion | ||
| 458 | (when point (goto-char (point))) | ||
| 459 | (let* ((prefix (semantic-ctxt-current-symbol)) | ||
| 460 | (endsym (car (reverse prefix))) | ||
| 461 | ;; @todo - Can we get this data direct from ctxt-current-symbol? | ||
| 462 | (bounds (save-excursion | ||
| 463 | (cond ((string= endsym "") | ||
| 464 | (cons (point) (point)) | ||
| 465 | ) | ||
| 466 | ((and prefix (looking-at endsym)) | ||
| 467 | (cons (point) (progn | ||
| 468 | (condition-case nil | ||
| 469 | (forward-sexp 1) | ||
| 470 | (error nil)) | ||
| 471 | (point)))) | ||
| 472 | (prefix | ||
| 473 | (condition-case nil | ||
| 474 | (cons (progn (forward-sexp -1) (point)) | ||
| 475 | (progn (forward-sexp 1) (point))) | ||
| 476 | (error nil))) | ||
| 477 | (t nil)))) | ||
| 478 | ) | ||
| 479 | (list prefix endsym bounds)))) | ||
| 480 | |||
| 481 | (define-overloadable-function semantic-ctxt-current-assignment (&optional point) | ||
| 482 | "Return the current assignment near the cursor at POINT. | ||
| 483 | Return a list as per `semantic-ctxt-current-symbol'. | ||
| 484 | Return nil if there is nothing relevant.") | ||
| 485 | |||
| 486 | (defun semantic-ctxt-current-assignment-default (&optional point) | ||
| 487 | "Return the current assignment near the cursor at POINT. | ||
| 488 | By default, assume that \"=\" indicates an assignment." | ||
| 489 | (if point (goto-char point)) | ||
| 490 | (let ((case-fold-search semantic-case-fold)) | ||
| 491 | (with-syntax-table semantic-lex-syntax-table | ||
| 492 | (condition-case nil | ||
| 493 | (semantic-with-buffer-narrowed-to-command | ||
| 494 | (save-excursion | ||
| 495 | (skip-chars-forward " \t=") | ||
| 496 | (condition-case nil (forward-char 1) (error nil)) | ||
| 497 | (re-search-backward "[^=]=\\([^=]\\|$\\)") | ||
| 498 | ;; We are at an equals sign. Go backwards a sexp, and | ||
| 499 | ;; we'll have the variable. Otherwise we threw an error | ||
| 500 | (forward-sexp -1) | ||
| 501 | (semantic-ctxt-current-symbol))) | ||
| 502 | (error nil))))) | ||
| 503 | |||
| 504 | (define-overloadable-function semantic-ctxt-current-function (&optional point) | ||
| 505 | "Return the current function call the cursor is in at POINT. | ||
| 506 | The function returned is the one accepting the arguments that | ||
| 507 | the cursor is currently in. It will not return function symbol if the | ||
| 508 | cursor is on the text representing that function.") | ||
| 509 | |||
| 510 | (defun semantic-ctxt-current-function-default (&optional point) | ||
| 511 | "Return the current function call the cursor is in at POINT. | ||
| 512 | The call will be identifed for C like langauges with the form | ||
| 513 | NAME ( args ... )" | ||
| 514 | (if point (goto-char point)) | ||
| 515 | (let ((case-fold-search semantic-case-fold)) | ||
| 516 | (with-syntax-table semantic-lex-syntax-table | ||
| 517 | (save-excursion | ||
| 518 | (semantic-up-context) | ||
| 519 | (when (looking-at "(") | ||
| 520 | (semantic-ctxt-current-symbol)))) | ||
| 521 | )) | ||
| 522 | |||
| 523 | (define-overloadable-function semantic-ctxt-current-argument (&optional point) | ||
| 524 | "Return the index of the argument position the cursor is on at POINT.") | ||
| 525 | |||
| 526 | (defun semantic-ctxt-current-argument-default (&optional point) | ||
| 527 | "Return the index of the argument the cursor is on at POINT. | ||
| 528 | Depends on `semantic-function-argument-separation-character'." | ||
| 529 | (if point (goto-char point)) | ||
| 530 | (let ((case-fold-search semantic-case-fold)) | ||
| 531 | (with-syntax-table semantic-lex-syntax-table | ||
| 532 | (when (semantic-ctxt-current-function) | ||
| 533 | (save-excursion | ||
| 534 | ;; Only get the current arg index if we are in function args. | ||
| 535 | (let ((p (point)) | ||
| 536 | (idx 1)) | ||
| 537 | (semantic-up-context) | ||
| 538 | (while (re-search-forward | ||
| 539 | (regexp-quote semantic-function-argument-separation-character) | ||
| 540 | p t) | ||
| 541 | (setq idx (1+ idx))) | ||
| 542 | idx)))))) | ||
| 543 | |||
| 544 | (defun semantic-ctxt-current-thing () | ||
| 545 | "Calculate a thing identified by the current cursor position. | ||
| 546 | Calls previously defined `semantic-ctxt-current-...' calls until something | ||
| 547 | gets a match. See `semantic-ctxt-current-symbol', | ||
| 548 | `semantic-ctxt-current-function', and `semantic-ctxt-current-assignment' | ||
| 549 | for details on the return value." | ||
| 550 | (or (semantic-ctxt-current-symbol) | ||
| 551 | (semantic-ctxt-current-function) | ||
| 552 | (semantic-ctxt-current-assignment))) | ||
| 553 | |||
| 554 | (define-overloadable-function semantic-ctxt-current-class-list (&optional point) | ||
| 555 | "Return a list of tag classes that are allowed at POINT. | ||
| 556 | If POINT is nil, the current buffer location is used. | ||
| 557 | For example, in Emacs Lisp, the symbol after a ( is most likely | ||
| 558 | a function. In a makefile, symbols after a : are rules, and symbols | ||
| 559 | after a $( are variables.") | ||
| 560 | |||
| 561 | (defun semantic-ctxt-current-class-list-default (&optional point) | ||
| 562 | "Return a list of tag classes that are allowed at POINT. | ||
| 563 | Assume a functional typed language. Uses very simple rules." | ||
| 564 | (save-excursion | ||
| 565 | (if point (goto-char point)) | ||
| 566 | |||
| 567 | (let ((tag (semantic-current-tag))) | ||
| 568 | (if tag | ||
| 569 | (cond ((semantic-tag-of-class-p tag 'function) | ||
| 570 | '(function variable type)) | ||
| 571 | ((or (semantic-tag-of-class-p tag 'type) | ||
| 572 | (semantic-tag-of-class-p tag 'variable)) | ||
| 573 | '(type)) | ||
| 574 | (t nil)) | ||
| 575 | '(type) | ||
| 576 | )))) | ||
| 577 | |||
| 578 | (define-overloadable-function semantic-ctxt-current-mode (&optional point) | ||
| 579 | "Return the major mode active at POINT. | ||
| 580 | POINT defaults to the value of point in current buffer. | ||
| 581 | You should override this function in multiple mode buffers to | ||
| 582 | determine which major mode apply at point.") | ||
| 583 | |||
| 584 | (defun semantic-ctxt-current-mode-default (&optional point) | ||
| 585 | "Return the major mode active at POINT. | ||
| 586 | POINT defaults to the value of point in current buffer. | ||
| 587 | This default implementation returns the current major mode." | ||
| 588 | major-mode) | ||
| 589 | |||
| 590 | ;;; Scoped Types | ||
| 591 | ;; | ||
| 592 | ;; Scoped types are types that the current code would have access to. | ||
| 593 | ;; The come from the global namespace or from special commands such as "using" | ||
| 594 | (define-overloadable-function semantic-ctxt-scoped-types (&optional point) | ||
| 595 | "Return a list of type names currently in scope at POINT. | ||
| 596 | The return value can be a mixed list of either strings (names of | ||
| 597 | types that are in scope) or actual tags (type declared locally | ||
| 598 | that may or may not have a name.)") | ||
| 599 | |||
| 600 | (defun semantic-ctxt-scoped-types-default (&optional point) | ||
| 601 | "Return a list of scoped types by name for the current context at POINT. | ||
| 602 | This is very different for various languages, and does nothing unless | ||
| 603 | overriden." | ||
| 604 | (if point (goto-char point)) | ||
| 605 | (let ((case-fold-search semantic-case-fold)) | ||
| 606 | ;; We need to look at TYPES within the bounds of locally parse arguments. | ||
| 607 | ;; C needs to find using statements and the like too. Bleh. | ||
| 608 | nil | ||
| 609 | )) | ||
| 610 | |||
| 611 | (provide 'semantic/ctxt) | ||
| 612 | |||
| 613 | ;;; semantic-ctxt.el ends here | ||
diff --git a/lisp/cedet/semantic/db-find.el b/lisp/cedet/semantic/db-find.el new file mode 100644 index 00000000000..fb40d77d3ef --- /dev/null +++ b/lisp/cedet/semantic/db-find.el | |||
| @@ -0,0 +1,1353 @@ | |||
| 1 | ;;; db-find.el --- Searching through semantic databases. | ||
| 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: 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 | ;; Databases of various forms can all be searched. | ||
| 27 | ;; There are a few types of searches that can be done: | ||
| 28 | ;; | ||
| 29 | ;; Basic Name Search: | ||
| 30 | ;; These searches scan a database table collection for tags based | ||
| 31 | ;; on name. | ||
| 32 | ;; | ||
| 33 | ;; Basic Attribute Search: | ||
| 34 | ;; These searches allow searching on specific attributes of tags, | ||
| 35 | ;; such as name, type, or other attribute. | ||
| 36 | ;; | ||
| 37 | ;; Advanced Search: | ||
| 38 | ;; These are searches that were needed to accomplish some | ||
| 39 | ;; specialized tasks as discovered in utilities. Advanced searches | ||
| 40 | ;; include matching methods defined outside some parent class. | ||
| 41 | ;; | ||
| 42 | ;; The reason for advanced searches are so that external | ||
| 43 | ;; repositories such as the Emacs obarray, or java .class files can | ||
| 44 | ;; quickly answer these needed questions without dumping the entire | ||
| 45 | ;; symbol list into Emacs for additional refinement searches via | ||
| 46 | ;; regular semanticdb search. | ||
| 47 | ;; | ||
| 48 | ;; How databases are decided upon is another important aspect of a | ||
| 49 | ;; database search. When it comes to searching for a name, there are | ||
| 50 | ;; these types of searches: | ||
| 51 | ;; | ||
| 52 | ;; Basic Search: | ||
| 53 | ;; Basic search means that tags looking for a given name start | ||
| 54 | ;; with a specific search path. Names are sought on that path | ||
| 55 | ;; until it is empty or items on the path can no longer be found. | ||
| 56 | ;; Use `semanticdb-dump-all-table-summary' to test this list. | ||
| 57 | ;; Use `semanticdb-find-throttle-custom-list' to refine this list. | ||
| 58 | ;; | ||
| 59 | ;; Deep Search: | ||
| 60 | ;; A deep search will search more than just the global namespace. | ||
| 61 | ;; It will recurse into tags that contain more tags, and search | ||
| 62 | ;; those too. | ||
| 63 | ;; | ||
| 64 | ;; Brute Search: | ||
| 65 | ;; Brute search means that all tables in all databases in a given | ||
| 66 | ;; project are searched. Brute searches are the search style as | ||
| 67 | ;; written for semantic version 1.x. | ||
| 68 | ;; | ||
| 69 | ;; How does the search path work? | ||
| 70 | ;; | ||
| 71 | ;; A basic search starts with three parameters: | ||
| 72 | ;; | ||
| 73 | ;; (FINDME &optional PATH FIND-FILE-MATCH) | ||
| 74 | ;; | ||
| 75 | ;; FINDME is key to be searched for dependent on the type of search. | ||
| 76 | ;; PATH is an indicator of which tables are to be searched. | ||
| 77 | ;; FIND-FILE-MATCH indicates that any time a match is found, the | ||
| 78 | ;; file associated with the tag should be read into a file. | ||
| 79 | ;; | ||
| 80 | ;; The PATH argument is then the most interesting argument. It can | ||
| 81 | ;; have these values: | ||
| 82 | ;; | ||
| 83 | ;; nil - Take the current buffer, and use it's include list | ||
| 84 | ;; buffer - Use that buffer's include list. | ||
| 85 | ;; filename - Use that file's include list. If the file is not | ||
| 86 | ;; in a buffer, see of there is a semanticdb table for it. If | ||
| 87 | ;; not, read that file into a buffer. | ||
| 88 | ;; tag - Get that tag's buffer of file file. See above. | ||
| 89 | ;; table - Search that table, and it's include list. | ||
| 90 | ;; | ||
| 91 | ;; Search Results: | ||
| 92 | ;; | ||
| 93 | ;; Semanticdb returns the results in a specific format. There are a | ||
| 94 | ;; series of routines for using those results, and results can be | ||
| 95 | ;; passed in as a search-path for refinement searches with | ||
| 96 | ;; semanticdb. Apropos for semanticdb.*find-result for more. | ||
| 97 | ;; | ||
| 98 | ;; Application: | ||
| 99 | ;; | ||
| 100 | ;; Here are applications where different searches are needed which | ||
| 101 | ;; exist as of semantic 1.4.x | ||
| 102 | ;; | ||
| 103 | ;; eldoc - popup help | ||
| 104 | ;; => Requires basic search using default path. (Header files ok) | ||
| 105 | ;; tag jump - jump to a named tag | ||
| 106 | ;; => Requires a brute search useing whole project. (Source files only) | ||
| 107 | ;; completion - Completing symbol names in a smart way | ||
| 108 | ;; => Basic search (headers ok) | ||
| 109 | ;; type analysis - finding type definitions for variables & fcns | ||
| 110 | ;; => Basic search (headers ok) | ||
| 111 | ;; Class browser - organize types into some structure | ||
| 112 | ;; => Brute search, or custom navigation. | ||
| 113 | |||
| 114 | ;; TODO: | ||
| 115 | ;; During a search, load any unloaded DB files based on paths in the | ||
| 116 | ;; current project. | ||
| 117 | |||
| 118 | (require 'semantic/db) | ||
| 119 | (require 'semantic/db-ref) | ||
| 120 | (eval-when-compile | ||
| 121 | (require 'eieio) | ||
| 122 | ) | ||
| 123 | |||
| 124 | ;;; Code: | ||
| 125 | (defvar semanticdb-find-throttle-custom-list | ||
| 126 | '(repeat (radio (const 'local) | ||
| 127 | (const 'project) | ||
| 128 | (const 'unloaded) | ||
| 129 | (const 'system) | ||
| 130 | (const 'recursive) | ||
| 131 | (const 'omniscience))) | ||
| 132 | "Customization values for semanticdb find throttle. | ||
| 133 | See `semanticdb-find-throttle' for details.") | ||
| 134 | |||
| 135 | (defcustom semanticdb-find-default-throttle | ||
| 136 | '(local project unloaded system recursive) | ||
| 137 | "The default throttle for `semanticdb-find' routines. | ||
| 138 | The throttle controls how detailed the list of database | ||
| 139 | tables is for a symbol lookup. The value is a list with | ||
| 140 | the following keys: | ||
| 141 | `file' - The file the search is being performed from. | ||
| 142 | This option is here for completeness only, and | ||
| 143 | is assumed to always be on. | ||
| 144 | `local' - Tables from the same local directory are included. | ||
| 145 | This includes files directly referenced by a file name | ||
| 146 | which might be in a different directory. | ||
| 147 | `project' - Tables from the same local project are included | ||
| 148 | If `project' is specified, then `local' is assumed. | ||
| 149 | `unloaded' - If a table is not in memory, load it. If it is not cached | ||
| 150 | on disk either, get the source, parse it, and create | ||
| 151 | the table. | ||
| 152 | `system' - Tables from system databases. These are specifically | ||
| 153 | tables from system header files, or language equivalent. | ||
| 154 | `recursive' - For include based searches, includes tables referenced | ||
| 155 | by included files. | ||
| 156 | `omniscience' - Included system databases which are omniscience, or | ||
| 157 | somehow know everything. Omniscience databases are found | ||
| 158 | in `semanticdb-project-system-databases'. | ||
| 159 | The Emacs Lisp system DB is an omniscience database." | ||
| 160 | :group 'semanticdb | ||
| 161 | :type semanticdb-find-throttle-custom-list) | ||
| 162 | |||
| 163 | (defun semanticdb-find-throttle-active-p (access-type) | ||
| 164 | "Non-nil if ACCESS-TYPE is an active throttle type." | ||
| 165 | (or (memq access-type semanticdb-find-default-throttle) | ||
| 166 | (eq access-type 'file) | ||
| 167 | (and (eq access-type 'local) | ||
| 168 | (memq 'project semanticdb-find-default-throttle)) | ||
| 169 | )) | ||
| 170 | |||
| 171 | ;;; Index Class | ||
| 172 | ;; | ||
| 173 | ;; The find routines spend a lot of time looking stuff up. | ||
| 174 | ;; Use this handy search index to cache data between searches. | ||
| 175 | ;; This should allow searches to start running faster. | ||
| 176 | (defclass semanticdb-find-search-index (semanticdb-abstract-search-index) | ||
| 177 | ((include-path :initform nil | ||
| 178 | :documentation | ||
| 179 | "List of semanticdb tables from the include path.") | ||
| 180 | (type-cache :initform nil | ||
| 181 | :documentation | ||
| 182 | "Cache of all the data types accessible from this file. | ||
| 183 | Includes all types from all included files, merged namespaces, and | ||
| 184 | expunge duplicates.") | ||
| 185 | ) | ||
| 186 | "Concrete search index for `semanticdb-find'. | ||
| 187 | This class will cache data derived during various searches.") | ||
| 188 | |||
| 189 | (defmethod semantic-reset ((idx semanticdb-find-search-index)) | ||
| 190 | "Reset the object IDX." | ||
| 191 | ;; Clear the include path. | ||
| 192 | (oset idx include-path nil) | ||
| 193 | (when (oref idx type-cache) | ||
| 194 | (semantic-reset (oref idx type-cache))) | ||
| 195 | ;; Clear the scope. Scope doesn't have the data it needs to track | ||
| 196 | ;; it's own reset. | ||
| 197 | (semantic-scope-reset-cache) | ||
| 198 | ) | ||
| 199 | |||
| 200 | (defmethod semanticdb-synchronize ((idx semanticdb-find-search-index) | ||
| 201 | new-tags) | ||
| 202 | "Synchronize the search index IDX with some NEW-TAGS." | ||
| 203 | ;; Reset our parts. | ||
| 204 | (semantic-reset idx) | ||
| 205 | ;; Notify dependants by clearning their indicies. | ||
| 206 | (semanticdb-notify-references | ||
| 207 | (oref idx table) | ||
| 208 | (lambda (tab me) | ||
| 209 | (semantic-reset (semanticdb-get-table-index tab)))) | ||
| 210 | ) | ||
| 211 | |||
| 212 | (defmethod semanticdb-partial-synchronize ((idx semanticdb-find-search-index) | ||
| 213 | new-tags) | ||
| 214 | "Synchronize the search index IDX with some changed NEW-TAGS." | ||
| 215 | ;; Only reset if include statements changed. | ||
| 216 | (if (semantic-find-tags-by-class 'include new-tags) | ||
| 217 | (progn | ||
| 218 | (semantic-reset idx) | ||
| 219 | ;; Notify dependants by clearning their indicies. | ||
| 220 | (semanticdb-notify-references | ||
| 221 | (oref idx table) | ||
| 222 | (lambda (tab me) | ||
| 223 | (semantic-reset (semanticdb-get-table-index tab)))) | ||
| 224 | ) | ||
| 225 | ;; Else, not an include, by just a type. | ||
| 226 | (when (oref idx type-cache) | ||
| 227 | (when (semanticdb-partial-synchronize (oref idx type-cache) new-tags) | ||
| 228 | ;; If the synchronize returns true, we need to notify. | ||
| 229 | ;; Notify dependants by clearning their indicies. | ||
| 230 | (semanticdb-notify-references | ||
| 231 | (oref idx table) | ||
| 232 | (lambda (tab me) | ||
| 233 | (let ((tab-idx (semanticdb-get-table-index tab))) | ||
| 234 | ;; Not a full reset? | ||
| 235 | (when (oref tab-idx type-cache) | ||
| 236 | (semanticdb-typecache-notify-reset | ||
| 237 | (oref tab-idx type-cache))) | ||
| 238 | ))) | ||
| 239 | )) | ||
| 240 | )) | ||
| 241 | |||
| 242 | |||
| 243 | ;;; Path Translations | ||
| 244 | ;; | ||
| 245 | ;;; OVERLOAD Functions | ||
| 246 | ;; | ||
| 247 | ;; These routines needed to be overloaded by specific language modes. | ||
| 248 | ;; They are needed for translating an INCLUDE tag into a semanticdb | ||
| 249 | ;; TABLE object. | ||
| 250 | (define-overloadable-function semanticdb-find-translate-path (path brutish) | ||
| 251 | "Translate PATH into a list of semantic tables. | ||
| 252 | Path translation involves identifying the PATH input argument | ||
| 253 | in one of the following ways: | ||
| 254 | nil - Take the current buffer, and use it's include list | ||
| 255 | buffer - Use that buffer's include list. | ||
| 256 | filename - Use that file's include list. If the file is not | ||
| 257 | in a buffer, see of there is a semanticdb table for it. If | ||
| 258 | not, read that file into a buffer. | ||
| 259 | tag - Get that tag's buffer of file file. See above. | ||
| 260 | table - Search that table, and it's include list. | ||
| 261 | find result - Search the results of a previous find. | ||
| 262 | |||
| 263 | In addition, once the base path is found, there is the possibility of | ||
| 264 | each added table adding yet more tables to the path, so this routine | ||
| 265 | can return a lengthy list. | ||
| 266 | |||
| 267 | If argument BRUTISH is non-nil, then instead of using the include | ||
| 268 | list, use all tables found in the parent project of the table | ||
| 269 | identified by translating PATH. Such searches use brute force to | ||
| 270 | scan every available table. | ||
| 271 | |||
| 272 | The return value is a list of objects of type `semanticdb-table' or | ||
| 273 | it's children. In the case of passing in a find result, the result | ||
| 274 | is returned unchanged. | ||
| 275 | |||
| 276 | This routine uses `semanticdb-find-table-for-include' to translate | ||
| 277 | specific include tags into a semanticdb table. | ||
| 278 | |||
| 279 | Note: When searching using a non-brutish method, the list of | ||
| 280 | included files will be cached between runs. Database-references | ||
| 281 | are used to track which files need to have their include lists | ||
| 282 | refreshed when things change. See `semanticdb-ref-test'. | ||
| 283 | |||
| 284 | Note for overloading: If you opt to overload this function for your | ||
| 285 | major mode, and your routine takes a long time, be sure to call | ||
| 286 | |||
| 287 | (semantic-throw-on-input 'your-symbol-here) | ||
| 288 | |||
| 289 | so that it can be called from the idle work handler." | ||
| 290 | ) | ||
| 291 | |||
| 292 | (defun semanticdb-find-translate-path-default (path brutish) | ||
| 293 | "Translate PATH into a list of semantic tables. | ||
| 294 | If BRUTISH is non nil, return all tables associated with PATH. | ||
| 295 | Default action as described in `semanticdb-find-translate-path'." | ||
| 296 | (if (semanticdb-find-results-p path) | ||
| 297 | ;; nil means perform the search over these results. | ||
| 298 | nil | ||
| 299 | (if brutish | ||
| 300 | (semanticdb-find-translate-path-brutish-default path) | ||
| 301 | (semanticdb-find-translate-path-includes-default path)))) | ||
| 302 | |||
| 303 | (defun semanticdb-find-translate-path-brutish-default (path) | ||
| 304 | "Translate PATH into a list of semantic tables. | ||
| 305 | Default action as described in `semanticdb-find-translate-path'." | ||
| 306 | (let ((basedb | ||
| 307 | (cond ((null path) semanticdb-current-database) | ||
| 308 | ((semanticdb-table-p path) (oref path parent-db)) | ||
| 309 | (t (let ((tt (semantic-something-to-tag-table path))) | ||
| 310 | (save-excursion | ||
| 311 | ;; @todo - What does this DO ??!?! | ||
| 312 | (set-buffer (semantic-tag-buffer (car tt))) | ||
| 313 | semanticdb-current-database)))))) | ||
| 314 | (apply | ||
| 315 | #'nconc | ||
| 316 | (mapcar | ||
| 317 | (lambda (db) | ||
| 318 | (let ((tabs (semanticdb-get-database-tables db)) | ||
| 319 | (ret nil)) | ||
| 320 | ;; Only return tables of the same language (major-mode) | ||
| 321 | ;; as the current search environment. | ||
| 322 | (while tabs | ||
| 323 | |||
| 324 | (semantic-throw-on-input 'translate-path-brutish) | ||
| 325 | |||
| 326 | (if (semanticdb-equivalent-mode-for-search (car tabs) | ||
| 327 | (current-buffer)) | ||
| 328 | (setq ret (cons (car tabs) ret))) | ||
| 329 | (setq tabs (cdr tabs))) | ||
| 330 | ret)) | ||
| 331 | ;; FIXME: | ||
| 332 | ;; This should scan the current project directory list for all | ||
| 333 | ;; semanticdb files, perhaps handling proxies for them. | ||
| 334 | (semanticdb-current-database-list | ||
| 335 | (if basedb (oref basedb reference-directory) | ||
| 336 | default-directory)))) | ||
| 337 | )) | ||
| 338 | |||
| 339 | (defun semanticdb-find-incomplete-cache-entries-p (cache) | ||
| 340 | "Are there any incomplete entries in CACHE?" | ||
| 341 | (let ((ans nil)) | ||
| 342 | (dolist (tab cache) | ||
| 343 | (when (and (semanticdb-table-child-p tab) | ||
| 344 | (not (number-or-marker-p (oref tab pointmax)))) | ||
| 345 | (setq ans t)) | ||
| 346 | ) | ||
| 347 | ans)) | ||
| 348 | |||
| 349 | (defun semanticdb-find-need-cache-update-p (table) | ||
| 350 | "Non nil if the semanticdb TABLE cache needs to be updated." | ||
| 351 | ;; If we were passed in something related to a TABLE, | ||
| 352 | ;; do a caching lookup. | ||
| 353 | (let* ((index (semanticdb-get-table-index table)) | ||
| 354 | (cache (when index (oref index include-path))) | ||
| 355 | (incom (semanticdb-find-incomplete-cache-entries-p cache)) | ||
| 356 | (unl (semanticdb-find-throttle-active-p 'unloaded)) | ||
| 357 | ) | ||
| 358 | (if (and | ||
| 359 | cache ;; Must have a cache | ||
| 360 | (or | ||
| 361 | ;; If all entries are "full", or if 'unloaded | ||
| 362 | ;; OR | ||
| 363 | ;; is not in the throttle, it is ok to use the cache. | ||
| 364 | (not incom) (not unl) | ||
| 365 | )) | ||
| 366 | nil | ||
| 367 | ;;cache | ||
| 368 | ;; ELSE | ||
| 369 | ;; | ||
| 370 | ;; We need an update. | ||
| 371 | t)) | ||
| 372 | ) | ||
| 373 | |||
| 374 | (defun semanticdb-find-translate-path-includes-default (path) | ||
| 375 | "Translate PATH into a list of semantic tables. | ||
| 376 | Default action as described in `semanticdb-find-translate-path'." | ||
| 377 | (let ((table (cond ((null path) | ||
| 378 | semanticdb-current-table) | ||
| 379 | ((bufferp path) | ||
| 380 | (semantic-buffer-local-value 'semanticdb-current-table path)) | ||
| 381 | ((and (stringp path) (file-exists-p path)) | ||
| 382 | (semanticdb-file-table-object path t)) | ||
| 383 | ((semanticdb-abstract-table-child-p path) | ||
| 384 | path) | ||
| 385 | (t nil)))) | ||
| 386 | (if table | ||
| 387 | ;; If we were passed in something related to a TABLE, | ||
| 388 | ;; do a caching lookup. | ||
| 389 | (let ((index (semanticdb-get-table-index table))) | ||
| 390 | (if (semanticdb-find-need-cache-update-p table) | ||
| 391 | ;; Lets go look up our indicies | ||
| 392 | (let ((ans (semanticdb-find-translate-path-includes--internal path))) | ||
| 393 | (oset index include-path ans) | ||
| 394 | ;; Once we have our new indicies set up, notify those | ||
| 395 | ;; who depend on us if we found something for them to | ||
| 396 | ;; depend on. | ||
| 397 | (when ans (semanticdb-refresh-references table)) | ||
| 398 | ans) | ||
| 399 | ;; ELSE | ||
| 400 | ;; | ||
| 401 | ;; Just return the cache. | ||
| 402 | (oref index include-path))) | ||
| 403 | ;; If we were passed in something like a tag list, or other boring | ||
| 404 | ;; searchable item, then instead do the regular thing without caching. | ||
| 405 | (semanticdb-find-translate-path-includes--internal path)))) | ||
| 406 | |||
| 407 | (defvar semanticdb-find-lost-includes nil | ||
| 408 | "Include files that we cannot find associated with this buffer.") | ||
| 409 | (make-variable-buffer-local 'semanticdb-find-lost-includes) | ||
| 410 | |||
| 411 | (defvar semanticdb-find-scanned-include-tags nil | ||
| 412 | "All include tags scanned, plus action taken on the tag. | ||
| 413 | Each entry is an alist: | ||
| 414 | (ACTION . TAG) | ||
| 415 | where ACTION is one of 'scanned, 'duplicate, 'lost. | ||
| 416 | and TAG is a clone of the include tag that was found.") | ||
| 417 | (make-variable-buffer-local 'semanticdb-find-scanned-include-tags) | ||
| 418 | |||
| 419 | (defvar semanticdb-implied-include-tags nil | ||
| 420 | "Include tags implied for all files of a given mode. | ||
| 421 | Set this variable with `defvar-mode-local' for a particular mode so | ||
| 422 | that any symbols that exist for all files for that mode are included. | ||
| 423 | |||
| 424 | Note: This could be used as a way to write a file in a langauge | ||
| 425 | to declare all the built-ins for that language.") | ||
| 426 | |||
| 427 | (defun semanticdb-find-translate-path-includes--internal (path) | ||
| 428 | "Internal implementation of `semanticdb-find-translate-path-includes-default'. | ||
| 429 | This routine does not depend on the cache, but will always derive | ||
| 430 | a new path from the provided PATH." | ||
| 431 | (let ((includetags nil) | ||
| 432 | (curtable nil) | ||
| 433 | (matchedtables (list semanticdb-current-table)) | ||
| 434 | (matchedincludes nil) | ||
| 435 | (lostincludes nil) | ||
| 436 | (scannedincludes nil) | ||
| 437 | (incfname nil) | ||
| 438 | nexttable) | ||
| 439 | (cond ((null path) | ||
| 440 | (semantic-refresh-tags-safe) | ||
| 441 | (setq includetags (append | ||
| 442 | (semantic-find-tags-included (current-buffer)) | ||
| 443 | semanticdb-implied-include-tags) | ||
| 444 | curtable semanticdb-current-table | ||
| 445 | incfname (buffer-file-name)) | ||
| 446 | ) | ||
| 447 | ((semanticdb-table-p path) | ||
| 448 | (setq includetags (semantic-find-tags-included path) | ||
| 449 | curtable path | ||
| 450 | incfname (semanticdb-full-filename path)) | ||
| 451 | ) | ||
| 452 | ((bufferp path) | ||
| 453 | (save-excursion | ||
| 454 | (set-buffer path) | ||
| 455 | (semantic-refresh-tags-safe)) | ||
| 456 | (setq includetags (semantic-find-tags-included path) | ||
| 457 | curtable (save-excursion (set-buffer path) | ||
| 458 | semanticdb-current-table) | ||
| 459 | incfname (buffer-file-name path))) | ||
| 460 | (t | ||
| 461 | (setq includetags (semantic-find-tags-included path)) | ||
| 462 | (when includetags | ||
| 463 | ;; If we have some tags, derive a table from them. | ||
| 464 | ;; else we will do nothing, so the table is useless. | ||
| 465 | |||
| 466 | ;; @todo - derive some tables | ||
| 467 | (message "Need to derive tables for %S in translate-path-includes--default." | ||
| 468 | path) | ||
| 469 | ))) | ||
| 470 | |||
| 471 | ;; Make sure each found include tag has an originating file name associated | ||
| 472 | ;; with it. | ||
| 473 | (when incfname | ||
| 474 | (dolist (it includetags) | ||
| 475 | (semantic--tag-put-property it :filename incfname))) | ||
| 476 | |||
| 477 | ;; Loop over all include tags adding to matchedtables | ||
| 478 | (while includetags | ||
| 479 | (semantic-throw-on-input 'semantic-find-translate-path-includes-default) | ||
| 480 | |||
| 481 | ;; If we've seen this include string before, lets skip it. | ||
| 482 | (if (member (semantic-tag-name (car includetags)) matchedincludes) | ||
| 483 | (progn | ||
| 484 | (setq nexttable nil) | ||
| 485 | (push (cons 'duplicate (semantic-tag-clone (car includetags))) | ||
| 486 | scannedincludes) | ||
| 487 | ) | ||
| 488 | (setq nexttable (semanticdb-find-table-for-include (car includetags) curtable)) | ||
| 489 | (when (not nexttable) | ||
| 490 | ;; Save the lost include. | ||
| 491 | (push (car includetags) lostincludes) | ||
| 492 | (push (cons 'lost (semantic-tag-clone (car includetags))) | ||
| 493 | scannedincludes) | ||
| 494 | ) | ||
| 495 | ) | ||
| 496 | |||
| 497 | ;; Push the include file, so if we can't find it, we only | ||
| 498 | ;; can't find it once. | ||
| 499 | (push (semantic-tag-name (car includetags)) matchedincludes) | ||
| 500 | |||
| 501 | ;; (message "Scanning %s" (semantic-tag-name (car includetags))) | ||
| 502 | (when (and nexttable | ||
| 503 | (not (memq nexttable matchedtables)) | ||
| 504 | (semanticdb-equivalent-mode-for-search nexttable | ||
| 505 | (current-buffer)) | ||
| 506 | ) | ||
| 507 | ;; Add to list of tables | ||
| 508 | (push nexttable matchedtables) | ||
| 509 | |||
| 510 | ;; Queue new includes to list | ||
| 511 | (if (semanticdb-find-throttle-active-p 'recursive) | ||
| 512 | ;; @todo - recursive includes need to have the originating | ||
| 513 | ;; buffer's location added to the path. | ||
| 514 | (let ((newtags | ||
| 515 | (cond | ||
| 516 | ((semanticdb-table-p nexttable) | ||
| 517 | (semanticdb-refresh-table nexttable) | ||
| 518 | ;; Use the method directly, or we will recurse | ||
| 519 | ;; into ourselves here. | ||
| 520 | (semanticdb-find-tags-by-class-method | ||
| 521 | nexttable 'include)) | ||
| 522 | (t ;; @todo - is this ever possible??? | ||
| 523 | (message "semanticdb-ftp - how did you do that?") | ||
| 524 | (semantic-find-tags-included | ||
| 525 | (semanticdb-get-tags nexttable))) | ||
| 526 | )) | ||
| 527 | (newincfname (semanticdb-full-filename nexttable)) | ||
| 528 | ) | ||
| 529 | |||
| 530 | (push (cons 'scanned (semantic-tag-clone (car includetags))) | ||
| 531 | scannedincludes) | ||
| 532 | |||
| 533 | ;; Setup new tags so we know where they are. | ||
| 534 | (dolist (it newtags) | ||
| 535 | (semantic--tag-put-property it :filename | ||
| 536 | newincfname)) | ||
| 537 | |||
| 538 | (setq includetags (nconc includetags newtags))) | ||
| 539 | ;; ELSE - not recursive throttle | ||
| 540 | (push (cons 'scanned-no-recurse | ||
| 541 | (semantic-tag-clone (car includetags))) | ||
| 542 | scannedincludes) | ||
| 543 | ) | ||
| 544 | ) | ||
| 545 | (setq includetags (cdr includetags))) | ||
| 546 | |||
| 547 | (setq semanticdb-find-lost-includes lostincludes) | ||
| 548 | (setq semanticdb-find-scanned-include-tags (reverse scannedincludes)) | ||
| 549 | |||
| 550 | ;; Find all the omniscient databases for this major mode, and | ||
| 551 | ;; add them if needed | ||
| 552 | (when (and (semanticdb-find-throttle-active-p 'omniscience) | ||
| 553 | semanticdb-search-system-databases) | ||
| 554 | ;; We can append any mode-specific omniscience databases into | ||
| 555 | ;; our search list here. | ||
| 556 | (let ((systemdb semanticdb-project-system-databases) | ||
| 557 | (ans nil)) | ||
| 558 | (while systemdb | ||
| 559 | (setq ans (semanticdb-file-table | ||
| 560 | (car systemdb) | ||
| 561 | ;; I would expect most omniscient to return the same | ||
| 562 | ;; thing reguardless of filename, but we may have | ||
| 563 | ;; one that can return a table of all things the | ||
| 564 | ;; current file needs. | ||
| 565 | (buffer-file-name (current-buffer)))) | ||
| 566 | (when (not (memq ans matchedtables)) | ||
| 567 | (setq matchedtables (cons ans matchedtables))) | ||
| 568 | (setq systemdb (cdr systemdb)))) | ||
| 569 | ) | ||
| 570 | (nreverse matchedtables))) | ||
| 571 | |||
| 572 | (define-overloadable-function semanticdb-find-load-unloaded (filename) | ||
| 573 | "Create a database table for FILENAME if it hasn't been parsed yet. | ||
| 574 | Assumes that FILENAME exists as a source file. | ||
| 575 | Assumes that a preexisting table does not exist, even if it | ||
| 576 | isn't in memory yet." | ||
| 577 | (if (semanticdb-find-throttle-active-p 'unloaded) | ||
| 578 | (:override) | ||
| 579 | (semanticdb-file-table-object filename t))) | ||
| 580 | |||
| 581 | (defun semanticdb-find-load-unloaded-default (filename) | ||
| 582 | "Load an unloaded file in FILENAME using the default semanticdb loader." | ||
| 583 | (semanticdb-file-table-object filename)) | ||
| 584 | |||
| 585 | (define-overloadable-function semanticdb-find-table-for-include (includetag &optional table) | ||
| 586 | "For a single INCLUDETAG found in TABLE, find a `semanticdb-table' object | ||
| 587 | INCLUDETAG is a semantic TAG of class 'include. | ||
| 588 | TABLE is a semanticdb table that identifies where INCLUDETAG came from. | ||
| 589 | TABLE is optional if INCLUDETAG has an overlay of :filename attribute." | ||
| 590 | ) | ||
| 591 | |||
| 592 | (defun semanticdb-find-table-for-include-default (includetag &optional table) | ||
| 593 | "Default implementation of `semanticdb-find-table-for-include'. | ||
| 594 | Uses `semanticdb-current-database-list' as the search path. | ||
| 595 | INCLUDETAG and TABLE are documented in `semanticdb-find-table-for-include'. | ||
| 596 | Included databases are filtered based on `semanticdb-find-default-throttle'." | ||
| 597 | (if (not (eq (semantic-tag-class includetag) 'include)) | ||
| 598 | (signal 'wrong-type-argument (list includetag 'include))) | ||
| 599 | |||
| 600 | (let ((name | ||
| 601 | ;; Note, some languages (like Emacs or Java) use include tag names | ||
| 602 | ;; that don't represent files! We want to have file names. | ||
| 603 | (semantic-tag-include-filename includetag)) | ||
| 604 | (originfiledir nil) | ||
| 605 | (roots nil) | ||
| 606 | (tmp nil) | ||
| 607 | (ans nil)) | ||
| 608 | |||
| 609 | ;; INCLUDETAG should have some way to reference where it came | ||
| 610 | ;; from! If not, TABLE should provide the way. Each time we | ||
| 611 | ;; look up a tag, we may need to find it in some relative way | ||
| 612 | ;; and must set our current buffer eto the origin of includetag | ||
| 613 | ;; or nothing may work. | ||
| 614 | (setq originfiledir | ||
| 615 | (cond ((semantic-tag-file-name includetag) | ||
| 616 | ;; A tag may have a buffer, or a :filename property. | ||
| 617 | (file-name-directory (semantic-tag-file-name includetag))) | ||
| 618 | (table | ||
| 619 | (file-name-directory (semanticdb-full-filename table))) | ||
| 620 | (t | ||
| 621 | ;; @todo - what to do here? Throw an error maybe | ||
| 622 | ;; and fix usage bugs? | ||
| 623 | default-directory))) | ||
| 624 | |||
| 625 | (cond | ||
| 626 | ;; Step 1: Relative path name | ||
| 627 | ;; | ||
| 628 | ;; If the name is relative, then it should be findable as relative | ||
| 629 | ;; to the source file that this tag originated in, and be fast. | ||
| 630 | ;; | ||
| 631 | ((and (semanticdb-find-throttle-active-p 'local) | ||
| 632 | (file-exists-p (expand-file-name name originfiledir))) | ||
| 633 | |||
| 634 | (setq ans (semanticdb-find-load-unloaded | ||
| 635 | (expand-file-name name originfiledir))) | ||
| 636 | ) | ||
| 637 | ;; Step 2: System or Project level includes | ||
| 638 | ;; | ||
| 639 | ((or | ||
| 640 | ;; First, if it a system include, we can investigate that tags | ||
| 641 | ;; dependency file | ||
| 642 | (and (semanticdb-find-throttle-active-p 'system) | ||
| 643 | |||
| 644 | ;; Sadly, not all languages make this distinction. | ||
| 645 | ;;(semantic-tag-include-system-p includetag) | ||
| 646 | |||
| 647 | ;; Here, we get local and system files. | ||
| 648 | (setq tmp (semantic-dependency-tag-file includetag)) | ||
| 649 | ) | ||
| 650 | ;; Second, project files are active, we and we have EDE, | ||
| 651 | ;; we can find it using the same tool. | ||
| 652 | (and (semanticdb-find-throttle-active-p 'project) | ||
| 653 | ;; Make sure EDE is available, and we have a project | ||
| 654 | (featurep 'ede) (ede-current-project originfiledir) | ||
| 655 | ;; The EDE query is hidden in this call. | ||
| 656 | (setq tmp (semantic-dependency-tag-file includetag)) | ||
| 657 | ) | ||
| 658 | ) | ||
| 659 | (setq ans (semanticdb-find-load-unloaded tmp)) | ||
| 660 | ) | ||
| 661 | ;; Somewhere in our project hierarchy | ||
| 662 | ;; | ||
| 663 | ;; Remember: Roots includes system databases which can create | ||
| 664 | ;; specialized tables we can search. | ||
| 665 | ;; | ||
| 666 | ;; NOTE: Not used if EDE is active! | ||
| 667 | ((and (semanticdb-find-throttle-active-p 'project) | ||
| 668 | ;; And dont do this if it is a system include. Not supported by all languages, | ||
| 669 | ;; but when it is, this is a nice fast way to skip this step. | ||
| 670 | (not (semantic-tag-include-system-p includetag)) | ||
| 671 | ;; Don't do this if we have an EDE project. | ||
| 672 | (not (and (featurep 'ede) | ||
| 673 | ;; Note: We don't use originfiledir here because | ||
| 674 | ;; we want to know about the source file we are | ||
| 675 | ;; starting from. | ||
| 676 | (ede-current-project))) | ||
| 677 | ) | ||
| 678 | |||
| 679 | (setq roots (semanticdb-current-database-list)) | ||
| 680 | |||
| 681 | (while (and (not ans) roots) | ||
| 682 | (let* ((ref (if (slot-boundp (car roots) 'reference-directory) | ||
| 683 | (oref (car roots) reference-directory))) | ||
| 684 | (fname (cond ((null ref) nil) | ||
| 685 | ((file-exists-p (expand-file-name name ref)) | ||
| 686 | (expand-file-name name ref)) | ||
| 687 | ((file-exists-p (expand-file-name (file-name-nondirectory name) ref)) | ||
| 688 | (expand-file-name (file-name-nondirectory name) ref))))) | ||
| 689 | (when (and ref fname) | ||
| 690 | ;; There is an actual file. Grab it. | ||
| 691 | (setq ans (semanticdb-find-load-unloaded fname))) | ||
| 692 | |||
| 693 | ;; ELSE | ||
| 694 | ;; | ||
| 695 | ;; NOTE: We used to look up omniscient databases here, but that | ||
| 696 | ;; is now handled one layer up. | ||
| 697 | ;; | ||
| 698 | ;; Missing: a database that knows where missing files are. Hmm. | ||
| 699 | ;; perhaps I need an override function for that? | ||
| 700 | |||
| 701 | ) | ||
| 702 | |||
| 703 | (setq roots (cdr roots)))) | ||
| 704 | ) | ||
| 705 | ans)) | ||
| 706 | |||
| 707 | |||
| 708 | ;;; Perform interactive tests on the path/search mechanisms. | ||
| 709 | ;; | ||
| 710 | (defun semanticdb-find-test-translate-path (&optional arg) | ||
| 711 | "Call and output results of `semanticdb-find-translate-path'. | ||
| 712 | With ARG non-nil, specify a BRUTISH translation. | ||
| 713 | See `semanticdb-find-default-throttle' and `semanticdb-project-roots' | ||
| 714 | for details on how this list is derived." | ||
| 715 | (interactive "P") | ||
| 716 | (semantic-fetch-tags) | ||
| 717 | (require 'data-debug) | ||
| 718 | (let ((start (current-time)) | ||
| 719 | (p (semanticdb-find-translate-path nil arg)) | ||
| 720 | (end (current-time)) | ||
| 721 | ) | ||
| 722 | (data-debug-new-buffer "*SEMANTICDB FTP ADEBUG*") | ||
| 723 | (message "Search of tags took %.2f seconds." | ||
| 724 | (semantic-elapsed-time start end)) | ||
| 725 | |||
| 726 | (data-debug-insert-stuff-list p "*"))) | ||
| 727 | |||
| 728 | (defun semanticdb-find-test-translate-path-no-loading (&optional arg) | ||
| 729 | "Call and output results of `semanticdb-find-translate-path'. | ||
| 730 | With ARG non-nil, specify a BRUTISH translation. | ||
| 731 | See `semanticdb-find-default-throttle' and `semanticdb-project-roots' | ||
| 732 | for details on how this list is derived." | ||
| 733 | (interactive "P") | ||
| 734 | (semantic-fetch-tags) | ||
| 735 | (require 'data-debug) | ||
| 736 | (let* ((semanticdb-find-default-throttle | ||
| 737 | (if (featurep 'semanticdb-find) | ||
| 738 | (remq 'unloaded semanticdb-find-default-throttle) | ||
| 739 | nil)) | ||
| 740 | (start (current-time)) | ||
| 741 | (p (semanticdb-find-translate-path nil arg)) | ||
| 742 | (end (current-time)) | ||
| 743 | ) | ||
| 744 | (data-debug-new-buffer "*SEMANTICDB FTP ADEBUG*") | ||
| 745 | (message "Search of tags took %.2f seconds." | ||
| 746 | (semantic-elapsed-time start end)) | ||
| 747 | |||
| 748 | (data-debug-insert-stuff-list p "*"))) | ||
| 749 | |||
| 750 | (defun semanticdb-find-adebug-lost-includes () | ||
| 751 | "Translate the current path, then display the lost includes. | ||
| 752 | Examines the variable `semanticdb-find-lost-includes'." | ||
| 753 | (interactive) | ||
| 754 | (require 'data-debug) | ||
| 755 | (semanticdb-find-translate-path nil nil) | ||
| 756 | (let ((lost semanticdb-find-lost-includes) | ||
| 757 | ) | ||
| 758 | |||
| 759 | (if (not lost) | ||
| 760 | (message "There are no unknown includes for %s" | ||
| 761 | (buffer-name)) | ||
| 762 | |||
| 763 | (data-debug-new-buffer "*SEMANTICDB lost-includes ADEBUG*") | ||
| 764 | (data-debug-insert-tag-list lost "*") | ||
| 765 | ))) | ||
| 766 | |||
| 767 | (defun semanticdb-find-adebug-insert-scanned-tag-cons (consdata prefix prebuttontext) | ||
| 768 | "Insert a button representing scanned include CONSDATA. | ||
| 769 | PREFIX is the text that preceeds the button. | ||
| 770 | PREBUTTONTEXT is some text between prefix and the overlay button." | ||
| 771 | (let* ((start (point)) | ||
| 772 | (end nil) | ||
| 773 | (mode (car consdata)) | ||
| 774 | (tag (cdr consdata)) | ||
| 775 | (name (semantic-tag-name tag)) | ||
| 776 | (file (semantic-tag-file-name tag)) | ||
| 777 | (str1 (format "%S %s" mode name)) | ||
| 778 | (str2 (format " : %s" file)) | ||
| 779 | (tip nil)) | ||
| 780 | (insert prefix prebuttontext str1) | ||
| 781 | (setq end (point)) | ||
| 782 | (insert str2) | ||
| 783 | (put-text-property start end 'face | ||
| 784 | (cond ((eq mode 'scanned) | ||
| 785 | 'font-lock-function-name-face) | ||
| 786 | ((eq mode 'duplicate) | ||
| 787 | 'font-lock-comment-face) | ||
| 788 | ((eq mode 'lost) | ||
| 789 | 'font-lock-variable-name-face) | ||
| 790 | ((eq mode 'scanned-no-recurse) | ||
| 791 | 'font-lock-type-face))) | ||
| 792 | (put-text-property start end 'ddebug (cdr consdata)) | ||
| 793 | (put-text-property start end 'ddebug-indent(length prefix)) | ||
| 794 | (put-text-property start end 'ddebug-prefix prefix) | ||
| 795 | (put-text-property start end 'help-echo tip) | ||
| 796 | (put-text-property start end 'ddebug-function | ||
| 797 | 'data-debug-insert-tag-parts-from-point) | ||
| 798 | (insert "\n") | ||
| 799 | ) | ||
| 800 | ) | ||
| 801 | |||
| 802 | (defun semanticdb-find-adebug-scanned-includes () | ||
| 803 | "Translate the current path, then display the lost includes. | ||
| 804 | Examines the variable `semanticdb-find-lost-includes'." | ||
| 805 | (interactive) | ||
| 806 | (require 'data-debug) | ||
| 807 | (semanticdb-find-translate-path nil nil) | ||
| 808 | (let ((scanned semanticdb-find-scanned-include-tags) | ||
| 809 | (data-debug-thing-alist | ||
| 810 | (cons | ||
| 811 | '((lambda (thing) (and (consp thing) | ||
| 812 | (symbolp (car thing)) | ||
| 813 | (memq (car thing) | ||
| 814 | '(scanned scanned-no-recurse | ||
| 815 | lost duplicate)))) | ||
| 816 | . semanticdb-find-adebug-insert-scanned-tag-cons) | ||
| 817 | data-debug-thing-alist)) | ||
| 818 | ) | ||
| 819 | |||
| 820 | (if (not scanned) | ||
| 821 | (message "There are no includes scanned %s" | ||
| 822 | (buffer-name)) | ||
| 823 | |||
| 824 | (data-debug-new-buffer "*SEMANTICDB scanned-includes ADEBUG*") | ||
| 825 | (data-debug-insert-stuff-list scanned "*") | ||
| 826 | ))) | ||
| 827 | |||
| 828 | ;;; FIND results and edebug | ||
| 829 | ;; | ||
| 830 | (eval-after-load "cedet-edebug" | ||
| 831 | '(progn | ||
| 832 | (cedet-edebug-add-print-override | ||
| 833 | '(semanticdb-find-results-p object) | ||
| 834 | '(semanticdb-find-result-prin1-to-string object) ) | ||
| 835 | )) | ||
| 836 | |||
| 837 | |||
| 838 | |||
| 839 | ;;; API Functions | ||
| 840 | ;; | ||
| 841 | ;; Once you have a search result, use these routines to operate | ||
| 842 | ;; on the search results at a higher level | ||
| 843 | |||
| 844 | (defun semanticdb-strip-find-results (results &optional find-file-match) | ||
| 845 | "Strip a semanticdb search RESULTS to exclude objects. | ||
| 846 | This makes it appear more like the results of a `semantic-find-' call. | ||
| 847 | Optional FIND-FILE-MATCH loads all files associated with RESULTS | ||
| 848 | into buffers. This has the side effect of enabling `semantic-tag-buffer' to | ||
| 849 | return a value. | ||
| 850 | If FIND-FILE-MATCH is 'name, then only the filename is stored | ||
| 851 | in each tag instead of loading each file into a buffer. | ||
| 852 | If the input RESULTS are not going to be used again, and if | ||
| 853 | FIND-FILE-MATCH is nil, you can use `semanticdb-fast-strip-find-results' | ||
| 854 | instead." | ||
| 855 | (if find-file-match | ||
| 856 | ;; Load all files associated with RESULTS. | ||
| 857 | (let ((tmp results) | ||
| 858 | (output nil)) | ||
| 859 | (while tmp | ||
| 860 | (let ((tab (car (car tmp))) | ||
| 861 | (tags (cdr (car tmp)))) | ||
| 862 | (dolist (T tags) | ||
| 863 | ;; Normilzation gives specialty database tables a chance | ||
| 864 | ;; to convert into a more stable tag format. | ||
| 865 | (let* ((norm (semanticdb-normalize-one-tag tab T)) | ||
| 866 | (ntab (car norm)) | ||
| 867 | (ntag (cdr norm)) | ||
| 868 | (nametable ntab)) | ||
| 869 | |||
| 870 | ;; If it didn't normalize, use what we had. | ||
| 871 | (if (not norm) | ||
| 872 | (setq nametable tab) | ||
| 873 | (setq output (append output (list ntag)))) | ||
| 874 | |||
| 875 | ;; Find-file-match allows a tool to make sure the tag is | ||
| 876 | ;; 'live', somewhere in a buffer. | ||
| 877 | (cond ((eq find-file-match 'name) | ||
| 878 | (let ((f (semanticdb-full-filename nametable))) | ||
| 879 | (semantic--tag-put-property ntag :filename f))) | ||
| 880 | ((and find-file-match ntab) | ||
| 881 | (semanticdb-get-buffer ntab)) | ||
| 882 | ) | ||
| 883 | )) | ||
| 884 | ) | ||
| 885 | (setq tmp (cdr tmp))) | ||
| 886 | output) | ||
| 887 | ;; @todo - I could use nconc, but I don't know what the caller may do with | ||
| 888 | ;; RESULTS after this is called. Right now semantic-complete will | ||
| 889 | ;; recycling the input after calling this routine. | ||
| 890 | (apply #'append (mapcar #'cdr results)))) | ||
| 891 | |||
| 892 | (defun semanticdb-fast-strip-find-results (results) | ||
| 893 | "Destructively strip a semanticdb search RESULTS to exclude objects. | ||
| 894 | This makes it appear more like the results of a `semantic-find-' call. | ||
| 895 | This is like `semanticdb-strip-find-results', except the input list RESULTS | ||
| 896 | will be changed." | ||
| 897 | (apply #'nconc (mapcar #'cdr results))) | ||
| 898 | |||
| 899 | (defun semanticdb-find-results-p (resultp) | ||
| 900 | "Non-nil if RESULTP is in the form of a semanticdb search result. | ||
| 901 | This query only really tests the first entry in the list that is RESULTP, | ||
| 902 | but should be good enough for debugging assertions." | ||
| 903 | (and (listp resultp) | ||
| 904 | (listp (car resultp)) | ||
| 905 | (semanticdb-abstract-table-child-p (car (car resultp))) | ||
| 906 | (or (semantic-tag-p (car (cdr (car resultp)))) | ||
| 907 | (null (car (cdr (car resultp))))))) | ||
| 908 | |||
| 909 | (defun semanticdb-find-result-prin1-to-string (result) | ||
| 910 | "Presuming RESULT satisfies `semanticdb-find-results-p', provide a short PRIN1 output." | ||
| 911 | (if (< (length result) 2) | ||
| 912 | (concat "#<FIND RESULT " | ||
| 913 | (mapconcat (lambda (a) | ||
| 914 | (concat "(" (object-name (car a) ) " . " | ||
| 915 | "#<TAG LIST " (number-to-string (length (cdr a))) ">)")) | ||
| 916 | result | ||
| 917 | " ") | ||
| 918 | ">") | ||
| 919 | ;; Longer results should have an abreviated form. | ||
| 920 | (format "#<FIND RESULT %d TAGS in %d FILES>" | ||
| 921 | (semanticdb-find-result-length result) | ||
| 922 | (length result)))) | ||
| 923 | |||
| 924 | (defun semanticdb-find-result-with-nil-p (resultp) | ||
| 925 | "Non-nil of RESULTP is in the form of a semanticdb search result. | ||
| 926 | nil is a valid value where a TABLE usually is, but only if the TAG | ||
| 927 | results include overlays. | ||
| 928 | This query only really tests the first entry in the list that is RESULTP, | ||
| 929 | but should be good enough for debugging assertions." | ||
| 930 | (and (listp resultp) | ||
| 931 | (listp (car resultp)) | ||
| 932 | (let ((tag-to-test (car-safe (cdr (car resultp))))) | ||
| 933 | (or (and (semanticdb-abstract-table-child-p (car (car resultp))) | ||
| 934 | (or (semantic-tag-p tag-to-test) | ||
| 935 | (null tag-to-test))) | ||
| 936 | (and (null (car (car resultp))) | ||
| 937 | (or (semantic-tag-with-position-p tag-to-test) | ||
| 938 | (null tag-to-test)))) | ||
| 939 | ))) | ||
| 940 | |||
| 941 | (defun semanticdb-find-result-length (result) | ||
| 942 | "Number of tags found in RESULT." | ||
| 943 | (let ((count 0)) | ||
| 944 | (mapc (lambda (onetable) | ||
| 945 | (setq count (+ count (1- (length onetable))))) | ||
| 946 | result) | ||
| 947 | count)) | ||
| 948 | |||
| 949 | (defun semanticdb-find-result-nth (result n) | ||
| 950 | "In RESULT, return the Nth search result. | ||
| 951 | This is a 0 based search result, with the first match being element 0. | ||
| 952 | |||
| 953 | The returned value is a cons cell: (TAG . TABLE) where TAG | ||
| 954 | is the tag at the Nth position. TABLE is the semanticdb table where | ||
| 955 | the TAG was found. Sometimes TABLE can be nil." | ||
| 956 | (let ((ans nil) | ||
| 957 | (anstable nil)) | ||
| 958 | ;; Loop over each single table hit. | ||
| 959 | (while (and (not ans) result) | ||
| 960 | ;; For each table result, get local length, and modify | ||
| 961 | ;; N to be that much less. | ||
| 962 | (let ((ll (length (cdr (car result))))) ;; local length | ||
| 963 | (if (> ll n) | ||
| 964 | ;; We have a local match. | ||
| 965 | (setq ans (nth n (cdr (car result))) | ||
| 966 | anstable (car (car result))) | ||
| 967 | ;; More to go. Decrement N. | ||
| 968 | (setq n (- n ll)))) | ||
| 969 | ;; Keep moving. | ||
| 970 | (setq result (cdr result))) | ||
| 971 | (cons ans anstable))) | ||
| 972 | |||
| 973 | (defun semanticdb-find-result-test (result) | ||
| 974 | "Test RESULT by accessing all the tags in the list." | ||
| 975 | (if (not (semanticdb-find-results-p result)) | ||
| 976 | (error "Does not pass `semanticdb-find-results-p.\n")) | ||
| 977 | (let ((len (semanticdb-find-result-length result)) | ||
| 978 | (i 0)) | ||
| 979 | (while (< i len) | ||
| 980 | (let ((tag (semanticdb-find-result-nth result i))) | ||
| 981 | (if (not (semantic-tag-p (car tag))) | ||
| 982 | (error "%d entry is not a tag" i))) | ||
| 983 | (setq i (1+ i))))) | ||
| 984 | |||
| 985 | (defun semanticdb-find-result-nth-in-buffer (result n) | ||
| 986 | "In RESULT, return the Nth search result. | ||
| 987 | Like `semanticdb-find-result-nth', except that only the TAG | ||
| 988 | is returned, and the buffer it is found it will be made current. | ||
| 989 | If the result tag has no position information, the originating buffer | ||
| 990 | is still made current." | ||
| 991 | (let* ((ret (semanticdb-find-result-nth result n)) | ||
| 992 | (ans (car ret)) | ||
| 993 | (anstable (cdr ret))) | ||
| 994 | ;; If we have a hit, double-check the find-file | ||
| 995 | ;; entry. If the file must be loaded, then gat that table's | ||
| 996 | ;; source file into a buffer. | ||
| 997 | |||
| 998 | (if anstable | ||
| 999 | (let ((norm (semanticdb-normalize-one-tag anstable ans))) | ||
| 1000 | (when norm | ||
| 1001 | ;; The normalized tags can now be found based on that | ||
| 1002 | ;; tags table. | ||
| 1003 | (semanticdb-set-buffer (car norm)) | ||
| 1004 | ;; Now reset ans | ||
| 1005 | (setq ans (cdr norm)) | ||
| 1006 | )) | ||
| 1007 | ) | ||
| 1008 | ;; Return the tag. | ||
| 1009 | ans)) | ||
| 1010 | |||
| 1011 | (defun semanticdb-find-result-mapc (fcn result) | ||
| 1012 | "Apply FCN to each element of find RESULT for side-effects only. | ||
| 1013 | FCN takes two arguments. The first is a TAG, and the | ||
| 1014 | second is a DB from wence TAG originated. | ||
| 1015 | Returns result." | ||
| 1016 | (mapc (lambda (sublst) | ||
| 1017 | (mapc (lambda (tag) | ||
| 1018 | (funcall fcn tag (car sublst))) | ||
| 1019 | (cdr sublst))) | ||
| 1020 | result) | ||
| 1021 | result) | ||
| 1022 | |||
| 1023 | ;;; Search Logging | ||
| 1024 | ;; | ||
| 1025 | ;; Basic logging to see what the search routines are doing. | ||
| 1026 | (defvar semanticdb-find-log-flag nil | ||
| 1027 | "Non-nil means log the process of searches.") | ||
| 1028 | |||
| 1029 | (defvar semanticdb-find-log-buffer-name "*SemanticDB Find Log*" | ||
| 1030 | "The name of the logging buffer.") | ||
| 1031 | |||
| 1032 | (defun semanticdb-find-toggle-logging () | ||
| 1033 | "Toggle sematnicdb logging." | ||
| 1034 | (interactive) | ||
| 1035 | (setq semanticdb-find-log-flag (null semanticdb-find-log-flag)) | ||
| 1036 | (message "Semanticdb find logging is %sabled" | ||
| 1037 | (if semanticdb-find-log-flag "en" "dis"))) | ||
| 1038 | |||
| 1039 | (defun semanticdb-reset-log () | ||
| 1040 | "Reset the log buffer." | ||
| 1041 | (interactive) | ||
| 1042 | (when semanticdb-find-log-flag | ||
| 1043 | (save-excursion | ||
| 1044 | (set-buffer (get-buffer-create semanticdb-find-log-buffer-name)) | ||
| 1045 | (erase-buffer) | ||
| 1046 | ))) | ||
| 1047 | |||
| 1048 | (defun semanticdb-find-log-move-to-end () | ||
| 1049 | "Move to the end of the semantic log." | ||
| 1050 | (let ((cb (current-buffer)) | ||
| 1051 | (cw (selected-window))) | ||
| 1052 | (unwind-protect | ||
| 1053 | (progn | ||
| 1054 | (set-buffer semanticdb-find-log-buffer-name) | ||
| 1055 | (if (get-buffer-window (current-buffer) 'visible) | ||
| 1056 | (select-window (get-buffer-window (current-buffer) 'visible))) | ||
| 1057 | (goto-char (point-max))) | ||
| 1058 | (if cw (select-window cw)) | ||
| 1059 | (set-buffer cb)))) | ||
| 1060 | |||
| 1061 | (defun semanticdb-find-log-new-search (forwhat) | ||
| 1062 | "Start a new search FORWHAT." | ||
| 1063 | (when semanticdb-find-log-flag | ||
| 1064 | (save-excursion | ||
| 1065 | (set-buffer (get-buffer-create semanticdb-find-log-buffer-name)) | ||
| 1066 | (insert (format "New Search: %S\n" forwhat)) | ||
| 1067 | ) | ||
| 1068 | (semanticdb-find-log-move-to-end))) | ||
| 1069 | |||
| 1070 | (defun semanticdb-find-log-activity (table result) | ||
| 1071 | "Log that TABLE has been searched and RESULT was found." | ||
| 1072 | (when semanticdb-find-log-flag | ||
| 1073 | (save-excursion | ||
| 1074 | (set-buffer semanticdb-find-log-buffer-name) | ||
| 1075 | (insert "Table: " (object-print table) | ||
| 1076 | " Result: " (int-to-string (length result)) " tags" | ||
| 1077 | "\n") | ||
| 1078 | ) | ||
| 1079 | (semanticdb-find-log-move-to-end))) | ||
| 1080 | |||
| 1081 | ;;; Semanticdb find API functions | ||
| 1082 | ;; | ||
| 1083 | ;; These are the routines actually used to perform searches. | ||
| 1084 | ;; | ||
| 1085 | (defun semanticdb-find-tags-collector (function &optional path find-file-match | ||
| 1086 | brutish) | ||
| 1087 | "Collect all tags returned by FUNCTION over PATH. | ||
| 1088 | The FUNCTION must take two arguments. The first is TABLE, | ||
| 1089 | which is a semanticdb table containing tags. The second argument | ||
| 1090 | to FUNCTION is TAGS. TAGS may be a list of tags. If TAGS is non-nil, then | ||
| 1091 | FUNCTION should search the TAG list, not through TABLE. | ||
| 1092 | |||
| 1093 | See `semanticdb-find-translate-path' for details on PATH. | ||
| 1094 | FIND-FILE-MATCH indicates that any time a match is found, the file | ||
| 1095 | associated with that tag should be loaded into a buffer. | ||
| 1096 | |||
| 1097 | Note: You should leave FIND-FILE-MATCH as nil. It is far more | ||
| 1098 | efficient to take the results from any search and use | ||
| 1099 | `semanticdb-strip-find-results' instead. This argument is here | ||
| 1100 | for backward compatibility. | ||
| 1101 | |||
| 1102 | If optional argument BRUTISH is non-nil, then ignore include statements, | ||
| 1103 | and search all tables in this project tree." | ||
| 1104 | (let (found match) | ||
| 1105 | (save-excursion | ||
| 1106 | ;; If path is a buffer, set ourselves up in that buffer | ||
| 1107 | ;; so that the override methods work correctly. | ||
| 1108 | (when (bufferp path) (set-buffer path)) | ||
| 1109 | (if (semanticdb-find-results-p path) | ||
| 1110 | ;; When we get find results, loop over that. | ||
| 1111 | (dolist (tableandtags path) | ||
| 1112 | (semantic-throw-on-input 'semantic-find-translate-path) | ||
| 1113 | ;; If FIND-FILE-MATCH is non-nil, skip tables of class | ||
| 1114 | ;; `semanticdb-search-results-table', since those are system | ||
| 1115 | ;; databases and not associated with a file. | ||
| 1116 | (unless (and find-file-match | ||
| 1117 | (obj-of-class-p | ||
| 1118 | (car tableandtags) semanticdb-search-results-table)) | ||
| 1119 | (when (setq match (funcall function | ||
| 1120 | (car tableandtags) (cdr tableandtags))) | ||
| 1121 | (when find-file-match | ||
| 1122 | (save-excursion (semanticdb-set-buffer (car tableandtags)))) | ||
| 1123 | (push (cons (car tableandtags) match) found))) | ||
| 1124 | ) | ||
| 1125 | ;; Only log searches across data bases. | ||
| 1126 | (semanticdb-find-log-new-search nil) | ||
| 1127 | ;; If we get something else, scan the list of tables resulting | ||
| 1128 | ;; from translating it into a list of objects. | ||
| 1129 | (dolist (table (semanticdb-find-translate-path path brutish)) | ||
| 1130 | (semantic-throw-on-input 'semantic-find-translate-path) | ||
| 1131 | ;; If FIND-FILE-MATCH is non-nil, skip tables of class | ||
| 1132 | ;; `semanticdb-search-results-table', since those are system | ||
| 1133 | ;; databases and not associated with a file. | ||
| 1134 | (unless (and find-file-match | ||
| 1135 | (obj-of-class-p table semanticdb-search-results-table)) | ||
| 1136 | (when (and table (setq match (funcall function table nil))) | ||
| 1137 | (semanticdb-find-log-activity table match) | ||
| 1138 | (when find-file-match | ||
| 1139 | (save-excursion (semanticdb-set-buffer table))) | ||
| 1140 | (push (cons table match) found)))))) | ||
| 1141 | ;; At this point, FOUND has had items pushed onto it. | ||
| 1142 | ;; This means items are being returned in REVERSE order | ||
| 1143 | ;; of the tables searched, so if you just get th CAR, then | ||
| 1144 | ;; too-bad, you may have some system-tag that has no | ||
| 1145 | ;; buffer associated with it. | ||
| 1146 | |||
| 1147 | ;; It must be reversed. | ||
| 1148 | (nreverse found))) | ||
| 1149 | |||
| 1150 | (defun semanticdb-find-tags-by-name (name &optional path find-file-match) | ||
| 1151 | "Search for all tags matching NAME on PATH. | ||
| 1152 | See `semanticdb-find-translate-path' for details on PATH. | ||
| 1153 | FIND-FILE-MATCH indicates that any time a match is found, the file | ||
| 1154 | associated with that tag should be loaded into a buffer." | ||
| 1155 | (semanticdb-find-tags-collector | ||
| 1156 | (lambda (table tags) | ||
| 1157 | (semanticdb-find-tags-by-name-method table name tags)) | ||
| 1158 | path find-file-match)) | ||
| 1159 | |||
| 1160 | (defun semanticdb-find-tags-by-name-regexp (regexp &optional path find-file-match) | ||
| 1161 | "Search for all tags matching REGEXP on PATH. | ||
| 1162 | See `semanticdb-find-translate-path' for details on PATH. | ||
| 1163 | FIND-FILE-MATCH indicates that any time a match is found, the file | ||
| 1164 | associated with that tag should be loaded into a buffer." | ||
| 1165 | (semanticdb-find-tags-collector | ||
| 1166 | (lambda (table tags) | ||
| 1167 | (semanticdb-find-tags-by-name-regexp-method table regexp tags)) | ||
| 1168 | path find-file-match)) | ||
| 1169 | |||
| 1170 | (defun semanticdb-find-tags-for-completion (prefix &optional path find-file-match) | ||
| 1171 | "Search for all tags matching PREFIX on PATH. | ||
| 1172 | See `semanticdb-find-translate-path' for details on PATH. | ||
| 1173 | FIND-FILE-MATCH indicates that any time a match is found, the file | ||
| 1174 | associated with that tag should be loaded into a buffer." | ||
| 1175 | (semanticdb-find-tags-collector | ||
| 1176 | (lambda (table tags) | ||
| 1177 | (semanticdb-find-tags-for-completion-method table prefix tags)) | ||
| 1178 | path find-file-match)) | ||
| 1179 | |||
| 1180 | (defun semanticdb-find-tags-by-class (class &optional path find-file-match) | ||
| 1181 | "Search for all tags of CLASS on PATH. | ||
| 1182 | See `semanticdb-find-translate-path' for details on PATH. | ||
| 1183 | FIND-FILE-MATCH indicates that any time a match is found, the file | ||
| 1184 | associated with that tag should be loaded into a buffer." | ||
| 1185 | (semanticdb-find-tags-collector | ||
| 1186 | (lambda (table tags) | ||
| 1187 | (semanticdb-find-tags-by-class-method table class tags)) | ||
| 1188 | path find-file-match)) | ||
| 1189 | |||
| 1190 | ;;; Deep Searches | ||
| 1191 | (defun semanticdb-deep-find-tags-by-name (name &optional path find-file-match) | ||
| 1192 | "Search for all tags matching NAME on PATH. | ||
| 1193 | Search also in all components of top level tags founds. | ||
| 1194 | See `semanticdb-find-translate-path' for details on PATH. | ||
| 1195 | FIND-FILE-MATCH indicates that any time a match is found, the file | ||
| 1196 | associated with that tag should be loaded into a buffer." | ||
| 1197 | (semanticdb-find-tags-collector | ||
| 1198 | (lambda (table tags) | ||
| 1199 | (semanticdb-deep-find-tags-by-name-method table name tags)) | ||
| 1200 | path find-file-match)) | ||
| 1201 | |||
| 1202 | (defun semanticdb-deep-find-tags-by-name-regexp (regexp &optional path find-file-match) | ||
| 1203 | "Search for all tags matching REGEXP on PATH. | ||
| 1204 | Search also in all components of top level tags founds. | ||
| 1205 | See `semanticdb-find-translate-path' for details on PATH. | ||
| 1206 | FIND-FILE-MATCH indicates that any time a match is found, the file | ||
| 1207 | associated with that tag should be loaded into a buffer." | ||
| 1208 | (semanticdb-find-tags-collector | ||
| 1209 | (lambda (table tags) | ||
| 1210 | (semanticdb-deep-find-tags-by-name-regexp-method table regexp tags)) | ||
| 1211 | path find-file-match)) | ||
| 1212 | |||
| 1213 | (defun semanticdb-deep-find-tags-for-completion (prefix &optional path find-file-match) | ||
| 1214 | "Search for all tags matching PREFIX on PATH. | ||
| 1215 | Search also in all components of top level tags founds. | ||
| 1216 | See `semanticdb-find-translate-path' for details on PATH. | ||
| 1217 | FIND-FILE-MATCH indicates that any time a match is found, the file | ||
| 1218 | associated with that tag should be loaded into a buffer." | ||
| 1219 | (semanticdb-find-tags-collector | ||
| 1220 | (lambda (table tags) | ||
| 1221 | (semanticdb-deep-find-tags-for-completion-method table prefix tags)) | ||
| 1222 | path find-file-match)) | ||
| 1223 | |||
| 1224 | ;;; Brutish Search Routines | ||
| 1225 | (defun semanticdb-brute-deep-find-tags-by-name (name &optional path find-file-match) | ||
| 1226 | "Search for all tags matching NAME on PATH. | ||
| 1227 | See `semanticdb-find-translate-path' for details on PATH. | ||
| 1228 | The argument BRUTISH will be set so that searching includes all tables | ||
| 1229 | in the current project. | ||
| 1230 | FIND-FILE-MATCH indicates that any time a matchi is found, the file | ||
| 1231 | associated wit that tag should be loaded into a buffer." | ||
| 1232 | (semanticdb-find-tags-collector | ||
| 1233 | (lambda (table tags) | ||
| 1234 | (semanticdb-deep-find-tags-by-name-method table name tags)) | ||
| 1235 | path find-file-match t)) | ||
| 1236 | |||
| 1237 | (defun semanticdb-brute-deep-find-tags-for-completion (prefix &optional path find-file-match) | ||
| 1238 | "Search for all tags matching PREFIX on PATH. | ||
| 1239 | See `semanticdb-find-translate-path' for details on PATH. | ||
| 1240 | The argument BRUTISH will be set so that searching includes all tables | ||
| 1241 | in the current project. | ||
| 1242 | FIND-FILE-MATCH indicates that any time a matchi is found, the file | ||
| 1243 | associated wit that tag should be loaded into a buffer." | ||
| 1244 | (semanticdb-find-tags-collector | ||
| 1245 | (lambda (table tags) | ||
| 1246 | (semanticdb-deep-find-tags-for-completion-method table prefix tags)) | ||
| 1247 | path find-file-match t)) | ||
| 1248 | |||
| 1249 | (defun semanticdb-brute-find-tags-by-class (class &optional path find-file-match) | ||
| 1250 | "Search for all tags of CLASS on PATH. | ||
| 1251 | See `semanticdb-find-translate-path' for details on PATH. | ||
| 1252 | The argument BRUTISH will be set so that searching includes all tables | ||
| 1253 | in the current project. | ||
| 1254 | FIND-FILE-MATCH indicates that any time a match is found, the file | ||
| 1255 | associated with that tag should be loaded into a buffer." | ||
| 1256 | (semanticdb-find-tags-collector | ||
| 1257 | (lambda (table tags) | ||
| 1258 | (semanticdb-find-tags-by-class-method table class tags)) | ||
| 1259 | path find-file-match t)) | ||
| 1260 | |||
| 1261 | ;;; Specialty Search Routines | ||
| 1262 | (defun semanticdb-find-tags-external-children-of-type | ||
| 1263 | (type &optional path find-file-match) | ||
| 1264 | "Search for all tags defined outside of TYPE w/ TYPE as a parent. | ||
| 1265 | See `semanticdb-find-translate-path' for details on PATH. | ||
| 1266 | FIND-FILE-MATCH indicates that any time a match is found, the file | ||
| 1267 | associated with that tag should be loaded into a buffer." | ||
| 1268 | (semanticdb-find-tags-collector | ||
| 1269 | (lambda (table tags) | ||
| 1270 | (semanticdb-find-tags-external-children-of-type-method table type tags)) | ||
| 1271 | path find-file-match)) | ||
| 1272 | |||
| 1273 | (defun semanticdb-find-tags-subclasses-of-type | ||
| 1274 | (type &optional path find-file-match) | ||
| 1275 | "Search for all tags of class type defined that subclass TYPE. | ||
| 1276 | See `semanticdb-find-translate-path' for details on PATH. | ||
| 1277 | FIND-FILE-MATCH indicates that any time a match is found, the file | ||
| 1278 | associated with that tag should be loaded into a buffer." | ||
| 1279 | (semanticdb-find-tags-collector | ||
| 1280 | (lambda (table tags) | ||
| 1281 | (semanticdb-find-tags-subclasses-of-type-method table type tags)) | ||
| 1282 | path find-file-match t)) | ||
| 1283 | |||
| 1284 | ;;; METHODS | ||
| 1285 | ;; | ||
| 1286 | ;; Default methods for semanticdb database and table objects. | ||
| 1287 | ;; Override these with system databases to as new types of back ends. | ||
| 1288 | |||
| 1289 | ;;; Top level Searches | ||
| 1290 | (defmethod semanticdb-find-tags-by-name-method ((table semanticdb-abstract-table) name &optional tags) | ||
| 1291 | "In TABLE, find all occurances of tags with NAME. | ||
| 1292 | Optional argument TAGS is a list of tags to search. | ||
| 1293 | Returns a table of all matching tags." | ||
| 1294 | (semantic-find-tags-by-name name (or tags (semanticdb-get-tags table)))) | ||
| 1295 | |||
| 1296 | (defmethod semanticdb-find-tags-by-name-regexp-method ((table semanticdb-abstract-table) regexp &optional tags) | ||
| 1297 | "In TABLE, find all occurances of tags matching REGEXP. | ||
| 1298 | Optional argument TAGS is a list of tags to search. | ||
| 1299 | Returns a table of all matching tags." | ||
| 1300 | (semantic-find-tags-by-name-regexp regexp (or tags (semanticdb-get-tags table)))) | ||
| 1301 | |||
| 1302 | (defmethod semanticdb-find-tags-for-completion-method ((table semanticdb-abstract-table) prefix &optional tags) | ||
| 1303 | "In TABLE, find all occurances of tags matching PREFIX. | ||
| 1304 | Optional argument TAGS is a list of tags to search. | ||
| 1305 | Returns a table of all matching tags." | ||
| 1306 | (semantic-find-tags-for-completion prefix (or tags (semanticdb-get-tags table)))) | ||
| 1307 | |||
| 1308 | (defmethod semanticdb-find-tags-by-class-method ((table semanticdb-abstract-table) class &optional tags) | ||
| 1309 | "In TABLE, find all occurances of tags of CLASS. | ||
| 1310 | Optional argument TAGS is a list of tags to search. | ||
| 1311 | Returns a table of all matching tags." | ||
| 1312 | (semantic-find-tags-by-class class (or tags (semanticdb-get-tags table)))) | ||
| 1313 | |||
| 1314 | (defmethod semanticdb-find-tags-external-children-of-type-method ((table semanticdb-abstract-table) parent &optional tags) | ||
| 1315 | "In TABLE, find all occurances of tags whose parent is the PARENT type. | ||
| 1316 | Optional argument TAGS is a list of tags to search. | ||
| 1317 | Returns a table of all matching tags." | ||
| 1318 | (semantic-find-tags-external-children-of-type parent (or tags (semanticdb-get-tags table)))) | ||
| 1319 | |||
| 1320 | (defmethod semanticdb-find-tags-subclasses-of-type-method ((table semanticdb-abstract-table) parent &optional tags) | ||
| 1321 | "In TABLE, find all occurances of tags whose parent is the PARENT type. | ||
| 1322 | Optional argument TAGS is a list of tags to search. | ||
| 1323 | Returns a table of all matching tags." | ||
| 1324 | (semantic-find-tags-subclasses-of-type parent (or tags (semanticdb-get-tags table)))) | ||
| 1325 | |||
| 1326 | ;;; Deep Searches | ||
| 1327 | (defmethod semanticdb-deep-find-tags-by-name-method ((table semanticdb-abstract-table) name &optional tags) | ||
| 1328 | "In TABLE, find all occurances of tags with NAME. | ||
| 1329 | Search in all tags in TABLE, and all components of top level tags in | ||
| 1330 | TABLE. | ||
| 1331 | Optional argument TAGS is a list of tags to search. | ||
| 1332 | Return a table of all matching tags." | ||
| 1333 | (semantic-find-tags-by-name name (semantic-flatten-tags-table (or tags (semanticdb-get-tags table))))) | ||
| 1334 | |||
| 1335 | (defmethod semanticdb-deep-find-tags-by-name-regexp-method ((table semanticdb-abstract-table) regexp &optional tags) | ||
| 1336 | "In TABLE, find all occurances of tags matching REGEXP. | ||
| 1337 | Search in all tags in TABLE, and all components of top level tags in | ||
| 1338 | TABLE. | ||
| 1339 | Optional argument TAGS is a list of tags to search. | ||
| 1340 | Return a table of all matching tags." | ||
| 1341 | (semantic-find-tags-by-name-regexp regexp (semantic-flatten-tags-table (or tags (semanticdb-get-tags table))))) | ||
| 1342 | |||
| 1343 | (defmethod semanticdb-deep-find-tags-for-completion-method ((table semanticdb-abstract-table) prefix &optional tags) | ||
| 1344 | "In TABLE, find all occurances of tags matching PREFIX. | ||
| 1345 | Search in all tags in TABLE, and all components of top level tags in | ||
| 1346 | TABLE. | ||
| 1347 | Optional argument TAGS is a list of tags to search. | ||
| 1348 | Return a table of all matching tags." | ||
| 1349 | (semantic-find-tags-for-completion prefix (semantic-flatten-tags-table (or tags (semanticdb-get-tags table))))) | ||
| 1350 | |||
| 1351 | (provide 'semantic/db-find) | ||
| 1352 | |||
| 1353 | ;;; semanticdb-find.el ends here | ||
diff --git a/lisp/cedet/semantic/db-ref.el b/lisp/cedet/semantic/db-ref.el new file mode 100644 index 00000000000..62faf9933c2 --- /dev/null +++ b/lisp/cedet/semantic/db-ref.el | |||
| @@ -0,0 +1,161 @@ | |||
| 1 | ;;; db-ref.el --- Handle cross-db file references | ||
| 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 | ;; Handle cross-database file references. | ||
| 25 | ;; | ||
| 26 | ;; Any given database may be referred to by some other database. For | ||
| 27 | ;; example, if a .cpp file has a #include in a header, then that | ||
| 28 | ;; header file should have a reference to the .cpp file that included | ||
| 29 | ;; it. | ||
| 30 | ;; | ||
| 31 | ;; This is critical for purposes where a file (such as a .cpp file) | ||
| 32 | ;; needs to have its caches flushed because of changes in the | ||
| 33 | ;; header. Changing a header may cause a referring file to be | ||
| 34 | ;; reparsed due to account for changes in defined macros, or perhaps | ||
| 35 | ;; a change to files the header includes. | ||
| 36 | |||
| 37 | |||
| 38 | ;;; Code: | ||
| 39 | (defmethod semanticdb-add-reference ((dbt semanticdb-abstract-table) | ||
| 40 | include-tag) | ||
| 41 | "Add a reference for the database table DBT based on INCLUDE-TAG. | ||
| 42 | DBT is the database table that owns the INCLUDE-TAG. The reference | ||
| 43 | will be added to the database that INCLUDE-TAG refers to." | ||
| 44 | ;; NOTE: I should add a check to make sure include-tag is in DB. | ||
| 45 | ;; but I'm too lazy. | ||
| 46 | (let* ((semanticdb-find-default-throttle | ||
| 47 | (if (featurep 'semanticdb-find) | ||
| 48 | (remq 'unloaded semanticdb-find-default-throttle) | ||
| 49 | nil)) | ||
| 50 | (refdbt (semanticdb-find-table-for-include include-tag dbt)) | ||
| 51 | ;;(fullfile (semanticdb-full-filename dbt)) | ||
| 52 | ) | ||
| 53 | (when refdbt | ||
| 54 | ;; Add our filename (full path) | ||
| 55 | ;; (object-add-to-list refdbt 'file-refs fullfile) | ||
| 56 | |||
| 57 | ;; Add our database. | ||
| 58 | (object-add-to-list refdbt 'db-refs dbt) | ||
| 59 | t))) | ||
| 60 | |||
| 61 | (defmethod semanticdb-check-references ((dbt semanticdb-abstract-table)) | ||
| 62 | "Check and cleanup references in the database DBT. | ||
| 63 | Abstract tables would be difficult to reference." | ||
| 64 | ;; Not sure how an abstract table can have references. | ||
| 65 | nil) | ||
| 66 | |||
| 67 | (defmethod semanticdb-includes-in-table ((dbt semanticdb-abstract-table)) | ||
| 68 | "Return a list of direct includes in table DBT." | ||
| 69 | (semantic-find-tags-by-class 'include (semanticdb-get-tags dbt))) | ||
| 70 | |||
| 71 | |||
| 72 | (defmethod semanticdb-check-references ((dbt semanticdb-table)) | ||
| 73 | "Check and cleanup references in the database DBT. | ||
| 74 | Any reference to a file that cannot be found, or whos file no longer | ||
| 75 | refers to DBT will be removed." | ||
| 76 | (let ((refs (oref dbt db-refs)) | ||
| 77 | (myexpr (concat "\\<" (oref dbt file))) | ||
| 78 | ) | ||
| 79 | (while refs | ||
| 80 | (let* ((ok t) | ||
| 81 | (db (car refs)) | ||
| 82 | (f (when (semanticdb-table-child-p db) | ||
| 83 | (semanticdb-full-filename db))) | ||
| 84 | ) | ||
| 85 | |||
| 86 | ;; The file was deleted | ||
| 87 | (when (and f (not (file-exists-p f))) | ||
| 88 | (setq ok nil)) | ||
| 89 | |||
| 90 | ;; The reference no longer includes the textual reference? | ||
| 91 | (let* ((refs (semanticdb-includes-in-table db)) | ||
| 92 | (inc (semantic-find-tags-by-name-regexp | ||
| 93 | myexpr refs))) | ||
| 94 | (when (not inc) | ||
| 95 | (setq ok nil))) | ||
| 96 | |||
| 97 | ;; Remove not-ok databases from the list. | ||
| 98 | (when (not ok) | ||
| 99 | (object-remove-from-list dbt 'db-refs db) | ||
| 100 | )) | ||
| 101 | (setq refs (cdr refs))))) | ||
| 102 | |||
| 103 | (defmethod semanticdb-refresh-references ((dbt semanticdb-abstract-table)) | ||
| 104 | "Refresh references to DBT in other files." | ||
| 105 | ;; alternate tables can't be edited, so can't be changed. | ||
| 106 | nil | ||
| 107 | ) | ||
| 108 | |||
| 109 | (defmethod semanticdb-refresh-references ((dbt semanticdb-table)) | ||
| 110 | "Refresh references to DBT in other files." | ||
| 111 | (let ((refs (semanticdb-includes-in-table dbt)) | ||
| 112 | ) | ||
| 113 | (while refs | ||
| 114 | (if (semanticdb-add-reference dbt (car refs)) | ||
| 115 | nil | ||
| 116 | ;; If we succeeded, then do... nothing? | ||
| 117 | nil | ||
| 118 | ) | ||
| 119 | (setq refs (cdr refs))) | ||
| 120 | )) | ||
| 121 | |||
| 122 | (defmethod semanticdb-notify-references ((dbt semanticdb-table) | ||
| 123 | method) | ||
| 124 | "Notify all references of the table DBT using method. | ||
| 125 | METHOD takes two arguments. | ||
| 126 | (METHOD TABLE-TO-NOTIFY DBT) | ||
| 127 | TABLE-TO-NOTIFY is a semanticdb-table which is being notified. | ||
| 128 | DBT, the second argument is DBT." | ||
| 129 | (mapc (lambda (R) (funcall method R dbt)) | ||
| 130 | (oref dbt db-refs))) | ||
| 131 | |||
| 132 | ;;; DEBUG | ||
| 133 | ;; | ||
| 134 | (defclass semanticdb-ref-adebug () | ||
| 135 | ((i-depend-on :initarg :i-depend-on) | ||
| 136 | (local-table :initarg :local-table) | ||
| 137 | (i-include :initarg :i-include)) | ||
| 138 | "Simple class to allow ADEBUG to show a nice list.") | ||
| 139 | |||
| 140 | (defun semanticdb-ref-test (refresh) | ||
| 141 | "Dump out the list of references for the current buffer. | ||
| 142 | If REFRESH is non-nil, cause the current table to have it's references | ||
| 143 | refreshed before dumping the result." | ||
| 144 | (interactive "p") | ||
| 145 | ;; If we need to refresh... then do so. | ||
| 146 | (when refresh | ||
| 147 | (semanticdb-refresh-references semanticdb-current-table)) | ||
| 148 | ;; Do the debug system | ||
| 149 | (let* ((tab semanticdb-current-table) | ||
| 150 | (myrefs (oref tab db-refs)) | ||
| 151 | (myinc (semanticdb-includes-in-table tab)) | ||
| 152 | (adbc (semanticdb-ref-adebug "DEBUG" | ||
| 153 | :i-depend-on myrefs | ||
| 154 | :local-table tab | ||
| 155 | :i-include myinc))) | ||
| 156 | (data-debug-new-buffer "*References ADEBUG*") | ||
| 157 | (data-debug-insert-object-slots adbc "!")) | ||
| 158 | ) | ||
| 159 | |||
| 160 | (provide 'semantic/db-ref) | ||
| 161 | ;;; semanticdb-ref.el ends here | ||
diff --git a/lisp/cedet/semantic/find.el b/lisp/cedet/semantic/find.el new file mode 100644 index 00000000000..a01b2ae2b22 --- /dev/null +++ b/lisp/cedet/semantic/find.el | |||
| @@ -0,0 +1,795 @@ | |||
| 1 | ;;; find.el --- Search routines for Semantic | ||
| 2 | |||
| 3 | ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2008, 2009 | ||
| 4 | ;;; 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 | ;; Routines for searching through lists of tags. | ||
| 27 | ;; There are several groups of tag search routines: | ||
| 28 | ;; | ||
| 29 | ;; 1) semantic-brute-find-tag-by-* | ||
| 30 | ;; These routines use brute force hierarchical search to scan | ||
| 31 | ;; through lists of tags. They include some parameters | ||
| 32 | ;; used for compatibility with the semantic 1.x search routines. | ||
| 33 | ;; | ||
| 34 | ;; 1.5) semantic-brute-find-first-tag-by-* | ||
| 35 | ;; Like 1, except seraching stops on the first match for the given | ||
| 36 | ;; information. | ||
| 37 | ;; | ||
| 38 | ;; 2) semantic-find-tag-by-* | ||
| 39 | ;; These prefered search routines attempt to scan through lists | ||
| 40 | ;; in an intelligent way based on questions asked. | ||
| 41 | ;; | ||
| 42 | ;; 3) semantic-find-*-overlay | ||
| 43 | ;; These routines use overlays to return tags based on a buffer position. | ||
| 44 | ;; | ||
| 45 | ;; 4) ... | ||
| 46 | |||
| 47 | (require 'semantic/tag) | ||
| 48 | |||
| 49 | ;;; Code: | ||
| 50 | |||
| 51 | ;;; Overlay Search Routines | ||
| 52 | ;; | ||
| 53 | ;; These routines provide fast access to tokens based on a buffer that | ||
| 54 | ;; has parsed tokens in it. Uses overlays to perform the hard work. | ||
| 55 | (defun semantic-find-tag-by-overlay (&optional positionormarker buffer) | ||
| 56 | "Find all tags covering POSITIONORMARKER by using overlays. | ||
| 57 | If POSITIONORMARKER is nil, use the current point. | ||
| 58 | Optional BUFFER is used if POSITIONORMARKER is a number, otherwise the current | ||
| 59 | buffer is used. This finds all tags covering the specified position | ||
| 60 | by checking for all overlays covering the current spot. They are then sorted | ||
| 61 | from largest to smallest via the start location." | ||
| 62 | (save-excursion | ||
| 63 | (when positionormarker | ||
| 64 | (if (markerp positionormarker) | ||
| 65 | (set-buffer (marker-buffer positionormarker)) | ||
| 66 | (if (bufferp buffer) | ||
| 67 | (set-buffer buffer)))) | ||
| 68 | (let ((ol (semantic-overlays-at (or positionormarker (point)))) | ||
| 69 | (ret nil)) | ||
| 70 | (while ol | ||
| 71 | (let ((tmp (semantic-overlay-get (car ol) 'semantic))) | ||
| 72 | (when (and tmp | ||
| 73 | ;; We don't need with-position because no tag w/out | ||
| 74 | ;; a position could exist in an overlay. | ||
| 75 | (semantic-tag-p tmp)) | ||
| 76 | (setq ret (cons tmp ret)))) | ||
| 77 | (setq ol (cdr ol))) | ||
| 78 | (sort ret (lambda (a b) (< (semantic-tag-start a) | ||
| 79 | (semantic-tag-start b))))))) | ||
| 80 | |||
| 81 | (defun semantic-find-tag-by-overlay-in-region (start end &optional buffer) | ||
| 82 | "Find all tags which exist in whole or in part between START and END. | ||
| 83 | Uses overlays to determine positin. | ||
| 84 | Optional BUFFER argument specifies the buffer to use." | ||
| 85 | (save-excursion | ||
| 86 | (if buffer (set-buffer buffer)) | ||
| 87 | (let ((ol (semantic-overlays-in start end)) | ||
| 88 | (ret nil)) | ||
| 89 | (while ol | ||
| 90 | (let ((tmp (semantic-overlay-get (car ol) 'semantic))) | ||
| 91 | (when (and tmp | ||
| 92 | ;; See above about position | ||
| 93 | (semantic-tag-p tmp)) | ||
| 94 | (setq ret (cons tmp ret)))) | ||
| 95 | (setq ol (cdr ol))) | ||
| 96 | (sort ret (lambda (a b) (< (semantic-tag-start a) | ||
| 97 | (semantic-tag-start b))))))) | ||
| 98 | |||
| 99 | (defun semantic-find-tag-by-overlay-next (&optional start buffer) | ||
| 100 | "Find the next tag after START in BUFFER. | ||
| 101 | If START is in an overlay, find the tag which starts next, | ||
| 102 | not the current tag." | ||
| 103 | (save-excursion | ||
| 104 | (if buffer (set-buffer buffer)) | ||
| 105 | (if (not start) (setq start (point))) | ||
| 106 | (let ((os start) (ol nil)) | ||
| 107 | (while (and os (< os (point-max)) (not ol)) | ||
| 108 | (setq os (semantic-overlay-next-change os)) | ||
| 109 | (when os | ||
| 110 | ;; Get overlays at position | ||
| 111 | (setq ol (semantic-overlays-at os)) | ||
| 112 | ;; find the overlay that belongs to semantic | ||
| 113 | ;; and starts at the found position. | ||
| 114 | (while (and ol (listp ol)) | ||
| 115 | (if (and (semantic-overlay-get (car ol) 'semantic) | ||
| 116 | (semantic-tag-p | ||
| 117 | (semantic-overlay-get (car ol) 'semantic)) | ||
| 118 | (= (semantic-overlay-start (car ol)) os)) | ||
| 119 | (setq ol (car ol))) | ||
| 120 | (when (listp ol) (setq ol (cdr ol)))))) | ||
| 121 | ;; convert ol to a tag | ||
| 122 | (when (and ol (semantic-tag-p (semantic-overlay-get ol 'semantic))) | ||
| 123 | (semantic-overlay-get ol 'semantic))))) | ||
| 124 | |||
| 125 | (defun semantic-find-tag-by-overlay-prev (&optional start buffer) | ||
| 126 | "Find the next tag before START in BUFFER. | ||
| 127 | If START is in an overlay, find the tag which starts next, | ||
| 128 | not the current tag." | ||
| 129 | (save-excursion | ||
| 130 | (if buffer (set-buffer buffer)) | ||
| 131 | (if (not start) (setq start (point))) | ||
| 132 | (let ((os start) (ol nil)) | ||
| 133 | (while (and os (> os (point-min)) (not ol)) | ||
| 134 | (setq os (semantic-overlay-previous-change os)) | ||
| 135 | (when os | ||
| 136 | ;; Get overlays at position | ||
| 137 | (setq ol (semantic-overlays-at (1- os))) | ||
| 138 | ;; find the overlay that belongs to semantic | ||
| 139 | ;; and ENDS at the found position. | ||
| 140 | ;; | ||
| 141 | ;; Use end because we are going backward. | ||
| 142 | (while (and ol (listp ol)) | ||
| 143 | (if (and (semantic-overlay-get (car ol) 'semantic) | ||
| 144 | (semantic-tag-p | ||
| 145 | (semantic-overlay-get (car ol) 'semantic)) | ||
| 146 | (= (semantic-overlay-end (car ol)) os)) | ||
| 147 | (setq ol (car ol))) | ||
| 148 | (when (listp ol) (setq ol (cdr ol)))))) | ||
| 149 | ;; convert ol to a tag | ||
| 150 | (when (and ol | ||
| 151 | (semantic-tag-p (semantic-overlay-get ol 'semantic))) | ||
| 152 | (semantic-overlay-get ol 'semantic))))) | ||
| 153 | |||
| 154 | (defun semantic-find-tag-parent-by-overlay (tag) | ||
| 155 | "Find the parent of TAG by overlays. | ||
| 156 | Overlays are a fast way of finding this information for active buffers." | ||
| 157 | (let ((tag (nreverse (semantic-find-tag-by-overlay | ||
| 158 | (semantic-tag-start tag))))) | ||
| 159 | ;; This is a lot like `semantic-current-tag-parent', but | ||
| 160 | ;; it uses a position to do it's work. Assumes two tags don't share | ||
| 161 | ;; the same start unless they are siblings. | ||
| 162 | (car (cdr tag)))) | ||
| 163 | |||
| 164 | (defun semantic-current-tag () | ||
| 165 | "Return the current tag in the current buffer. | ||
| 166 | If there are more than one in the same location, return the | ||
| 167 | smallest tag. Return nil if there is no tag here." | ||
| 168 | (car (nreverse (semantic-find-tag-by-overlay)))) | ||
| 169 | |||
| 170 | (defun semantic-current-tag-parent () | ||
| 171 | "Return the current tags parent in the current buffer. | ||
| 172 | A tag's parent would be a containing structure, such as a type | ||
| 173 | containing a field. Return nil if there is no parent." | ||
| 174 | (car (cdr (nreverse (semantic-find-tag-by-overlay))))) | ||
| 175 | |||
| 176 | (defun semantic-current-tag-of-class (class) | ||
| 177 | "Return the current (smallest) tags of CLASS in the current buffer. | ||
| 178 | If the smallest tag is not of type CLASS, keep going upwards until one | ||
| 179 | is found. | ||
| 180 | Uses `semantic-tag-class' for classification." | ||
| 181 | (let ((tags (nreverse (semantic-find-tag-by-overlay)))) | ||
| 182 | (while (and tags | ||
| 183 | (not (eq (semantic-tag-class (car tags)) class))) | ||
| 184 | (setq tags (cdr tags))) | ||
| 185 | (car tags))) | ||
| 186 | |||
| 187 | ;;; Search Routines | ||
| 188 | ;; | ||
| 189 | ;; These are routines that search a single tags table. | ||
| 190 | ;; | ||
| 191 | ;; The original API (see COMPATIBILITY section below) in semantic 1.4 | ||
| 192 | ;; had these usage statistics: | ||
| 193 | ;; | ||
| 194 | ;; semantic-find-nonterminal-by-name 17 | ||
| 195 | ;; semantic-find-nonterminal-by-name-regexp 8 - Most doing completion | ||
| 196 | ;; semantic-find-nonterminal-by-position 13 | ||
| 197 | ;; semantic-find-nonterminal-by-token 21 | ||
| 198 | ;; semantic-find-nonterminal-by-type 2 | ||
| 199 | ;; semantic-find-nonterminal-standard 1 | ||
| 200 | ;; | ||
| 201 | ;; semantic-find-nonterminal-by-function (not in other searches) 1 | ||
| 202 | ;; | ||
| 203 | ;; New API: As above w/out `search-parts' or `search-includes' arguments. | ||
| 204 | ;; Extra fcn: Specific to completion which is what -name-regexp is | ||
| 205 | ;; mostly used for | ||
| 206 | ;; | ||
| 207 | ;; As for the sarguments "search-parts" and "search-includes" here | ||
| 208 | ;; are stats: | ||
| 209 | ;; | ||
| 210 | ;; search-parts: 4 - charting x2, find-doc, senator (sans db) | ||
| 211 | ;; | ||
| 212 | ;; Implement command to flatten a tag table. Call new API Fcn w/ | ||
| 213 | ;; flattened table for same results. | ||
| 214 | ;; | ||
| 215 | ;; search-include: 2 - analyze x2 (sans db) | ||
| 216 | ;; | ||
| 217 | ;; Not used effectively. Not to be re-implemented here. | ||
| 218 | |||
| 219 | (defsubst semantic--find-tags-by-function (predicate &optional table) | ||
| 220 | "Find tags for which PREDICATE is non-nil in TABLE. | ||
| 221 | PREDICATE is a lambda expression which accepts on TAG. | ||
| 222 | TABLE is a semantic tags table. See `semantic-something-to-tag-table'." | ||
| 223 | (let ((tags (semantic-something-to-tag-table table)) | ||
| 224 | (result nil)) | ||
| 225 | ; (mapc (lambda (tag) (and (funcall predicate tag) | ||
| 226 | ; (setq result (cons tag result)))) | ||
| 227 | ; tags) | ||
| 228 | ;; A while loop is actually faster. Who knew | ||
| 229 | (while tags | ||
| 230 | (and (funcall predicate (car tags)) | ||
| 231 | (setq result (cons (car tags) result))) | ||
| 232 | (setq tags (cdr tags))) | ||
| 233 | (nreverse result))) | ||
| 234 | |||
| 235 | ;; I can shave off some time by removing the funcall (see above) | ||
| 236 | ;; and having the question be inlined in the while loop. | ||
| 237 | ;; Strangely turning the upper level fcns into macros had a larger | ||
| 238 | ;; impact. | ||
| 239 | (defmacro semantic--find-tags-by-macro (form &optional table) | ||
| 240 | "Find tags for which FORM is non-nil in TABLE. | ||
| 241 | TABLE is a semantic tags table. See `semantic-something-to-tag-table'." | ||
| 242 | `(let ((tags (semantic-something-to-tag-table ,table)) | ||
| 243 | (result nil)) | ||
| 244 | (while tags | ||
| 245 | (and ,form | ||
| 246 | (setq result (cons (car tags) result))) | ||
| 247 | (setq tags (cdr tags))) | ||
| 248 | (nreverse result))) | ||
| 249 | |||
| 250 | ;;; Top level Searches | ||
| 251 | ;; | ||
| 252 | (defsubst semantic-find-first-tag-by-name (name &optional table) | ||
| 253 | "Find the first tag with NAME in TABLE. | ||
| 254 | NAME is a string. | ||
| 255 | TABLE is a semantic tags table. See `semantic-something-to-tag-table'. | ||
| 256 | This routine uses `assoc' to quickly find the first matching entry." | ||
| 257 | (funcall (if semantic-case-fold 'assoc-ignore-case 'assoc) | ||
| 258 | name (semantic-something-to-tag-table table))) | ||
| 259 | |||
| 260 | (defmacro semantic-find-tags-by-name (name &optional table) | ||
| 261 | "Find all tags with NAME in TABLE. | ||
| 262 | NAME is a string. | ||
| 263 | TABLE is a tag table. See `semantic-something-to-tag-table'." | ||
| 264 | `(let ((case-fold-search semantic-case-fold)) | ||
| 265 | (semantic--find-tags-by-macro | ||
| 266 | (string= ,name (semantic-tag-name (car tags))) | ||
| 267 | ,table))) | ||
| 268 | |||
| 269 | (defmacro semantic-find-tags-for-completion (prefix &optional table) | ||
| 270 | "Find all tags whos name begins with PREFIX in TABLE. | ||
| 271 | PREFIX is a string. | ||
| 272 | TABLE is a tag table. See `semantic-something-to-tag-table'. | ||
| 273 | While it would be nice to use `try-completion' or `all-completions', | ||
| 274 | those functions do not return the tags, only a string. | ||
| 275 | Uses `compare-strings' for fast comparison." | ||
| 276 | `(let ((l (length ,prefix))) | ||
| 277 | (semantic--find-tags-by-macro | ||
| 278 | (eq (compare-strings ,prefix 0 nil | ||
| 279 | (semantic-tag-name (car tags)) 0 l | ||
| 280 | semantic-case-fold) | ||
| 281 | t) | ||
| 282 | ,table))) | ||
| 283 | |||
| 284 | (defmacro semantic-find-tags-by-name-regexp (regexp &optional table) | ||
| 285 | "Find all tags with name matching REGEXP in TABLE. | ||
| 286 | REGEXP is a string containing a regular expression, | ||
| 287 | TABLE is a tag table. See `semantic-something-to-tag-table'. | ||
| 288 | Consider using `semantic-find-tags-for-completion' if you are | ||
| 289 | attempting to do completions." | ||
| 290 | `(let ((case-fold-search semantic-case-fold)) | ||
| 291 | (semantic--find-tags-by-macro | ||
| 292 | (string-match ,regexp (semantic-tag-name (car tags))) | ||
| 293 | ,table))) | ||
| 294 | |||
| 295 | (defmacro semantic-find-tags-by-class (class &optional table) | ||
| 296 | "Find all tags of class CLASS in TABLE. | ||
| 297 | CLASS is a symbol representing the class of the token, such as | ||
| 298 | 'variable, of 'function.. | ||
| 299 | TABLE is a tag table. See `semantic-something-to-tag-table'." | ||
| 300 | `(semantic--find-tags-by-macro | ||
| 301 | (eq ,class (semantic-tag-class (car tags))) | ||
| 302 | ,table)) | ||
| 303 | |||
| 304 | (defmacro semantic-find-tags-by-type (type &optional table) | ||
| 305 | "Find all tags of with a type TYPE in TABLE. | ||
| 306 | TYPE is a string or tag representing a data type as defined in the | ||
| 307 | language the tags were parsed from, such as \"int\", or perhaps | ||
| 308 | a tag whose name is that of a struct or class. | ||
| 309 | TABLE is a tag table. See `semantic-something-to-tag-table'." | ||
| 310 | `(semantic--find-tags-by-macro | ||
| 311 | (semantic-tag-of-type-p (car tags) ,type) | ||
| 312 | ,table)) | ||
| 313 | |||
| 314 | (defmacro semantic-find-tags-of-compound-type (&optional table) | ||
| 315 | "Find all tags which are a compound type in TABLE. | ||
| 316 | Compound types are structures, or other data type which | ||
| 317 | is not of a primitive nature, such as int or double. | ||
| 318 | Used in completion." | ||
| 319 | `(semantic--find-tags-by-macro | ||
| 320 | (semantic-tag-type-compound-p (car tags)) | ||
| 321 | ,table)) | ||
| 322 | |||
| 323 | (define-overloadable-function semantic-find-tags-by-scope-protection (scopeprotection parent &optional table) | ||
| 324 | "Find all tags accessable by SCOPEPROTECTION. | ||
| 325 | SCOPEPROTECTION is a symbol which can be returned by the method | ||
| 326 | `semantic-tag-protection'. A hard-coded order is used to determine a match. | ||
| 327 | PARENT is a tag representing the PARENT slot needed for | ||
| 328 | `semantic-tag-protection'. | ||
| 329 | TABLE is a list of tags (a subset of PARENT members) to scan. If TABLE is nil, | ||
| 330 | the type members of PARENT are used. | ||
| 331 | See `semantic-tag-protected-p' for details on which tags are returned." | ||
| 332 | (if (not (eq (semantic-tag-class parent) 'type)) | ||
| 333 | (signal 'wrong-type-argument '(semantic-find-tags-by-scope-protection | ||
| 334 | parent | ||
| 335 | semantic-tag-class type)) | ||
| 336 | (:override))) | ||
| 337 | |||
| 338 | (defun semantic-find-tags-by-scope-protection-default | ||
| 339 | (scopeprotection parent &optional table) | ||
| 340 | "Find all tags accessable by SCOPEPROTECTION. | ||
| 341 | SCOPEPROTECTION is a symbol which can be returned by the method | ||
| 342 | `semantic-tag-protection'. A hard-coded order is used to determine a match. | ||
| 343 | PARENT is a tag representing the PARENT slot needed for | ||
| 344 | `semantic-tag-protection'. | ||
| 345 | TABLE is a list of tags (a subset of PARENT members) to scan. If TABLE is nil, | ||
| 346 | the type members of PARENT are used. | ||
| 347 | See `semantic-tag-protected-p' for details on which tags are returned." | ||
| 348 | (if (not table) (setq table (semantic-tag-type-members parent))) | ||
| 349 | (if (null scopeprotection) | ||
| 350 | table | ||
| 351 | (semantic--find-tags-by-macro | ||
| 352 | (not (semantic-tag-protected-p (car tags) scopeprotection parent)) | ||
| 353 | table))) | ||
| 354 | |||
| 355 | (defsubst semantic-find-tags-included (&optional table) | ||
| 356 | "Find all tags in TABLE that are of the 'include class. | ||
| 357 | TABLE is a tag table. See `semantic-something-to-tag-table'." | ||
| 358 | (semantic-find-tags-by-class 'include table)) | ||
| 359 | |||
| 360 | ;;; Deep Searches | ||
| 361 | |||
| 362 | (defmacro semantic-deep-find-tags-by-name (name &optional table) | ||
| 363 | "Find all tags with NAME in TABLE. | ||
| 364 | Search in top level tags, and their components, in TABLE. | ||
| 365 | NAME is a string. | ||
| 366 | TABLE is a tag table. See `semantic-flatten-tags-table'. | ||
| 367 | See also `semantic-find-tags-by-name'." | ||
| 368 | `(semantic-find-tags-by-name | ||
| 369 | ,name (semantic-flatten-tags-table ,table))) | ||
| 370 | |||
| 371 | (defmacro semantic-deep-find-tags-for-completion (prefix &optional table) | ||
| 372 | "Find all tags whos name begins with PREFIX in TABLE. | ||
| 373 | Search in top level tags, and their components, in TABLE. | ||
| 374 | TABLE is a tag table. See `semantic-flatten-tags-table'. | ||
| 375 | See also `semantic-find-tags-for-completion'." | ||
| 376 | `(semantic-find-tags-for-completion | ||
| 377 | ,prefix (semantic-flatten-tags-table ,table))) | ||
| 378 | |||
| 379 | (defmacro semantic-deep-find-tags-by-name-regexp (regexp &optional table) | ||
| 380 | "Find all tags with name matching REGEXP in TABLE. | ||
| 381 | Search in top level tags, and their components, in TABLE. | ||
| 382 | REGEXP is a string containing a regular expression, | ||
| 383 | TABLE is a tag table. See `semantic-flatten-tags-table'. | ||
| 384 | See also `semantic-find-tags-by-name-regexp'. | ||
| 385 | Consider using `semantic-deep-find-tags-for-completion' if you are | ||
| 386 | attempting to do completions." | ||
| 387 | `(semantic-find-tags-by-name-regexp | ||
| 388 | ,regexp (semantic-flatten-tags-table ,table))) | ||
| 389 | |||
| 390 | ;;; Specialty Searches | ||
| 391 | ;; | ||
| 392 | (defun semantic-find-tags-external-children-of-type (type &optional table) | ||
| 393 | "Find all tags in whose parent is TYPE in TABLE. | ||
| 394 | These tags are defined outside the scope of the original TYPE declaration. | ||
| 395 | TABLE is a tag table. See `semantic-something-to-tag-table'." | ||
| 396 | (semantic--find-tags-by-macro | ||
| 397 | (equal (semantic-tag-external-member-parent (car tags)) | ||
| 398 | type) | ||
| 399 | table)) | ||
| 400 | |||
| 401 | (defun semantic-find-tags-subclasses-of-type (type &optional table) | ||
| 402 | "Find all tags of class type in whose parent is TYPE in TABLE. | ||
| 403 | These tags are defined outside the scope of the original TYPE declaration. | ||
| 404 | TABLE is a tag table. See `semantic-something-to-tag-table'." | ||
| 405 | (semantic--find-tags-by-macro | ||
| 406 | (and (eq (semantic-tag-class (car tags)) 'type) | ||
| 407 | (or (member type (semantic-tag-type-superclasses (car tags))) | ||
| 408 | (member type (semantic-tag-type-interfaces (car tags))))) | ||
| 409 | table)) | ||
| 410 | |||
| 411 | ;; | ||
| 412 | ;; ************************** Compatibility *************************** | ||
| 413 | ;; | ||
| 414 | |||
| 415 | ;;; Old Style Brute Force Search Routines | ||
| 416 | ;; | ||
| 417 | ;; These functions will search through tags lists explicity for | ||
| 418 | ;; desired information. | ||
| 419 | |||
| 420 | ;; The -by-name nonterminal search can use the built in fcn | ||
| 421 | ;; `assoc', which is faster than looping ourselves, so we will | ||
| 422 | ;; not use `semantic-brute-find-tag-by-function' to do this, | ||
| 423 | ;; instead erroring on the side of speed. | ||
| 424 | |||
| 425 | (defun semantic-brute-find-first-tag-by-name | ||
| 426 | (name streamorbuffer &optional search-parts search-include) | ||
| 427 | "Find a tag NAME within STREAMORBUFFER. NAME is a string. | ||
| 428 | If SEARCH-PARTS is non-nil, search children of tags. | ||
| 429 | If SEARCH-INCLUDE was never implemented. | ||
| 430 | |||
| 431 | Use `semantic-find-first-tag-by-name' instead." | ||
| 432 | (let* ((stream (semantic-something-to-tag-table streamorbuffer)) | ||
| 433 | (assoc-fun (if semantic-case-fold | ||
| 434 | #'assoc-ignore-case | ||
| 435 | #'assoc)) | ||
| 436 | (m (funcall assoc-fun name stream))) | ||
| 437 | (if m | ||
| 438 | m | ||
| 439 | (let ((toklst stream) | ||
| 440 | (children nil)) | ||
| 441 | (while (and (not m) toklst) | ||
| 442 | (if search-parts | ||
| 443 | (progn | ||
| 444 | (setq children (semantic-tag-components-with-overlays | ||
| 445 | (car toklst))) | ||
| 446 | (if children | ||
| 447 | (setq m (semantic-brute-find-first-tag-by-name | ||
| 448 | name children search-parts search-include))))) | ||
| 449 | (setq toklst (cdr toklst))) | ||
| 450 | (if (not m) | ||
| 451 | ;; Go to dependencies, and search there. | ||
| 452 | nil) | ||
| 453 | m)))) | ||
| 454 | |||
| 455 | (defmacro semantic-brute-find-tag-by-class | ||
| 456 | (class streamorbuffer &optional search-parts search-includes) | ||
| 457 | "Find all tags with a class CLASS within STREAMORBUFFER. | ||
| 458 | CLASS is a symbol representing the class of the tags to find. | ||
| 459 | See `semantic-tag-class'. | ||
| 460 | Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to | ||
| 461 | `semantic-brute-find-tag-by-function'. | ||
| 462 | |||
| 463 | Use `semantic-find-tag-by-class' instead." | ||
| 464 | `(semantic-brute-find-tag-by-function | ||
| 465 | (lambda (tag) (eq ,class (semantic-tag-class tag))) | ||
| 466 | ,streamorbuffer ,search-parts ,search-includes)) | ||
| 467 | |||
| 468 | (defmacro semantic-brute-find-tag-standard | ||
| 469 | (streamorbuffer &optional search-parts search-includes) | ||
| 470 | "Find all tags in STREAMORBUFFER which define simple class types. | ||
| 471 | See `semantic-tag-class'. | ||
| 472 | Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to | ||
| 473 | `semantic-brute-find-tag-by-function'." | ||
| 474 | `(semantic-brute-find-tag-by-function | ||
| 475 | (lambda (tag) (member (semantic-tag-class tag) | ||
| 476 | '(function variable type))) | ||
| 477 | ,streamorbuffer ,search-parts ,search-includes)) | ||
| 478 | |||
| 479 | (defun semantic-brute-find-tag-by-type | ||
| 480 | (type streamorbuffer &optional search-parts search-includes) | ||
| 481 | "Find all tags with type TYPE within STREAMORBUFFER. | ||
| 482 | TYPE is a string which is the name of the type of the tags returned. | ||
| 483 | See `semantic-tag-type'. | ||
| 484 | Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to | ||
| 485 | `semantic-brute-find-tag-by-function'." | ||
| 486 | (semantic-brute-find-tag-by-function | ||
| 487 | (lambda (tag) | ||
| 488 | (let ((ts (semantic-tag-type tag))) | ||
| 489 | (if (and (listp ts) | ||
| 490 | (or (= (length ts) 1) | ||
| 491 | (eq (semantic-tag-class ts) 'type))) | ||
| 492 | (setq ts (semantic-tag-name ts))) | ||
| 493 | (equal type ts))) | ||
| 494 | streamorbuffer search-parts search-includes)) | ||
| 495 | |||
| 496 | (defun semantic-brute-find-tag-by-type-regexp | ||
| 497 | (regexp streamorbuffer &optional search-parts search-includes) | ||
| 498 | "Find all tags with type matching REGEXP within STREAMORBUFFER. | ||
| 499 | REGEXP is a regular expression which matches the name of the type of the | ||
| 500 | tags returned. See `semantic-tag-type'. | ||
| 501 | Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to | ||
| 502 | `semantic-brute-find-tag-by-function'." | ||
| 503 | (semantic-brute-find-tag-by-function | ||
| 504 | (lambda (tag) | ||
| 505 | (let ((ts (semantic-tag-type tag))) | ||
| 506 | (if (listp ts) | ||
| 507 | (setq ts | ||
| 508 | (if (eq (semantic-tag-class ts) 'type) | ||
| 509 | (semantic-tag-name ts) | ||
| 510 | (car ts)))) | ||
| 511 | (and ts (string-match regexp ts)))) | ||
| 512 | streamorbuffer search-parts search-includes)) | ||
| 513 | |||
| 514 | (defun semantic-brute-find-tag-by-name-regexp | ||
| 515 | (regex streamorbuffer &optional search-parts search-includes) | ||
| 516 | "Find all tags whose name match REGEX in STREAMORBUFFER. | ||
| 517 | Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to | ||
| 518 | `semantic-brute-find-tag-by-function'." | ||
| 519 | (semantic-brute-find-tag-by-function | ||
| 520 | (lambda (tag) (string-match regex (semantic-tag-name tag))) | ||
| 521 | streamorbuffer search-parts search-includes) | ||
| 522 | ) | ||
| 523 | |||
| 524 | (defun semantic-brute-find-tag-by-property | ||
| 525 | (property value streamorbuffer &optional search-parts search-includes) | ||
| 526 | "Find all tags with PROPERTY equal to VALUE in STREAMORBUFFER. | ||
| 527 | Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to | ||
| 528 | `semantic-brute-find-tag-by-function'." | ||
| 529 | (semantic-brute-find-tag-by-function | ||
| 530 | (lambda (tag) (equal (semantic--tag-get-property tag property) value)) | ||
| 531 | streamorbuffer search-parts search-includes) | ||
| 532 | ) | ||
| 533 | |||
| 534 | (defun semantic-brute-find-tag-by-attribute | ||
| 535 | (attr streamorbuffer &optional search-parts search-includes) | ||
| 536 | "Find all tags with a given ATTR in STREAMORBUFFER. | ||
| 537 | ATTR is a symbol key into the attributes list. | ||
| 538 | Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to | ||
| 539 | `semantic-brute-find-tag-by-function'." | ||
| 540 | (semantic-brute-find-tag-by-function | ||
| 541 | (lambda (tag) (semantic-tag-get-attribute tag attr)) | ||
| 542 | streamorbuffer search-parts search-includes) | ||
| 543 | ) | ||
| 544 | |||
| 545 | (defun semantic-brute-find-tag-by-attribute-value | ||
| 546 | (attr value streamorbuffer &optional search-parts search-includes) | ||
| 547 | "Find all tags with a given ATTR equal to VALUE in STREAMORBUFFER. | ||
| 548 | ATTR is a symbol key into the attributes list. | ||
| 549 | VALUE is the value that ATTR should match. | ||
| 550 | Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to | ||
| 551 | `semantic-brute-find-tag-by-function'." | ||
| 552 | (semantic-brute-find-tag-by-function | ||
| 553 | (lambda (tag) (equal (semantic-tag-get-attribute tag attr) value)) | ||
| 554 | streamorbuffer search-parts search-includes) | ||
| 555 | ) | ||
| 556 | |||
| 557 | (defun semantic-brute-find-tag-by-function | ||
| 558 | (function streamorbuffer &optional search-parts search-includes) | ||
| 559 | "Find all tags for which FUNCTION's value is non-nil within STREAMORBUFFER. | ||
| 560 | FUNCTION must return non-nil if an element of STREAM will be included | ||
| 561 | in the new list. | ||
| 562 | |||
| 563 | If optional argument SEARCH-PARTS is non-nil, all sub-parts of tags | ||
| 564 | are searched. The overloadable function `semantic-tag-componenets' is | ||
| 565 | used for the searching child lists. If SEARCH-PARTS is the symbol | ||
| 566 | 'positiononly, then only children that have positional information are | ||
| 567 | searched. | ||
| 568 | |||
| 569 | If SEARCH-INCLUDES has not been implemented. | ||
| 570 | This parameter hasn't be active for a while and is obsolete." | ||
| 571 | (let ((stream (semantic-something-to-tag-table streamorbuffer)) | ||
| 572 | (sl nil) ;list of tag children | ||
| 573 | (nl nil) ;new list | ||
| 574 | (case-fold-search semantic-case-fold)) | ||
| 575 | (dolist (tag stream) | ||
| 576 | (if (not (semantic-tag-p tag)) | ||
| 577 | ;; `semantic-tag-components-with-overlays' can return invalid | ||
| 578 | ;; tags if search-parts is not equal to 'positiononly | ||
| 579 | nil ;; Ignore them! | ||
| 580 | (if (funcall function tag) | ||
| 581 | (setq nl (cons tag nl))) | ||
| 582 | (and search-parts | ||
| 583 | (setq sl (if (eq search-parts 'positiononly) | ||
| 584 | (semantic-tag-components-with-overlays tag) | ||
| 585 | (semantic-tag-components tag)) | ||
| 586 | ) | ||
| 587 | (setq nl (nconc nl | ||
| 588 | (semantic-brute-find-tag-by-function | ||
| 589 | function sl | ||
| 590 | search-parts)))))) | ||
| 591 | (setq nl (nreverse nl)) | ||
| 592 | nl)) | ||
| 593 | |||
| 594 | (defun semantic-brute-find-first-tag-by-function | ||
| 595 | (function streamorbuffer &optional search-parts search-includes) | ||
| 596 | "Find the first tag which FUNCTION match within STREAMORBUFFER. | ||
| 597 | FUNCTION must return non-nil if an element of STREAM will be included | ||
| 598 | in the new list. | ||
| 599 | |||
| 600 | The following parameters were never implemented. | ||
| 601 | |||
| 602 | If optional argument SEARCH-PARTS, all sub-parts of tags are searched. | ||
| 603 | The overloadable function `semantic-tag-components' is used for | ||
| 604 | searching. | ||
| 605 | If SEARCH-INCLUDES is non-nil, then all include files are also | ||
| 606 | searched for matches." | ||
| 607 | (let ((stream (semantic-something-to-tag-table streamorbuffer)) | ||
| 608 | (found nil) | ||
| 609 | (case-fold-search semantic-case-fold)) | ||
| 610 | (while (and (not found) stream) | ||
| 611 | (if (funcall function (car stream)) | ||
| 612 | (setq found (car stream))) | ||
| 613 | (setq stream (cdr stream))) | ||
| 614 | found)) | ||
| 615 | |||
| 616 | |||
| 617 | ;;; Old Positional Searches | ||
| 618 | ;; | ||
| 619 | ;; Are these useful anymore? | ||
| 620 | ;; | ||
| 621 | (defun semantic-brute-find-tag-by-position (position streamorbuffer | ||
| 622 | &optional nomedian) | ||
| 623 | "Find a tag covering POSITION within STREAMORBUFFER. | ||
| 624 | POSITION is a number, or marker. If NOMEDIAN is non-nil, don't do | ||
| 625 | the median calculation, and return nil." | ||
| 626 | (save-excursion | ||
| 627 | (if (markerp position) (set-buffer (marker-buffer position))) | ||
| 628 | (let* ((stream (if (bufferp streamorbuffer) | ||
| 629 | (save-excursion | ||
| 630 | (set-buffer streamorbuffer) | ||
| 631 | (semantic-fetch-tags)) | ||
| 632 | streamorbuffer)) | ||
| 633 | (prev nil) | ||
| 634 | (found nil)) | ||
| 635 | (while (and stream (not found)) | ||
| 636 | ;; perfect fit | ||
| 637 | (if (and (>= position (semantic-tag-start (car stream))) | ||
| 638 | (<= position (semantic-tag-end (car stream)))) | ||
| 639 | (setq found (car stream)) | ||
| 640 | ;; Median between to objects. | ||
| 641 | (if (and prev (not nomedian) | ||
| 642 | (>= position (semantic-tag-end prev)) | ||
| 643 | (<= position (semantic-tag-start (car stream)))) | ||
| 644 | (let ((median (/ (+ (semantic-tag-end prev) | ||
| 645 | (semantic-tag-start (car stream))) | ||
| 646 | 2))) | ||
| 647 | (setq found | ||
| 648 | (if (> position median) | ||
| 649 | (car stream) | ||
| 650 | prev))))) | ||
| 651 | ;; Next!!! | ||
| 652 | (setq prev (car stream) | ||
| 653 | stream (cdr stream))) | ||
| 654 | found))) | ||
| 655 | |||
| 656 | (defun semantic-brute-find-innermost-tag-by-position | ||
| 657 | (position streamorbuffer &optional nomedian) | ||
| 658 | "Find a list of tags covering POSITION within STREAMORBUFFER. | ||
| 659 | POSITION is a number, or marker. If NOMEDIAN is non-nil, don't do | ||
| 660 | the median calculation, and return nil. | ||
| 661 | This function will find the topmost item, and recurse until no more | ||
| 662 | details are available of findable." | ||
| 663 | (let* ((returnme nil) | ||
| 664 | (current (semantic-brute-find-tag-by-position | ||
| 665 | position streamorbuffer nomedian)) | ||
| 666 | (nextstream (and current | ||
| 667 | (if (eq (semantic-tag-class current) 'type) | ||
| 668 | (semantic-tag-type-members current) | ||
| 669 | nil)))) | ||
| 670 | (while nextstream | ||
| 671 | (setq returnme (cons current returnme)) | ||
| 672 | (setq current (semantic-brute-find-tag-by-position | ||
| 673 | position nextstream nomedian)) | ||
| 674 | (setq nextstream (and current | ||
| 675 | ;; NOTE TO SELF: | ||
| 676 | ;; Looking at this after several years away, | ||
| 677 | ;; what does this do??? | ||
| 678 | (if (eq (semantic-tag-class current) 'token) | ||
| 679 | (semantic-tag-type-members current) | ||
| 680 | nil)))) | ||
| 681 | (nreverse (cons current returnme)))) | ||
| 682 | |||
| 683 | ;;; Compatibility Aliases | ||
| 684 | (semantic-alias-obsolete 'semantic-find-nonterminal-by-overlay | ||
| 685 | 'semantic-find-tag-by-overlay) | ||
| 686 | |||
| 687 | (semantic-alias-obsolete 'semantic-find-nonterminal-by-overlay-in-region | ||
| 688 | 'semantic-find-tag-by-overlay-in-region) | ||
| 689 | |||
| 690 | (semantic-alias-obsolete 'semantic-find-nonterminal-by-overlay-next | ||
| 691 | 'semantic-find-tag-by-overlay-next) | ||
| 692 | |||
| 693 | (semantic-alias-obsolete 'semantic-find-nonterminal-by-overlay-prev | ||
| 694 | 'semantic-find-tag-by-overlay-prev) | ||
| 695 | |||
| 696 | (semantic-alias-obsolete 'semantic-find-nonterminal-parent-by-overlay | ||
| 697 | 'semantic-find-tag-parent-by-overlay) | ||
| 698 | |||
| 699 | (semantic-alias-obsolete 'semantic-current-nonterminal | ||
| 700 | 'semantic-current-tag) | ||
| 701 | |||
| 702 | (semantic-alias-obsolete 'semantic-current-nonterminal-parent | ||
| 703 | 'semantic-current-tag-parent) | ||
| 704 | |||
| 705 | (semantic-alias-obsolete 'semantic-current-nonterminal-of-type | ||
| 706 | 'semantic-current-tag-of-class) | ||
| 707 | |||
| 708 | (semantic-alias-obsolete 'semantic-find-nonterminal-by-name | ||
| 709 | 'semantic-brute-find-first-tag-by-name) | ||
| 710 | |||
| 711 | (semantic-alias-obsolete 'semantic-find-nonterminal-by-token | ||
| 712 | 'semantic-brute-find-tag-by-class) | ||
| 713 | |||
| 714 | (semantic-alias-obsolete 'semantic-find-nonterminal-standard | ||
| 715 | 'semantic-brute-find-tag-standard) | ||
| 716 | |||
| 717 | (semantic-alias-obsolete 'semantic-find-nonterminal-by-type | ||
| 718 | 'semantic-brute-find-tag-by-type) | ||
| 719 | |||
| 720 | (semantic-alias-obsolete 'semantic-find-nonterminal-by-type-regexp | ||
| 721 | 'semantic-brute-find-tag-by-type-regexp) | ||
| 722 | |||
| 723 | (semantic-alias-obsolete 'semantic-find-nonterminal-by-name-regexp | ||
| 724 | 'semantic-brute-find-tag-by-name-regexp) | ||
| 725 | |||
| 726 | (semantic-alias-obsolete 'semantic-find-nonterminal-by-property | ||
| 727 | 'semantic-brute-find-tag-by-property) | ||
| 728 | |||
| 729 | (semantic-alias-obsolete 'semantic-find-nonterminal-by-extra-spec | ||
| 730 | 'semantic-brute-find-tag-by-attribute) | ||
| 731 | |||
| 732 | (semantic-alias-obsolete 'semantic-find-nonterminal-by-extra-spec-value | ||
| 733 | 'semantic-brute-find-tag-by-attribute-value) | ||
| 734 | |||
| 735 | (semantic-alias-obsolete 'semantic-find-nonterminal-by-function | ||
| 736 | 'semantic-brute-find-tag-by-function) | ||
| 737 | |||
| 738 | (semantic-alias-obsolete 'semantic-find-nonterminal-by-function-first-match | ||
| 739 | 'semantic-brute-find-first-tag-by-function) | ||
| 740 | |||
| 741 | (semantic-alias-obsolete 'semantic-find-nonterminal-by-position | ||
| 742 | 'semantic-brute-find-tag-by-position) | ||
| 743 | |||
| 744 | (semantic-alias-obsolete 'semantic-find-innermost-nonterminal-by-position | ||
| 745 | 'semantic-brute-find-innermost-tag-by-position) | ||
| 746 | |||
| 747 | ;;; TESTING | ||
| 748 | ;; | ||
| 749 | (defun semantic-find-benchmark () | ||
| 750 | "Run some simple benchmarks to see how we are doing. | ||
| 751 | Optional argument ARG is the number of iterations to run." | ||
| 752 | (interactive) | ||
| 753 | (require 'benchmark) | ||
| 754 | (let ((f-name nil) | ||
| 755 | (b-name nil) | ||
| 756 | (f-comp) | ||
| 757 | (b-comp) | ||
| 758 | (f-regex) | ||
| 759 | ) | ||
| 760 | (garbage-collect) | ||
| 761 | (setq f-name | ||
| 762 | (benchmark-run-compiled | ||
| 763 | 1000 (semantic-find-first-tag-by-name "class3" | ||
| 764 | "test/test.cpp"))) | ||
| 765 | (garbage-collect) | ||
| 766 | (setq b-name | ||
| 767 | (benchmark-run-compiled | ||
| 768 | 1000 (semantic-brute-find-first-tag-by-name "class3" | ||
| 769 | "test/test.cpp"))) | ||
| 770 | (garbage-collect) | ||
| 771 | (setq f-comp | ||
| 772 | (benchmark-run-compiled | ||
| 773 | 1000 (semantic-find-tags-for-completion "method" | ||
| 774 | "test/test.cpp"))) | ||
| 775 | (garbage-collect) | ||
| 776 | (setq b-comp | ||
| 777 | (benchmark-run-compiled | ||
| 778 | 1000 (semantic-brute-find-tag-by-name-regexp "^method" | ||
| 779 | "test/test.cpp"))) | ||
| 780 | (garbage-collect) | ||
| 781 | (setq f-regex | ||
| 782 | (benchmark-run-compiled | ||
| 783 | 1000 (semantic-find-tags-by-name-regexp "^method" | ||
| 784 | "test/test.cpp"))) | ||
| 785 | |||
| 786 | (message "Name [new old] [ %.3f %.3f ] Complete [newc/new old] [ %.3f/%.3f %.3f ]" | ||
| 787 | (car f-name) (car b-name) | ||
| 788 | (car f-comp) (car f-regex) | ||
| 789 | (car b-comp)) | ||
| 790 | )) | ||
| 791 | |||
| 792 | |||
| 793 | (provide 'semantic/find) | ||
| 794 | |||
| 795 | ;;; semantic-find.el ends here | ||
diff --git a/lisp/cedet/semantic/format.el b/lisp/cedet/semantic/format.el new file mode 100644 index 00000000000..ad6523f4fa8 --- /dev/null +++ b/lisp/cedet/semantic/format.el | |||
| @@ -0,0 +1,774 @@ | |||
| 1 | ;;; format.el --- Routines for formatting 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 | ;; Once a language file has been parsed into a TAG, it is often useful | ||
| 27 | ;; then display that tag information in browsers, completion engines, or | ||
| 28 | ;; help routines. The functions and setup in this file provide ways | ||
| 29 | ;; to reformat a tag into different standard output types. | ||
| 30 | ;; | ||
| 31 | ;; In addition, macros for setting up customizable variables that let | ||
| 32 | ;; the user choose their default format type are also provided. | ||
| 33 | ;; | ||
| 34 | |||
| 35 | ;;; Code: | ||
| 36 | (eval-when-compile (require 'font-lock)) | ||
| 37 | (require 'semantic/tag) | ||
| 38 | (require 'ezimage) | ||
| 39 | |||
| 40 | ;;; Tag to text overload functions | ||
| 41 | ;; | ||
| 42 | ;; abbreviations, prototypes, and coloring support. | ||
| 43 | (defvar semantic-format-tag-functions | ||
| 44 | '(semantic-format-tag-name | ||
| 45 | semantic-format-tag-canonical-name | ||
| 46 | semantic-format-tag-abbreviate | ||
| 47 | semantic-format-tag-summarize | ||
| 48 | semantic-format-tag-summarize-with-file | ||
| 49 | semantic-format-tag-short-doc | ||
| 50 | semantic-format-tag-prototype | ||
| 51 | semantic-format-tag-concise-prototype | ||
| 52 | semantic-format-tag-uml-abbreviate | ||
| 53 | semantic-format-tag-uml-prototype | ||
| 54 | semantic-format-tag-uml-concise-prototype | ||
| 55 | semantic-format-tag-prin1 | ||
| 56 | ) | ||
| 57 | "List of functions which convert a tag to text. | ||
| 58 | Each function must take the parameters TAG &optional PARENT COLOR. | ||
| 59 | TAG is the tag to convert. | ||
| 60 | PARENT is a parent tag or name which refers to the structure | ||
| 61 | or class which contains TAG. PARENT is NOT a class which a TAG | ||
| 62 | would claim as a parent. | ||
| 63 | COLOR indicates that the generated text should be colored using | ||
| 64 | `font-lock'.") | ||
| 65 | |||
| 66 | (semantic-varalias-obsolete 'semantic-token->text-functions | ||
| 67 | 'semantic-format-tag-functions) | ||
| 68 | (defvar semantic-format-tag-custom-list | ||
| 69 | (append '(radio) | ||
| 70 | (mapcar (lambda (f) (list 'const f)) | ||
| 71 | semantic-format-tag-functions) | ||
| 72 | '(function)) | ||
| 73 | "A List used by customizeable variables to choose a tag to text function. | ||
| 74 | Use this variable in the :type field of a customizable variable.") | ||
| 75 | |||
| 76 | (semantic-varalias-obsolete 'semantic-token->text-custom-list | ||
| 77 | 'semantic-format-tag-custom-list) | ||
| 78 | |||
| 79 | (defcustom semantic-format-use-images-flag ezimage-use-images | ||
| 80 | "Non-nil means semantic format functions use images. | ||
| 81 | Images can be used as icons instead of some types of text strings." | ||
| 82 | :group 'semantic | ||
| 83 | :type 'boolean) | ||
| 84 | |||
| 85 | (defvar semantic-function-argument-separator "," | ||
| 86 | "Text used to separate arguments when creating text from tags.") | ||
| 87 | (make-variable-buffer-local 'semantic-function-argument-separator) | ||
| 88 | |||
| 89 | (defvar semantic-format-parent-separator "::" | ||
| 90 | "Text used to separate names when between namespaces/classes and functions.") | ||
| 91 | (make-variable-buffer-local 'semantic-format-parent-separator) | ||
| 92 | |||
| 93 | (defun semantic-test-all-format-tag-functions (&optional arg) | ||
| 94 | "Test all outputs from `semantic-format-tag-functions'. | ||
| 95 | Output is generated from the function under `point'. | ||
| 96 | Optional argument ARG specifies not to use color." | ||
| 97 | (interactive "P") | ||
| 98 | (semantic-fetch-tags) | ||
| 99 | (let* ((tag (semantic-current-tag)) | ||
| 100 | (par (semantic-current-tag-parent)) | ||
| 101 | (fns semantic-format-tag-functions)) | ||
| 102 | (with-output-to-temp-buffer "*format-tag*" | ||
| 103 | (princ "Tag->format function tests:") | ||
| 104 | (while fns | ||
| 105 | (princ "\n") | ||
| 106 | (princ (car fns)) | ||
| 107 | (princ ":\n ") | ||
| 108 | (let ((s (funcall (car fns) tag par (not arg)))) | ||
| 109 | (save-excursion | ||
| 110 | (set-buffer "*format-tag*") | ||
| 111 | (goto-char (point-max)) | ||
| 112 | (insert s))) | ||
| 113 | (setq fns (cdr fns)))) | ||
| 114 | )) | ||
| 115 | |||
| 116 | (defvar semantic-format-face-alist | ||
| 117 | `( (function . font-lock-function-name-face) | ||
| 118 | (variable . font-lock-variable-name-face) | ||
| 119 | (type . font-lock-type-face) | ||
| 120 | ;; These are different between Emacsen. | ||
| 121 | (include . ,(if (featurep 'xemacs) | ||
| 122 | 'font-lock-preprocessor-face | ||
| 123 | 'font-lock-constant-face)) | ||
| 124 | (package . ,(if (featurep 'xemacs) | ||
| 125 | 'font-lock-preprocessor-face | ||
| 126 | 'font-lock-constant-face)) | ||
| 127 | ;; Not a tag, but instead a feature of output | ||
| 128 | (label . font-lock-string-face) | ||
| 129 | (comment . font-lock-comment-face) | ||
| 130 | (keyword . font-lock-keyword-face) | ||
| 131 | (abstract . italic) | ||
| 132 | (static . underline) | ||
| 133 | (documentation . font-lock-doc-face) | ||
| 134 | ) | ||
| 135 | "Face used to colorize tags of different types. | ||
| 136 | Override the value locally if a language supports other tag types. | ||
| 137 | When adding new elements, try to use symbols also returned by the parser. | ||
| 138 | The form of an entry in this list is of the form: | ||
| 139 | ( SYMBOL . FACE ) | ||
| 140 | where SYMBOL is a tag type symbol used with semantic. FACE | ||
| 141 | is a symbol representing a face. | ||
| 142 | Faces used are generated in `font-lock' for consistency, and will not | ||
| 143 | be used unless font lock is a feature.") | ||
| 144 | |||
| 145 | (semantic-varalias-obsolete 'semantic-face-alist | ||
| 146 | 'semantic-format-face-alist) | ||
| 147 | |||
| 148 | |||
| 149 | |||
| 150 | ;;; Coloring Functions | ||
| 151 | ;; | ||
| 152 | (defun semantic--format-colorize-text (text face-class) | ||
| 153 | "Apply onto TEXT a color associated with FACE-CLASS. | ||
| 154 | FACE-CLASS is a tag type found in `semantic-face-alist'. See this variable | ||
| 155 | for details on adding new types." | ||
| 156 | (if (featurep 'font-lock) | ||
| 157 | (let ((face (cdr-safe (assoc face-class semantic-format-face-alist))) | ||
| 158 | (newtext (concat text))) | ||
| 159 | (put-text-property 0 (length text) 'face face newtext) | ||
| 160 | newtext) | ||
| 161 | text)) | ||
| 162 | |||
| 163 | (make-obsolete 'semantic-colorize-text | ||
| 164 | 'semantic--format-colorize-text) | ||
| 165 | |||
| 166 | (defun semantic--format-colorize-merge-text (precoloredtext face-class) | ||
| 167 | "Apply onto PRECOLOREDTEXT a color associated with FACE-CLASS. | ||
| 168 | FACE-CLASS is a tag type found in 'semantic-face-alist'. See this | ||
| 169 | variable for details on adding new types." | ||
| 170 | (let ((face (cdr-safe (assoc face-class semantic-format-face-alist))) | ||
| 171 | (newtext (concat precoloredtext)) | ||
| 172 | ) | ||
| 173 | (if (featurep 'xemacs) | ||
| 174 | (add-text-properties 0 (length newtext) (list 'face face) newtext) | ||
| 175 | (alter-text-property 0 (length newtext) 'face | ||
| 176 | (lambda (current-face) | ||
| 177 | (let ((cf | ||
| 178 | (cond ((facep current-face) | ||
| 179 | (list current-face)) | ||
| 180 | ((listp current-face) | ||
| 181 | current-face) | ||
| 182 | (t nil))) | ||
| 183 | (nf | ||
| 184 | (cond ((facep face) | ||
| 185 | (list face)) | ||
| 186 | ((listp face) | ||
| 187 | face) | ||
| 188 | (t nil)))) | ||
| 189 | (append cf nf))) | ||
| 190 | newtext)) | ||
| 191 | newtext)) | ||
| 192 | |||
| 193 | ;;; Function Arguments | ||
| 194 | ;; | ||
| 195 | (defun semantic--format-tag-arguments (args formatter color) | ||
| 196 | "Format the argument list ARGS with FORMATTER. | ||
| 197 | FORMATTER is a function used to format a tag. | ||
| 198 | COLOR specifies if color should be used." | ||
| 199 | (let ((out nil)) | ||
| 200 | (while args | ||
| 201 | (push (if (and formatter | ||
| 202 | (semantic-tag-p (car args)) | ||
| 203 | (not (string= (semantic-tag-name (car args)) "")) | ||
| 204 | ) | ||
| 205 | (funcall formatter (car args) nil color) | ||
| 206 | (semantic-format-tag-name-from-anything | ||
| 207 | (car args) nil color 'variable)) | ||
| 208 | out) | ||
| 209 | (setq args (cdr args))) | ||
| 210 | (mapconcat 'identity (nreverse out) semantic-function-argument-separator) | ||
| 211 | )) | ||
| 212 | |||
| 213 | ;;; Data Type | ||
| 214 | (define-overloadable-function semantic-format-tag-type (tag color) | ||
| 215 | "Convert the data type of TAG to a string usable in tag formatting. | ||
| 216 | It is presumed that TYPE is a string or semantic tag.") | ||
| 217 | |||
| 218 | (defun semantic-format-tag-type-default (tag color) | ||
| 219 | "Convert the data type of TAG to a string usable in tag formatting. | ||
| 220 | Argument COLOR specifies to colorize the text." | ||
| 221 | (let* ((type (semantic-tag-type tag)) | ||
| 222 | (out (cond ((semantic-tag-p type) | ||
| 223 | (let* ((typetype (semantic-tag-type type)) | ||
| 224 | (name (semantic-tag-name type)) | ||
| 225 | (str (if typetype | ||
| 226 | (concat typetype " " name) | ||
| 227 | name))) | ||
| 228 | (if color | ||
| 229 | (semantic--format-colorize-text | ||
| 230 | str | ||
| 231 | 'type) | ||
| 232 | str))) | ||
| 233 | ((and (listp type) | ||
| 234 | (stringp (car type))) | ||
| 235 | (car type)) | ||
| 236 | ((stringp type) | ||
| 237 | type) | ||
| 238 | (t nil)))) | ||
| 239 | (if (and color out) | ||
| 240 | (setq out (semantic--format-colorize-text out 'type)) | ||
| 241 | out) | ||
| 242 | )) | ||
| 243 | |||
| 244 | |||
| 245 | ;;; Abstract formatting functions | ||
| 246 | |||
| 247 | (defun semantic-format-tag-prin1 (tag &optional parent color) | ||
| 248 | "Convert TAG to a string that is the print name for TAG. | ||
| 249 | PARENT and COLOR are ignored." | ||
| 250 | (format "%S" tag)) | ||
| 251 | |||
| 252 | (defun semantic-format-tag-name-from-anything (anything &optional | ||
| 253 | parent color | ||
| 254 | colorhint) | ||
| 255 | "Convert just about anything into a name like string. | ||
| 256 | Argument ANYTHING is the thing to be converted. | ||
| 257 | Optional argument PARENT is the parent type if TAG is a detail. | ||
| 258 | Optional argument COLOR means highlight the prototype with font-lock colors. | ||
| 259 | Optional COLORHINT is the type of color to use if ANYTHING is not a tag | ||
| 260 | with a tag class. See `semantic--format-colorize-text' for a definition | ||
| 261 | of FACE-CLASS for which this is used." | ||
| 262 | (cond ((stringp anything) | ||
| 263 | (semantic--format-colorize-text anything colorhint)) | ||
| 264 | ((semantic-tag-p anything) | ||
| 265 | (let ((ans (semantic-format-tag-name anything parent color))) | ||
| 266 | ;; If ANS is empty string or nil, then the name wasn't | ||
| 267 | ;; supplied. The implication is as in C where there is a data | ||
| 268 | ;; type but no name for a prototype from an include file, or | ||
| 269 | ;; an argument just wasn't used in the body of the fcn. | ||
| 270 | (if (or (null ans) (string= ans "")) | ||
| 271 | (setq ans (semantic-format-tag-type anything color))) | ||
| 272 | ans)) | ||
| 273 | ((and (listp anything) | ||
| 274 | (stringp (car anything))) | ||
| 275 | (semantic--format-colorize-text (car anything) colorhint)))) | ||
| 276 | |||
| 277 | (define-overloadable-function semantic-format-tag-name (tag &optional parent color) | ||
| 278 | "Return the name string describing TAG. | ||
| 279 | The name is the shortest possible representation. | ||
| 280 | Optional argument PARENT is the parent type if TAG is a detail. | ||
| 281 | Optional argument COLOR means highlight the prototype with font-lock colors.") | ||
| 282 | |||
| 283 | (defun semantic-format-tag-name-default (tag &optional parent color) | ||
| 284 | "Return an abbreviated string describing TAG. | ||
| 285 | Optional argument PARENT is the parent type if TAG is a detail. | ||
| 286 | Optional argument COLOR means highlight the prototype with font-lock colors." | ||
| 287 | (let ((name (semantic-tag-name tag)) | ||
| 288 | (destructor | ||
| 289 | (if (eq (semantic-tag-class tag) 'function) | ||
| 290 | (semantic-tag-function-destructor-p tag)))) | ||
| 291 | (when destructor | ||
| 292 | (setq name (concat "~" name))) | ||
| 293 | (if color | ||
| 294 | (setq name (semantic--format-colorize-text name (semantic-tag-class tag)))) | ||
| 295 | name)) | ||
| 296 | |||
| 297 | (defun semantic--format-tag-parent-tree (tag parent) | ||
| 298 | "Under Consideration. | ||
| 299 | |||
| 300 | Return a list of parents for TAG. | ||
| 301 | PARENT is the first parent, or nil. If nil, then an attempt to | ||
| 302 | determine PARENT is made. | ||
| 303 | Once PARENT is identified, additional parents are looked for. | ||
| 304 | The return list first element is the nearest parent, and the last | ||
| 305 | item is the first parent which may be a string. The root parent may | ||
| 306 | not be the actual first parent as there may just be a failure to find | ||
| 307 | local definitions." | ||
| 308 | ;; First, validate the PARENT argument. | ||
| 309 | (unless parent | ||
| 310 | ;; All mechanisms here must be fast as often parent | ||
| 311 | ;; is nil because there isn't one. | ||
| 312 | (setq parent (or (semantic-tag-function-parent tag) | ||
| 313 | (save-excursion | ||
| 314 | (semantic-go-to-tag tag) | ||
| 315 | (semantic-current-tag-parent))))) | ||
| 316 | (when (stringp parent) | ||
| 317 | (setq parent (semantic-find-first-tag-by-name | ||
| 318 | parent (current-buffer)))) | ||
| 319 | ;; Try and find a trail of parents from PARENT | ||
| 320 | (let ((rlist (list parent)) | ||
| 321 | ) | ||
| 322 | ;; IMPLELEMENT ME!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! | ||
| 323 | (reverse rlist))) | ||
| 324 | |||
| 325 | (define-overloadable-function semantic-format-tag-canonical-name (tag &optional parent color) | ||
| 326 | "Return a canonical name for TAG. | ||
| 327 | A canonical name includes the names of any parents or namespaces preceeding | ||
| 328 | the tag. | ||
| 329 | Optional argument PARENT is the parent type if TAG is a detail. | ||
| 330 | Optional argument COLOR means highlight the prototype with font-lock colors.") | ||
| 331 | |||
| 332 | (defun semantic-format-tag-canonical-name-default (tag &optional parent color) | ||
| 333 | "Return a canonical name for TAG. | ||
| 334 | A canonical name includes the names of any parents or namespaces preceeding | ||
| 335 | the tag with colons separating them. | ||
| 336 | Optional argument PARENT is the parent type if TAG is a detail. | ||
| 337 | Optional argument COLOR means highlight the prototype with font-lock colors." | ||
| 338 | (let ((parent-input-str | ||
| 339 | (if (and parent | ||
| 340 | (semantic-tag-p parent) | ||
| 341 | (semantic-tag-of-class-p parent 'type)) | ||
| 342 | (concat | ||
| 343 | ;; Choose a class of 'type as the default parent for something. | ||
| 344 | ;; Just a guess though. | ||
| 345 | (semantic-format-tag-name-from-anything parent nil color 'type) | ||
| 346 | ;; Default separator between class/namespace and others. | ||
| 347 | semantic-format-parent-separator) | ||
| 348 | "")) | ||
| 349 | (tag-parent-str | ||
| 350 | (or (when (and (semantic-tag-of-class-p tag 'function) | ||
| 351 | (semantic-tag-function-parent tag)) | ||
| 352 | (concat (semantic-tag-function-parent tag) | ||
| 353 | semantic-format-parent-separator)) | ||
| 354 | "")) | ||
| 355 | ) | ||
| 356 | (concat parent-input-str | ||
| 357 | tag-parent-str | ||
| 358 | (semantic-format-tag-name tag parent color)) | ||
| 359 | )) | ||
| 360 | |||
| 361 | (define-overloadable-function semantic-format-tag-abbreviate (tag &optional parent color) | ||
| 362 | "Return an abbreviated string describing TAG. | ||
| 363 | The abbreviation is to be short, with possible symbols indicating | ||
| 364 | the type of tag, or other information. | ||
| 365 | Optional argument PARENT is the parent type if TAG is a detail. | ||
| 366 | Optional argument COLOR means highlight the prototype with font-lock colors.") | ||
| 367 | |||
| 368 | (defun semantic-format-tag-abbreviate-default (tag &optional parent color) | ||
| 369 | "Return an abbreviated string describing TAG. | ||
| 370 | Optional argument PARENT is a parent tag in the tag hierarchy. | ||
| 371 | In this case PARENT refers to containment, not inheritance. | ||
| 372 | Optional argument COLOR means highlight the prototype with font-lock colors. | ||
| 373 | This is a simple C like default." | ||
| 374 | ;; Do lots of complex stuff here. | ||
| 375 | (let ((class (semantic-tag-class tag)) | ||
| 376 | (name (semantic-format-tag-canonical-name tag parent color)) | ||
| 377 | (suffix "") | ||
| 378 | (prefix "") | ||
| 379 | str) | ||
| 380 | (cond ((eq class 'function) | ||
| 381 | (setq suffix "()")) | ||
| 382 | ((eq class 'include) | ||
| 383 | (setq suffix "<>")) | ||
| 384 | ((eq class 'variable) | ||
| 385 | (setq suffix (if (semantic-tag-variable-default tag) | ||
| 386 | "=" ""))) | ||
| 387 | ((eq class 'label) | ||
| 388 | (setq suffix ":")) | ||
| 389 | ((eq class 'code) | ||
| 390 | (setq prefix "{" | ||
| 391 | suffix "}")) | ||
| 392 | ((eq class 'type) | ||
| 393 | (setq suffix "{}")) | ||
| 394 | ) | ||
| 395 | (setq str (concat prefix name suffix)) | ||
| 396 | str)) | ||
| 397 | |||
| 398 | ;; Semantic 1.2.x had this misspelling. Keep it for backwards compatibiity. | ||
| 399 | (semantic-alias-obsolete | ||
| 400 | 'semantic-summerize-nonterminal 'semantic-format-tag-summarize) | ||
| 401 | |||
| 402 | (define-overloadable-function semantic-format-tag-summarize (tag &optional parent color) | ||
| 403 | "Summarize TAG in a reasonable way. | ||
| 404 | Optional argument PARENT is the parent type if TAG is a detail. | ||
| 405 | Optional argument COLOR means highlight the prototype with font-lock colors.") | ||
| 406 | |||
| 407 | (defun semantic-format-tag-summarize-default (tag &optional parent color) | ||
| 408 | "Summarize TAG in a reasonable way. | ||
| 409 | Optional argument PARENT is the parent type if TAG is a detail. | ||
| 410 | Optional argument COLOR means highlight the prototype with font-lock colors." | ||
| 411 | (let* ((proto (semantic-format-tag-prototype tag nil color)) | ||
| 412 | (names (if parent | ||
| 413 | semantic-symbol->name-assoc-list-for-type-parts | ||
| 414 | semantic-symbol->name-assoc-list)) | ||
| 415 | (tsymb (semantic-tag-class tag)) | ||
| 416 | (label (capitalize (or (cdr-safe (assoc tsymb names)) | ||
| 417 | (symbol-name tsymb))))) | ||
| 418 | (if color | ||
| 419 | (setq label (semantic--format-colorize-text label 'label))) | ||
| 420 | (concat label ": " proto))) | ||
| 421 | |||
| 422 | (define-overloadable-function semantic-format-tag-summarize-with-file (tag &optional parent color) | ||
| 423 | "Like `semantic-format-tag-summarize', but with the file name. | ||
| 424 | Optional argument PARENT is the parent type if TAG is a detail. | ||
| 425 | Optional argument COLOR means highlight the prototype with font-lock colors.") | ||
| 426 | |||
| 427 | (defun semantic-format-tag-summarize-with-file-default (tag &optional parent color) | ||
| 428 | "Summarize TAG in a reasonable way. | ||
| 429 | Optional argument PARENT is the parent type if TAG is a detail. | ||
| 430 | Optional argument COLOR means highlight the prototype with font-lock colors." | ||
| 431 | (let* ((proto (semantic-format-tag-prototype tag nil color)) | ||
| 432 | (file (semantic-tag-file-name tag)) | ||
| 433 | ) | ||
| 434 | ;; Nothing for tag? Try parent. | ||
| 435 | (when (and (not file) (and parent)) | ||
| 436 | (setq file (semantic-tag-file-name parent))) | ||
| 437 | ;; Don't include the file name if we can't find one, or it is the | ||
| 438 | ;; same as the current buffer. | ||
| 439 | (if (or (not file) | ||
| 440 | (string= file (buffer-file-name (current-buffer)))) | ||
| 441 | proto | ||
| 442 | (setq file (file-name-nondirectory file)) | ||
| 443 | (when color | ||
| 444 | (setq file (semantic--format-colorize-text file 'label))) | ||
| 445 | (concat file ": " proto)))) | ||
| 446 | |||
| 447 | (define-overloadable-function semantic-format-tag-short-doc (tag &optional parent color) | ||
| 448 | "Display a short form of TAG's documentation. (Comments, or docstring.) | ||
| 449 | Optional argument PARENT is the parent type if TAG is a detail. | ||
| 450 | Optional argument COLOR means highlight the prototype with font-lock colors.") | ||
| 451 | |||
| 452 | (defun semantic-format-tag-short-doc-default (tag &optional parent color) | ||
| 453 | "Display a short form of TAG's documentation. (Comments, or docstring.) | ||
| 454 | Optional argument PARENT is the parent type if TAG is a detail. | ||
| 455 | Optional argument COLOR means highlight the prototype with font-lock colors." | ||
| 456 | (let* ((fname (or (semantic-tag-file-name tag) | ||
| 457 | (when parent (semantic-tag-file-name parent)))) | ||
| 458 | (buf (or (semantic-tag-buffer tag) | ||
| 459 | (when parent (semantic-tag-buffer parent)))) | ||
| 460 | (doc (semantic-tag-docstring tag buf))) | ||
| 461 | (when (and (not doc) (not buf) fname) | ||
| 462 | ;; If there is no doc, and no buffer, but we have a filename, | ||
| 463 | ;; lets try again. | ||
| 464 | (setq buf (find-file-noselect fname)) | ||
| 465 | (setq doc (semantic-tag-docstring tag buf))) | ||
| 466 | (when (not doc) | ||
| 467 | (setq doc (semantic-documentation-for-tag tag)) | ||
| 468 | ) | ||
| 469 | (setq doc | ||
| 470 | (if (not doc) | ||
| 471 | ;; No doc, use summarize. | ||
| 472 | (semantic-format-tag-summarize tag parent color) | ||
| 473 | ;; We have doc. Can we devise a single line? | ||
| 474 | (if (string-match "$" doc) | ||
| 475 | (substring doc 0 (match-beginning 0)) | ||
| 476 | doc) | ||
| 477 | )) | ||
| 478 | (when color | ||
| 479 | (setq doc (semantic--format-colorize-text doc 'documentation))) | ||
| 480 | doc | ||
| 481 | )) | ||
| 482 | |||
| 483 | ;;; Prototype generation | ||
| 484 | ;; | ||
| 485 | (define-overloadable-function semantic-format-tag-prototype (tag &optional parent color) | ||
| 486 | "Return a prototype for TAG. | ||
| 487 | This function should be overloaded, though it need not be used. | ||
| 488 | This is because it can be used to create code by language independent | ||
| 489 | tools. | ||
| 490 | Optional argument PARENT is the parent type if TAG is a detail. | ||
| 491 | Optional argument COLOR means highlight the prototype with font-lock colors.") | ||
| 492 | |||
| 493 | (defun semantic-format-tag-prototype-default (tag &optional parent color) | ||
| 494 | "Default method for returning a prototype for TAG. | ||
| 495 | This will work for C like languages. | ||
| 496 | Optional argument PARENT is the parent type if TAG is a detail. | ||
| 497 | Optional argument COLOR means highlight the prototype with font-lock colors." | ||
| 498 | (let* ((class (semantic-tag-class tag)) | ||
| 499 | (name (semantic-format-tag-name tag parent color)) | ||
| 500 | (type (if (member class '(function variable type)) | ||
| 501 | (semantic-format-tag-type tag color))) | ||
| 502 | (args (if (member class '(function type)) | ||
| 503 | (semantic--format-tag-arguments | ||
| 504 | (if (eq class 'function) | ||
| 505 | (semantic-tag-function-arguments tag) | ||
| 506 | (list "") | ||
| 507 | ;;(semantic-tag-type-members tag) | ||
| 508 | ) | ||
| 509 | #'semantic-format-tag-prototype | ||
| 510 | color))) | ||
| 511 | (const (semantic-tag-get-attribute tag :constant-flag)) | ||
| 512 | (tm (semantic-tag-get-attribute tag :typemodifiers)) | ||
| 513 | (mods (append | ||
| 514 | (if const '("const") nil) | ||
| 515 | (cond ((stringp tm) (list tm)) | ||
| 516 | ((consp tm) tm) | ||
| 517 | (t nil)) | ||
| 518 | )) | ||
| 519 | (array (if (eq class 'variable) | ||
| 520 | (let ((deref | ||
| 521 | (semantic-tag-get-attribute | ||
| 522 | tag :dereference)) | ||
| 523 | (r "")) | ||
| 524 | (while (and deref (/= deref 0)) | ||
| 525 | (setq r (concat r "[]") | ||
| 526 | deref (1- deref))) | ||
| 527 | r))) | ||
| 528 | ) | ||
| 529 | (if args | ||
| 530 | (setq args | ||
| 531 | (concat " " | ||
| 532 | (if (eq class 'type) "{" "(") | ||
| 533 | args | ||
| 534 | (if (eq class 'type) "}" ")")))) | ||
| 535 | (when mods | ||
| 536 | (setq mods (concat (mapconcat 'identity mods " ") " "))) | ||
| 537 | (concat (or mods "") | ||
| 538 | (if type (concat type " ")) | ||
| 539 | name | ||
| 540 | (or args "") | ||
| 541 | (or array "")))) | ||
| 542 | |||
| 543 | (define-overloadable-function semantic-format-tag-concise-prototype (tag &optional parent color) | ||
| 544 | "Return a concise prototype for TAG. | ||
| 545 | Optional argument PARENT is the parent type if TAG is a detail. | ||
| 546 | Optional argument COLOR means highlight the prototype with font-lock colors.") | ||
| 547 | |||
| 548 | (defun semantic-format-tag-concise-prototype-default (tag &optional parent color) | ||
| 549 | "Return a concise prototype for TAG. | ||
| 550 | This default function will make a cheap concise prototype using C like syntax. | ||
| 551 | Optional argument PARENT is the parent type if TAG is a detail. | ||
| 552 | Optional argument COLOR means highlight the prototype with font-lock colors." | ||
| 553 | (let ((class (semantic-tag-class tag))) | ||
| 554 | (cond | ||
| 555 | ((eq class 'type) | ||
| 556 | (concat (semantic-format-tag-name tag parent color) "{}")) | ||
| 557 | ((eq class 'function) | ||
| 558 | (concat (semantic-format-tag-name tag parent color) | ||
| 559 | " (" | ||
| 560 | (semantic--format-tag-arguments | ||
| 561 | (semantic-tag-function-arguments tag) | ||
| 562 | 'semantic-format-tag-concise-prototype | ||
| 563 | color) | ||
| 564 | ")")) | ||
| 565 | ((eq class 'variable) | ||
| 566 | (let* ((deref (semantic-tag-get-attribute | ||
| 567 | tag :dereference)) | ||
| 568 | (array "") | ||
| 569 | ) | ||
| 570 | (while (and deref (/= deref 0)) | ||
| 571 | (setq array (concat array "[]") | ||
| 572 | deref (1- deref))) | ||
| 573 | (concat (semantic-format-tag-name tag parent color) | ||
| 574 | array))) | ||
| 575 | (t | ||
| 576 | (semantic-format-tag-abbreviate tag parent color))))) | ||
| 577 | |||
| 578 | ;;; UML display styles | ||
| 579 | ;; | ||
| 580 | (defcustom semantic-uml-colon-string " : " | ||
| 581 | "*String used as a color separator between parts of a UML string. | ||
| 582 | In UML, a variable may appear as `varname : type'. | ||
| 583 | Change this variable to change the output separator." | ||
| 584 | :group 'semantic | ||
| 585 | :type 'string) | ||
| 586 | |||
| 587 | (defcustom semantic-uml-no-protection-string "" | ||
| 588 | "*String used to describe when no protection is specified. | ||
| 589 | Used by `semantic-format-tag-uml-protection-to-string'." | ||
| 590 | :group 'semantic | ||
| 591 | :type 'string) | ||
| 592 | |||
| 593 | (defun semantic--format-uml-post-colorize (text tag parent) | ||
| 594 | "Add color to TEXT created from TAG and PARENT. | ||
| 595 | Adds augmentation for `abstract' and `static' entries." | ||
| 596 | (if (semantic-tag-abstract-p tag parent) | ||
| 597 | (setq text (semantic--format-colorize-merge-text text 'abstract))) | ||
| 598 | (if (semantic-tag-static-p tag parent) | ||
| 599 | (setq text (semantic--format-colorize-merge-text text 'static))) | ||
| 600 | text | ||
| 601 | ) | ||
| 602 | |||
| 603 | (defun semantic-uml-attribute-string (tag &optional parent) | ||
| 604 | "Return a string for TAG, a child of PARENT representing a UML attribute. | ||
| 605 | UML attribute strings are things like {abstract} or {leaf}." | ||
| 606 | (cond ((semantic-tag-abstract-p tag parent) | ||
| 607 | "{abstract}") | ||
| 608 | ((semantic-tag-leaf-p tag parent) | ||
| 609 | "{leaf}") | ||
| 610 | )) | ||
| 611 | |||
| 612 | (defvar semantic-format-tag-protection-image-alist | ||
| 613 | '(("+" . ezimage-unlock) | ||
| 614 | ("#" . ezimage-key) | ||
| 615 | ("-" . ezimage-lock) | ||
| 616 | ) | ||
| 617 | "Association of protection strings, and images to use.") | ||
| 618 | |||
| 619 | (defvar semantic-format-tag-protection-symbol-to-string-assoc-list | ||
| 620 | '((public . "+") | ||
| 621 | (protected . "#") | ||
| 622 | (private . "-") | ||
| 623 | ) | ||
| 624 | "Association list of the form (SYMBOL . \"STRING\") for protection symbols. | ||
| 625 | This associates a symbol, such as 'public with the st ring \"+\".") | ||
| 626 | |||
| 627 | (define-overloadable-function semantic-format-tag-uml-protection-to-string (protection-symbol color) | ||
| 628 | "Convert PROTECTION-SYMBOL to a string for UML. | ||
| 629 | By default, uses `semantic-format-tag-protection-symbol-to-string-assoc-list' | ||
| 630 | to convert. | ||
| 631 | By defaul character returns are: | ||
| 632 | public -- + | ||
| 633 | private -- - | ||
| 634 | protected -- #. | ||
| 635 | If PROTECTION-SYMBOL is unknown, then the return value is | ||
| 636 | `semantic-uml-no-protection-string'. | ||
| 637 | COLOR indicates if we should use an image on the text.") | ||
| 638 | |||
| 639 | (defun semantic-format-tag-uml-protection-to-string-default (protection-symbol color) | ||
| 640 | "Convert PROTECTION-SYMBOL to a string for UML. | ||
| 641 | Uses `semantic-format-tag-protection-symbol-to-string-assoc-list' to convert. | ||
| 642 | If PROTECTION-SYMBOL is unknown, then the return value is | ||
| 643 | `semantic-uml-no-protection-string'. | ||
| 644 | COLOR indicates if we should use an image on the text." | ||
| 645 | (let* ((ezimage-use-images (and semantic-format-use-images-flag color)) | ||
| 646 | (key (assoc protection-symbol | ||
| 647 | semantic-format-tag-protection-symbol-to-string-assoc-list)) | ||
| 648 | (str (or (cdr-safe key) semantic-uml-no-protection-string))) | ||
| 649 | (ezimage-image-over-string | ||
| 650 | (copy-sequence str) ; make a copy to keep the original pristine. | ||
| 651 | semantic-format-tag-protection-image-alist))) | ||
| 652 | |||
| 653 | (defsubst semantic-format-tag-uml-protection (tag parent color) | ||
| 654 | "Retrieve the protection string for TAG with PARENT. | ||
| 655 | Argument COLOR specifies that color should be added to the string as | ||
| 656 | needed." | ||
| 657 | (semantic-format-tag-uml-protection-to-string | ||
| 658 | (semantic-tag-protection tag parent) | ||
| 659 | color)) | ||
| 660 | |||
| 661 | (defun semantic--format-tag-uml-type (tag color) | ||
| 662 | "Format the data type of TAG to a string usable for formatting. | ||
| 663 | COLOR indicates if it should be colorized." | ||
| 664 | (let ((str (semantic-format-tag-type tag color))) | ||
| 665 | (if str | ||
| 666 | (concat semantic-uml-colon-string str)))) | ||
| 667 | |||
| 668 | (define-overloadable-function semantic-format-tag-uml-abbreviate (tag &optional parent color) | ||
| 669 | "Return a UML style abbreviation for TAG. | ||
| 670 | Optional argument PARENT is the parent type if TAG is a detail. | ||
| 671 | Optional argument COLOR means highlight the prototype with font-lock colors.") | ||
| 672 | |||
| 673 | (defun semantic-format-tag-uml-abbreviate-default (tag &optional parent color) | ||
| 674 | "Return a UML style abbreviation for TAG. | ||
| 675 | Optional argument PARENT is the parent type if TAG is a detail. | ||
| 676 | Optional argument COLOR means highlight the prototype with font-lock colors." | ||
| 677 | (let* ((name (semantic-format-tag-name tag parent color)) | ||
| 678 | (type (semantic--format-tag-uml-type tag color)) | ||
| 679 | (protstr (semantic-format-tag-uml-protection tag parent color)) | ||
| 680 | (text nil)) | ||
| 681 | (setq text | ||
| 682 | (concat | ||
| 683 | protstr | ||
| 684 | (if type (concat name type) | ||
| 685 | name))) | ||
| 686 | (if color | ||
| 687 | (setq text (semantic--format-uml-post-colorize text tag parent))) | ||
| 688 | text)) | ||
| 689 | |||
| 690 | (define-overloadable-function semantic-format-tag-uml-prototype (tag &optional parent color) | ||
| 691 | "Return a UML style prototype for TAG. | ||
| 692 | Optional argument PARENT is the parent type if TAG is a detail. | ||
| 693 | Optional argument COLOR means highlight the prototype with font-lock colors.") | ||
| 694 | |||
| 695 | (defun semantic-format-tag-uml-prototype-default (tag &optional parent color) | ||
| 696 | "Return a UML style prototype for TAG. | ||
| 697 | Optional argument PARENT is the parent type if TAG is a detail. | ||
| 698 | Optional argument COLOR means highlight the prototype with font-lock colors." | ||
| 699 | (let* ((class (semantic-tag-class tag)) | ||
| 700 | (cp (semantic-format-tag-name tag parent color)) | ||
| 701 | (type (semantic--format-tag-uml-type tag color)) | ||
| 702 | (prot (semantic-format-tag-uml-protection tag parent color)) | ||
| 703 | (argtext | ||
| 704 | (cond ((eq class 'function) | ||
| 705 | (concat | ||
| 706 | " (" | ||
| 707 | (semantic--format-tag-arguments | ||
| 708 | (semantic-tag-function-arguments tag) | ||
| 709 | #'semantic-format-tag-uml-prototype | ||
| 710 | color) | ||
| 711 | ")")) | ||
| 712 | ((eq class 'type) | ||
| 713 | "{}"))) | ||
| 714 | (text nil)) | ||
| 715 | (setq text (concat prot cp argtext type)) | ||
| 716 | (if color | ||
| 717 | (setq text (semantic--format-uml-post-colorize text tag parent))) | ||
| 718 | text | ||
| 719 | )) | ||
| 720 | |||
| 721 | (define-overloadable-function semantic-format-tag-uml-concise-prototype (tag &optional parent color) | ||
| 722 | "Return a UML style concise prototype for TAG. | ||
| 723 | Optional argument PARENT is the parent type if TAG is a detail. | ||
| 724 | Optional argument COLOR means highlight the prototype with font-lock colors.") | ||
| 725 | |||
| 726 | (defun semantic-format-tag-uml-concise-prototype-default (tag &optional parent color) | ||
| 727 | "Return a UML style concise prototype for TAG. | ||
| 728 | Optional argument PARENT is the parent type if TAG is a detail. | ||
| 729 | Optional argument COLOR means highlight the prototype with font-lock colors." | ||
| 730 | (let* ((cp (semantic-format-tag-concise-prototype tag parent color)) | ||
| 731 | (type (semantic--format-tag-uml-type tag color)) | ||
| 732 | (prot (semantic-format-tag-uml-protection tag parent color)) | ||
| 733 | (text nil) | ||
| 734 | ) | ||
| 735 | (setq text (concat prot cp type)) | ||
| 736 | (if color | ||
| 737 | (setq text (semantic--format-uml-post-colorize text tag parent))) | ||
| 738 | text | ||
| 739 | )) | ||
| 740 | |||
| 741 | |||
| 742 | ;;; Compatibility and aliases | ||
| 743 | ;; | ||
| 744 | (semantic-alias-obsolete 'semantic-prin1-nonterminal | ||
| 745 | 'semantic-format-tag-prin1) | ||
| 746 | |||
| 747 | (semantic-alias-obsolete 'semantic-name-nonterminal | ||
| 748 | 'semantic-format-tag-name) | ||
| 749 | |||
| 750 | (semantic-alias-obsolete 'semantic-abbreviate-nonterminal | ||
| 751 | 'semantic-format-tag-abbreviate) | ||
| 752 | |||
| 753 | (semantic-alias-obsolete 'semantic-summarize-nonterminal | ||
| 754 | 'semantic-format-tag-summarize) | ||
| 755 | |||
| 756 | (semantic-alias-obsolete 'semantic-prototype-nonterminal | ||
| 757 | 'semantic-format-tag-prototype) | ||
| 758 | |||
| 759 | (semantic-alias-obsolete 'semantic-concise-prototype-nonterminal | ||
| 760 | 'semantic-format-tag-concise-prototype) | ||
| 761 | |||
| 762 | (semantic-alias-obsolete 'semantic-uml-abbreviate-nonterminal | ||
| 763 | 'semantic-format-tag-uml-abbreviate) | ||
| 764 | |||
| 765 | (semantic-alias-obsolete 'semantic-uml-prototype-nonterminal | ||
| 766 | 'semantic-format-tag-uml-prototype) | ||
| 767 | |||
| 768 | (semantic-alias-obsolete 'semantic-uml-concise-prototype-nonterminal | ||
| 769 | 'semantic-format-tag-uml-concise-prototype) | ||
| 770 | |||
| 771 | |||
| 772 | (provide 'semantic/format) | ||
| 773 | |||
| 774 | ;;; semantic-format.el ends here | ||
diff --git a/lisp/cedet/semantic/sort.el b/lisp/cedet/semantic/sort.el new file mode 100644 index 00000000000..7fa08530672 --- /dev/null +++ b/lisp/cedet/semantic/sort.el | |||
| @@ -0,0 +1,592 @@ | |||
| 1 | ;;; sort.el --- Utilities for sorting and re-arranging tag tables. | ||
| 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 | ;; Tag tables originate in the order they appear in a buffer, or source file. | ||
| 27 | ;; It is often useful to re-arrange them is some predictable way for browsing | ||
| 28 | ;; purposes. Re-organization may be alphabetical, or even a complete | ||
| 29 | ;; reorganization of parents and children. | ||
| 30 | ;; | ||
| 31 | ;; Originally written in semantic-util.el | ||
| 32 | ;; | ||
| 33 | |||
| 34 | (require 'assoc) | ||
| 35 | (require 'semantic) | ||
| 36 | (require 'semantic/db) | ||
| 37 | (eval-when-compile | ||
| 38 | (require 'semantic/find) | ||
| 39 | (require 'semantic/db-find)) | ||
| 40 | |||
| 41 | ;;; Alphanumeric sorting | ||
| 42 | ;; | ||
| 43 | ;; Takes a list of tags, and sorts them in a case-insensitive way | ||
| 44 | ;; at a single level. | ||
| 45 | |||
| 46 | ;;; Code: | ||
| 47 | (defun semantic-string-lessp-ci (s1 s2) | ||
| 48 | "Case insensitive version of `string-lessp'. | ||
| 49 | Argument S1 and S2 are the strings to compare." | ||
| 50 | ;; Use downcase instead of upcase because an average name | ||
| 51 | ;; has more lower case characters. | ||
| 52 | (if (fboundp 'compare-strings) | ||
| 53 | (eq (compare-strings s1 0 nil s2 0 nil t) -1) | ||
| 54 | (string-lessp (downcase s1) (downcase s2)))) | ||
| 55 | |||
| 56 | (defun semantic-sort-tag-type (tag) | ||
| 57 | "Return a type string for TAG guaranteed to be a string." | ||
| 58 | (let ((ty (semantic-tag-type tag))) | ||
| 59 | (cond ((stringp ty) | ||
| 60 | ty) | ||
| 61 | ((listp ty) | ||
| 62 | (or (car ty) "")) | ||
| 63 | (t "")))) | ||
| 64 | |||
| 65 | (defun semantic-tag-lessp-name-then-type (A B) | ||
| 66 | "Return t if tag A is < tag B. | ||
| 67 | First sorts on name, then sorts on the name of the :type of | ||
| 68 | each tag." | ||
| 69 | (let ((na (semantic-tag-name A)) | ||
| 70 | (nb (semantic-tag-name B)) | ||
| 71 | ) | ||
| 72 | (if (string-lessp na nb) | ||
| 73 | t ; a sure thing. | ||
| 74 | (if (string= na nb) | ||
| 75 | ;; If equal, test the :type which might be different. | ||
| 76 | (let* ((ta (semantic-tag-type A)) | ||
| 77 | (tb (semantic-tag-type B)) | ||
| 78 | (tas (cond ((stringp ta) | ||
| 79 | ta) | ||
| 80 | ((semantic-tag-p ta) | ||
| 81 | (semantic-tag-name ta)) | ||
| 82 | (t nil))) | ||
| 83 | (tbs (cond ((stringp tb) | ||
| 84 | tb) | ||
| 85 | ((semantic-tag-p tb) | ||
| 86 | (semantic-tag-name tb)) | ||
| 87 | (t nil)))) | ||
| 88 | (if (and (stringp tas) (stringp tbs)) | ||
| 89 | (string< tas tbs) | ||
| 90 | ;; This is if A == B, and no types in A or B | ||
| 91 | nil)) | ||
| 92 | ;; This nil is if A > B, but not = | ||
| 93 | nil)))) | ||
| 94 | |||
| 95 | (defun semantic-sort-tags-by-name-increasing (tags) | ||
| 96 | "Sort TAGS by name in increasing order with side effects. | ||
| 97 | Return the sorted list." | ||
| 98 | (sort tags (lambda (a b) | ||
| 99 | (string-lessp (semantic-tag-name a) | ||
| 100 | (semantic-tag-name b))))) | ||
| 101 | |||
| 102 | (defun semantic-sort-tags-by-name-decreasing (tags) | ||
| 103 | "Sort TAGS by name in decreasing order with side effects. | ||
| 104 | Return the sorted list." | ||
| 105 | (sort tags (lambda (a b) | ||
| 106 | (string-lessp (semantic-tag-name b) | ||
| 107 | (semantic-tag-name a))))) | ||
| 108 | |||
| 109 | (defun semantic-sort-tags-by-type-increasing (tags) | ||
| 110 | "Sort TAGS by type in increasing order with side effects. | ||
| 111 | Return the sorted list." | ||
| 112 | (sort tags (lambda (a b) | ||
| 113 | (string-lessp (semantic-sort-tag-type a) | ||
| 114 | (semantic-sort-tag-type b))))) | ||
| 115 | |||
| 116 | (defun semantic-sort-tags-by-type-decreasing (tags) | ||
| 117 | "Sort TAGS by type in decreasing order with side effects. | ||
| 118 | Return the sorted list." | ||
| 119 | (sort tags (lambda (a b) | ||
| 120 | (string-lessp (semantic-sort-tag-type b) | ||
| 121 | (semantic-sort-tag-type a))))) | ||
| 122 | |||
| 123 | (defun semantic-sort-tags-by-name-increasing-ci (tags) | ||
| 124 | "Sort TAGS by name in increasing order with side effects. | ||
| 125 | Return the sorted list." | ||
| 126 | (sort tags (lambda (a b) | ||
| 127 | (semantic-string-lessp-ci (semantic-tag-name a) | ||
| 128 | (semantic-tag-name b))))) | ||
| 129 | |||
| 130 | (defun semantic-sort-tags-by-name-decreasing-ci (tags) | ||
| 131 | "Sort TAGS by name in decreasing order with side effects. | ||
| 132 | Return the sorted list." | ||
| 133 | (sort tags (lambda (a b) | ||
| 134 | (semantic-string-lessp-ci (semantic-tag-name b) | ||
| 135 | (semantic-tag-name a))))) | ||
| 136 | |||
| 137 | (defun semantic-sort-tags-by-type-increasing-ci (tags) | ||
| 138 | "Sort TAGS by type in increasing order with side effects. | ||
| 139 | Return the sorted list." | ||
| 140 | (sort tags (lambda (a b) | ||
| 141 | (semantic-string-lessp-ci (semantic-sort-tag-type a) | ||
| 142 | (semantic-sort-tag-type b))))) | ||
| 143 | |||
| 144 | (defun semantic-sort-tags-by-type-decreasing-ci (tags) | ||
| 145 | "Sort TAGS by type in decreasing order with side effects. | ||
| 146 | Return the sorted list." | ||
| 147 | (sort tags (lambda (a b) | ||
| 148 | (semantic-string-lessp-ci (semantic-sort-tag-type b) | ||
| 149 | (semantic-sort-tag-type a))))) | ||
| 150 | |||
| 151 | (defun semantic-sort-tags-by-name-then-type-increasing (tags) | ||
| 152 | "Sort TAGS by name, then type in increasing order with side effects. | ||
| 153 | Return the sorted list." | ||
| 154 | (sort tags (lambda (a b) (semantic-tag-lessp-name-then-type a b)))) | ||
| 155 | |||
| 156 | (defun semantic-sort-tags-by-name-then-type-decreasing (tags) | ||
| 157 | "Sort TAGS by name, then type in increasing order with side effects. | ||
| 158 | Return the sorted list." | ||
| 159 | (sort tags (lambda (a b) (semantic-tag-lessp-name-then-type b a)))) | ||
| 160 | |||
| 161 | |||
| 162 | (semantic-alias-obsolete 'semantic-sort-tokens-by-name-increasing | ||
| 163 | 'semantic-sort-tags-by-name-increasing) | ||
| 164 | (semantic-alias-obsolete 'semantic-sort-tokens-by-name-decreasing | ||
| 165 | 'semantic-sort-tags-by-name-decreasing) | ||
| 166 | (semantic-alias-obsolete 'semantic-sort-tokens-by-type-increasing | ||
| 167 | 'semantic-sort-tags-by-type-increasing) | ||
| 168 | (semantic-alias-obsolete 'semantic-sort-tokens-by-type-decreasing | ||
| 169 | 'semantic-sort-tags-by-type-decreasing) | ||
| 170 | (semantic-alias-obsolete 'semantic-sort-tokens-by-name-increasing-ci | ||
| 171 | 'semantic-sort-tags-by-name-increasing-ci) | ||
| 172 | (semantic-alias-obsolete 'semantic-sort-tokens-by-name-decreasing-ci | ||
| 173 | 'semantic-sort-tags-by-name-decreasing-ci) | ||
| 174 | (semantic-alias-obsolete 'semantic-sort-tokens-by-type-increasing-ci | ||
| 175 | 'semantic-sort-tags-by-type-increasing-ci) | ||
| 176 | (semantic-alias-obsolete 'semantic-sort-tokens-by-type-decreasing-ci | ||
| 177 | 'semantic-sort-tags-by-type-decreasing-ci) | ||
| 178 | |||
| 179 | |||
| 180 | ;;; Unique | ||
| 181 | ;; | ||
| 182 | ;; Scan a list of tags, removing duplicates. | ||
| 183 | ;; This must first sort the tags by name alphabetically ascending. | ||
| 184 | ;; | ||
| 185 | ;; Useful for completion lists, or other situations where the | ||
| 186 | ;; other data isn't as useful. | ||
| 187 | |||
| 188 | (defun semantic-unique-tag-table-by-name (tags) | ||
| 189 | "Scan a list of TAGS, removing duplicate names. | ||
| 190 | This must first sort the tags by name alphabetically ascending. | ||
| 191 | For more complex uniqueness testing used by the semanticdb | ||
| 192 | typecaching system, see `semanticdb-typecache-merge-streams'." | ||
| 193 | (let ((sorted (semantic-sort-tags-by-name-increasing | ||
| 194 | (copy-sequence tags))) | ||
| 195 | (uniq nil)) | ||
| 196 | (while sorted | ||
| 197 | (if (or (not uniq) | ||
| 198 | (not (string= (semantic-tag-name (car sorted)) | ||
| 199 | (semantic-tag-name (car uniq))))) | ||
| 200 | (setq uniq (cons (car sorted) uniq))) | ||
| 201 | (setq sorted (cdr sorted)) | ||
| 202 | ) | ||
| 203 | (nreverse uniq))) | ||
| 204 | |||
| 205 | (defun semantic-unique-tag-table (tags) | ||
| 206 | "Scan a list of TAGS, removing duplicates. | ||
| 207 | This must first sort the tags by position ascending. | ||
| 208 | TAGS are removed only if they are equivalent, as can happen when | ||
| 209 | multiple tag sources are scanned. | ||
| 210 | For more complex uniqueness testing used by the semanticdb | ||
| 211 | typecaching system, see `semanticdb-typecache-merge-streams'." | ||
| 212 | (let ((sorted (sort (copy-sequence tags) | ||
| 213 | (lambda (a b) | ||
| 214 | (cond ((not (semantic-tag-with-position-p a)) | ||
| 215 | t) | ||
| 216 | ((not (semantic-tag-with-position-p b)) | ||
| 217 | nil) | ||
| 218 | (t | ||
| 219 | (< (semantic-tag-start a) | ||
| 220 | (semantic-tag-start b))))))) | ||
| 221 | (uniq nil)) | ||
| 222 | (while sorted | ||
| 223 | (if (or (not uniq) | ||
| 224 | (not (semantic-equivalent-tag-p (car sorted) (car uniq)))) | ||
| 225 | (setq uniq (cons (car sorted) uniq))) | ||
| 226 | (setq sorted (cdr sorted)) | ||
| 227 | ) | ||
| 228 | (nreverse uniq))) | ||
| 229 | |||
| 230 | |||
| 231 | ;;; Tag Table Flattening | ||
| 232 | ;; | ||
| 233 | ;; In the 1.4 search API, there was a parameter "search-parts" which | ||
| 234 | ;; was used to find tags inside other tags. This was used | ||
| 235 | ;; infrequently, mostly for completion/jump routines. These types | ||
| 236 | ;; of commands would be better off with a flattened list, where all | ||
| 237 | ;; tags appear at the top level. | ||
| 238 | |||
| 239 | (defun semantic-flatten-tags-table (&optional table) | ||
| 240 | "Flatten the tags table TABLE. | ||
| 241 | All tags in TABLE, and all components of top level tags | ||
| 242 | in TABLE will appear at the top level of list. | ||
| 243 | Tags promoted to the top of the list will still appear | ||
| 244 | unmodified as components of their parent tags." | ||
| 245 | (let* ((table (semantic-something-to-tag-table table)) | ||
| 246 | ;; Initialize the starting list with our table. | ||
| 247 | (lists (list table))) | ||
| 248 | (mapc (lambda (tag) | ||
| 249 | (let ((components (semantic-tag-components tag))) | ||
| 250 | (if (and components | ||
| 251 | ;; unpositined tags can be hazardous to | ||
| 252 | ;; completion. Do we need any type of tag | ||
| 253 | ;; here? - EL | ||
| 254 | (semantic-tag-with-position-p (car components))) | ||
| 255 | (setq lists (cons | ||
| 256 | (semantic-flatten-tags-table components) | ||
| 257 | lists))))) | ||
| 258 | table) | ||
| 259 | (apply 'append (nreverse lists)) | ||
| 260 | )) | ||
| 261 | |||
| 262 | |||
| 263 | ;;; Buckets: | ||
| 264 | ;; | ||
| 265 | ;; A list of tags can be grouped into buckets based on the tag class. | ||
| 266 | ;; Bucketize means to take a list of tags at a given level in a tag | ||
| 267 | ;; table, and reorganize them into buckets based on class. | ||
| 268 | ;; | ||
| 269 | (defvar semantic-bucketize-tag-class | ||
| 270 | ;; Must use lambda because `semantic-tag-class' is a macro. | ||
| 271 | (lambda (tok) (semantic-tag-class tok)) | ||
| 272 | "Function used to get a symbol describing the class of a tag. | ||
| 273 | This function must take one argument of a semantic tag. | ||
| 274 | It should return a symbol found in `semantic-symbol->name-assoc-list' | ||
| 275 | which `semantic-bucketize' uses to bin up tokens. | ||
| 276 | To create new bins for an application augment | ||
| 277 | `semantic-symbol->name-assoc-list', and | ||
| 278 | `semantic-symbol->name-assoc-list-for-type-parts' in addition | ||
| 279 | to setting this variable (locally in your function).") | ||
| 280 | |||
| 281 | (defun semantic-bucketize (tags &optional parent filter) | ||
| 282 | "Sort TAGS into a group of buckets based on tag class. | ||
| 283 | Unknown classes are placed in a Misc bucket. | ||
| 284 | Type bucket names are defined by either `semantic-symbol->name-assoc-list'. | ||
| 285 | If PARENT is specified, then TAGS belong to this PARENT in some way. | ||
| 286 | This will use `semantic-symbol->name-assoc-list-for-type-parts' to | ||
| 287 | generate bucket names. | ||
| 288 | Optional argument FILTER is a filter function to be applied to each bucket. | ||
| 289 | The filter function will take one argument, which is a list of tokens, and | ||
| 290 | may re-organize the list with side-effects." | ||
| 291 | (let* ((name-list (if parent | ||
| 292 | semantic-symbol->name-assoc-list-for-type-parts | ||
| 293 | semantic-symbol->name-assoc-list)) | ||
| 294 | (sn name-list) | ||
| 295 | (bins (make-vector (1+ (length sn)) nil)) | ||
| 296 | ask tagtype | ||
| 297 | (nsn nil) | ||
| 298 | (num 1) | ||
| 299 | (out nil)) | ||
| 300 | ;; Build up the bucket vector | ||
| 301 | (while sn | ||
| 302 | (setq nsn (cons (cons (car (car sn)) num) nsn) | ||
| 303 | sn (cdr sn) | ||
| 304 | num (1+ num))) | ||
| 305 | ;; Place into buckets | ||
| 306 | (while tags | ||
| 307 | (setq tagtype (funcall semantic-bucketize-tag-class (car tags)) | ||
| 308 | ask (assq tagtype nsn) | ||
| 309 | num (or (cdr ask) 0)) | ||
| 310 | (aset bins num (cons (car tags) (aref bins num))) | ||
| 311 | (setq tags (cdr tags))) | ||
| 312 | ;; Remove from buckets into a list. | ||
| 313 | (setq num 1) | ||
| 314 | (while (< num (length bins)) | ||
| 315 | (when (aref bins num) | ||
| 316 | (setq out | ||
| 317 | (cons (cons | ||
| 318 | (cdr (nth (1- num) name-list)) | ||
| 319 | ;; Filtering, First hacked by David Ponce david@dponce.com | ||
| 320 | (funcall (or filter 'nreverse) (aref bins num))) | ||
| 321 | out))) | ||
| 322 | (setq num (1+ num))) | ||
| 323 | (if (aref bins 0) | ||
| 324 | (setq out (cons (cons "Misc" | ||
| 325 | (funcall (or filter 'nreverse) (aref bins 0))) | ||
| 326 | out))) | ||
| 327 | (nreverse out))) | ||
| 328 | |||
| 329 | ;;; Adoption | ||
| 330 | ;; | ||
| 331 | ;; Some languages allow children of a type to be defined outside | ||
| 332 | ;; the syntactic scope of that class. These routines will find those | ||
| 333 | ;; external members, and bring them together in a cloned copy of the | ||
| 334 | ;; class tag. | ||
| 335 | ;; | ||
| 336 | (defvar semantic-orphaned-member-metaparent-type "class" | ||
| 337 | "In `semantic-adopt-external-members', the type of 'type for metaparents. | ||
| 338 | A metaparent is a made-up type semantic token used to hold the child list | ||
| 339 | of orphaned members of a named type.") | ||
| 340 | (make-variable-buffer-local 'semantic-orphaned-member-metaparent-type) | ||
| 341 | |||
| 342 | (defvar semantic-mark-external-member-function nil | ||
| 343 | "Function called when an externally defined orphan is found. | ||
| 344 | By default, the token is always marked with the `adopted' property. | ||
| 345 | This function should be locally bound by a program that needs | ||
| 346 | to add additional behaviors into the token list. | ||
| 347 | This function is called with two arguments. The first is TOKEN which is | ||
| 348 | a shallow copy of the token to be modified. The second is the PARENT | ||
| 349 | which is adopting TOKEN. This function should return TOKEN (or a copy of it) | ||
| 350 | which is then integrated into the revised token list.") | ||
| 351 | |||
| 352 | (defun semantic-adopt-external-members (tags) | ||
| 353 | "Rebuild TAGS so that externally defined members are regrouped. | ||
| 354 | Some languages such as C++ and CLOS permit the declaration of member | ||
| 355 | functions outside the definition of the class. It is easier to study | ||
| 356 | the structure of a program when such methods are grouped together | ||
| 357 | more logically. | ||
| 358 | |||
| 359 | This function uses `semantic-tag-external-member-p' to | ||
| 360 | determine when a potential child is an externally defined member. | ||
| 361 | |||
| 362 | Note: Applications which use this function must account for token | ||
| 363 | types which do not have a position, but have children which *do* | ||
| 364 | have positions. | ||
| 365 | |||
| 366 | Applications should use `semantic-mark-external-member-function' | ||
| 367 | to modify all tags which are found as externally defined to some | ||
| 368 | type. For example, changing the token type for generating extra | ||
| 369 | buckets with the bucket function." | ||
| 370 | (let ((parent-buckets nil) | ||
| 371 | (decent-list nil) | ||
| 372 | (out nil) | ||
| 373 | (tmp nil) | ||
| 374 | ) | ||
| 375 | ;; Rebuild the output list, stripping out all parented | ||
| 376 | ;; external entries | ||
| 377 | (while tags | ||
| 378 | (cond | ||
| 379 | ((setq tmp (semantic-tag-external-member-parent (car tags))) | ||
| 380 | (let ((tagcopy (semantic-tag-clone (car tags))) | ||
| 381 | (a (assoc tmp parent-buckets))) | ||
| 382 | (semantic--tag-put-property-no-side-effect tagcopy 'adopted t) | ||
| 383 | (if a | ||
| 384 | ;; If this parent is already in the list, append. | ||
| 385 | (setcdr (nthcdr (1- (length a)) a) (list tagcopy)) | ||
| 386 | ;; If not, prepend this new parent bucket into our list | ||
| 387 | (setq parent-buckets | ||
| 388 | (cons (cons tmp (list tagcopy)) parent-buckets))) | ||
| 389 | )) | ||
| 390 | ((eq (semantic-tag-class (car tags)) 'type) | ||
| 391 | ;; Types need to be rebuilt from scratch so we can add in new | ||
| 392 | ;; children to the child list. Only the top-level cons | ||
| 393 | ;; cells need to be duplicated so we can hack out the | ||
| 394 | ;; child list later. | ||
| 395 | (setq out (cons (semantic-tag-clone (car tags)) out)) | ||
| 396 | (setq decent-list (cons (car out) decent-list)) | ||
| 397 | ) | ||
| 398 | (t | ||
| 399 | ;; Otherwise, append this tag to our new output list. | ||
| 400 | (setq out (cons (car tags) out))) | ||
| 401 | ) | ||
| 402 | (setq tags (cdr tags))) | ||
| 403 | ;; Rescan out, by descending into all types and finding parents | ||
| 404 | ;; for all entries moved into the parent-buckets. | ||
| 405 | (while decent-list | ||
| 406 | (let* ((bucket (assoc (semantic-tag-name (car decent-list)) | ||
| 407 | parent-buckets)) | ||
| 408 | (bucketkids (cdr bucket))) | ||
| 409 | (when bucket | ||
| 410 | ;; Run our secondary marking function on the children | ||
| 411 | (if semantic-mark-external-member-function | ||
| 412 | (setq bucketkids | ||
| 413 | (mapcar (lambda (tok) | ||
| 414 | (funcall semantic-mark-external-member-function | ||
| 415 | tok (car decent-list))) | ||
| 416 | bucketkids))) | ||
| 417 | ;; We have some extra kids. Merge. | ||
| 418 | (semantic-tag-put-attribute | ||
| 419 | (car decent-list) :members | ||
| 420 | (append (semantic-tag-type-members (car decent-list)) | ||
| 421 | bucketkids)) | ||
| 422 | ;; Nuke the bucket label so it is not found again. | ||
| 423 | (setcar bucket nil)) | ||
| 424 | (setq decent-list | ||
| 425 | (append (cdr decent-list) | ||
| 426 | ;; get embedded types to scan and make copies | ||
| 427 | ;; of them. | ||
| 428 | (mapcar | ||
| 429 | (lambda (tok) (semantic-tag-clone tok)) | ||
| 430 | (semantic-find-tags-by-class 'type | ||
| 431 | (semantic-tag-type-members (car decent-list))))) | ||
| 432 | ))) | ||
| 433 | ;; Scan over all remaining lost external methods, and tack them | ||
| 434 | ;; onto the end. | ||
| 435 | (while parent-buckets | ||
| 436 | (if (car (car parent-buckets)) | ||
| 437 | (let* ((tmp (car parent-buckets)) | ||
| 438 | (fauxtag (semantic-tag-new-type | ||
| 439 | (car tmp) | ||
| 440 | semantic-orphaned-member-metaparent-type | ||
| 441 | nil ;; Part list | ||
| 442 | nil ;; parents (unknown) | ||
| 443 | )) | ||
| 444 | (bucketkids (cdr tmp))) | ||
| 445 | (semantic-tag-set-faux fauxtag) ;; properties | ||
| 446 | (if semantic-mark-external-member-function | ||
| 447 | (setq bucketkids | ||
| 448 | (mapcar (lambda (tok) | ||
| 449 | (funcall semantic-mark-external-member-function | ||
| 450 | tok fauxtag)) | ||
| 451 | bucketkids))) | ||
| 452 | (semantic-tag-put-attribute fauxtag :members bucketkids) | ||
| 453 | ;; We have a bunch of methods with no parent in this file. | ||
| 454 | ;; Create a meta-type to hold it. | ||
| 455 | (setq out (cons fauxtag out)) | ||
| 456 | )) | ||
| 457 | (setq parent-buckets (cdr parent-buckets))) | ||
| 458 | ;; Return the new list. | ||
| 459 | (nreverse out))) | ||
| 460 | |||
| 461 | |||
| 462 | ;;; External children | ||
| 463 | ;; | ||
| 464 | ;; In order to adopt external children, we need a few overload methods | ||
| 465 | ;; to enable the feature. | ||
| 466 | ;; | ||
| 467 | (define-overloadable-function semantic-tag-external-member-parent (tag) | ||
| 468 | "Return a parent for TAG when TAG is an external member. | ||
| 469 | TAG is an external member if it is defined at a toplevel and | ||
| 470 | has some sort of label defining a parent. The parent return will | ||
| 471 | be a string. | ||
| 472 | |||
| 473 | The default behavior, if not overridden with | ||
| 474 | `tag-member-parent' gets the 'parent extra | ||
| 475 | specifier of TAG. | ||
| 476 | |||
| 477 | If this function is overridden, use | ||
| 478 | `semantic-tag-external-member-parent-default' to also | ||
| 479 | include the default behavior, and merely extend your own." | ||
| 480 | ) | ||
| 481 | |||
| 482 | (defun semantic-tag-external-member-parent-default (tag) | ||
| 483 | "Return the name of TAGs parent only if TAG is not defined in it's parent." | ||
| 484 | ;; Use only the extra spec because a type has a parent which | ||
| 485 | ;; means something completely different. | ||
| 486 | (let ((tp (semantic-tag-get-attribute tag :parent))) | ||
| 487 | (when (stringp tp) | ||
| 488 | tp) | ||
| 489 | )) | ||
| 490 | |||
| 491 | (semantic-alias-obsolete 'semantic-nonterminal-external-member-parent | ||
| 492 | 'semantic-tag-external-member-parent) | ||
| 493 | |||
| 494 | (define-overloadable-function semantic-tag-external-member-p (parent tag) | ||
| 495 | "Return non-nil if PARENT is the parent of TAG. | ||
| 496 | TAG is an external member of PARENT when it is somehow tagged | ||
| 497 | as having PARENT as it's parent. | ||
| 498 | PARENT and TAG must both be semantic tags. | ||
| 499 | |||
| 500 | The default behavior, if not overridden with | ||
| 501 | `tag-external-member-p' is to match :parent attribute in | ||
| 502 | the name of TAG. | ||
| 503 | |||
| 504 | If this function is overridden, use | ||
| 505 | `semantic-tag-external-member-children-p-default' to also | ||
| 506 | include the default behavior, and merely extend your own." | ||
| 507 | ) | ||
| 508 | |||
| 509 | (defun semantic-tag-external-member-p-default (parent tag) | ||
| 510 | "Return non-nil if PARENT is the parent of TAG." | ||
| 511 | ;; Use only the extra spec because a type has a parent which | ||
| 512 | ;; means something completely different. | ||
| 513 | (let ((tp (semantic-tag-external-member-parent tag))) | ||
| 514 | (and (stringp tp) | ||
| 515 | (string= (semantic-tag-name parent) tp)) | ||
| 516 | )) | ||
| 517 | |||
| 518 | (semantic-alias-obsolete 'semantic-nonterminal-external-member-p | ||
| 519 | 'semantic-tag-external-member-p) | ||
| 520 | |||
| 521 | (define-overloadable-function semantic-tag-external-member-children (tag &optional usedb) | ||
| 522 | "Return the list of children which are not *in* TAG. | ||
| 523 | If optional argument USEDB is non-nil, then also search files in | ||
| 524 | the Semantic Database. If USEDB is a list of databases, search those | ||
| 525 | databases. | ||
| 526 | |||
| 527 | Children in this case are functions or types which are members of | ||
| 528 | TAG, such as the parts of a type, but which are not defined inside | ||
| 529 | the class. C++ and CLOS both permit methods of a class to be defined | ||
| 530 | outside the bounds of the class' definition. | ||
| 531 | |||
| 532 | The default behavior, if not overridden with | ||
| 533 | `tag-external-member-children' is to search using | ||
| 534 | `semantic-tag-external-member-p' in all top level definitions | ||
| 535 | with a parent of TAG. | ||
| 536 | |||
| 537 | If this function is overridden, use | ||
| 538 | `semantic-tag-external-member-children-default' to also | ||
| 539 | include the default behavior, and merely extend your own." | ||
| 540 | ) | ||
| 541 | |||
| 542 | (defun semantic-tag-external-member-children-default (tag &optional usedb) | ||
| 543 | "Return list of external children for TAG. | ||
| 544 | Optional argument USEDB specifies if the semantic database is used. | ||
| 545 | See `semantic-tag-external-member-children' for details." | ||
| 546 | (if (and usedb | ||
| 547 | (fboundp 'semanticdb-minor-mode-p) | ||
| 548 | (semanticdb-minor-mode-p)) | ||
| 549 | (let ((m (semanticdb-find-tags-external-children-of-type | ||
| 550 | (semantic-tag-name tag)))) | ||
| 551 | (if m (apply #'append (mapcar #'cdr m)))) | ||
| 552 | (semantic--find-tags-by-function | ||
| 553 | `(lambda (tok) | ||
| 554 | ;; This bit of annoying backquote forces the contents of | ||
| 555 | ;; tag into the generated lambda. | ||
| 556 | (semantic-tag-external-member-p ',tag tok)) | ||
| 557 | (current-buffer)) | ||
| 558 | )) | ||
| 559 | |||
| 560 | (define-overloadable-function semantic-tag-external-class (tag) | ||
| 561 | "Return a list of real tags that faux TAG might represent. | ||
| 562 | |||
| 563 | In some languages, a method can be defined on an object which is | ||
| 564 | not in the same file. In this case, | ||
| 565 | `semantic-adopt-external-members' will create a faux-tag. If it | ||
| 566 | is necessary to get the tag from which for faux TAG was most | ||
| 567 | likely derived, then this function is needed." | ||
| 568 | (unless (semantic-tag-faux-p tag) | ||
| 569 | (signal 'wrong-type-argument (list tag 'semantic-tag-faux-p))) | ||
| 570 | (:override) | ||
| 571 | ) | ||
| 572 | |||
| 573 | (defun semantic-tag-external-class-default (tag) | ||
| 574 | "Return a list of real tags that faux TAG might represent. | ||
| 575 | See `semantic-tag-external-class' for details." | ||
| 576 | (if (and (fboundp 'semanticdb-minor-mode-p) | ||
| 577 | (semanticdb-minor-mode-p)) | ||
| 578 | (let* ((semanticdb-search-system-databases nil) | ||
| 579 | (m (semanticdb-find-tags-by-class | ||
| 580 | (semantic-tag-class tag) | ||
| 581 | (semanticdb-find-tags-by-name (semantic-tag-name tag))))) | ||
| 582 | (semanticdb-strip-find-results m 'name)) | ||
| 583 | ;; Presumably, if the tag is faux, it is not local. | ||
| 584 | nil | ||
| 585 | )) | ||
| 586 | |||
| 587 | (semantic-alias-obsolete 'semantic-nonterminal-external-member-children | ||
| 588 | 'semantic-tag-external-member-children) | ||
| 589 | |||
| 590 | (provide 'semantic/sort) | ||
| 591 | |||
| 592 | ;;; semantic-sort.el ends here | ||