Mercurial > emacs
changeset 104417:6810f0d84270
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.
| author | Chong Yidong <cyd@stupidchicken.com> |
|---|---|
| date | Fri, 28 Aug 2009 19:18:35 +0000 |
| parents | c13af98da4d6 |
| children | 12884dc43872 |
| files | lisp/cedet/semantic/ctxt.el lisp/cedet/semantic/db-find.el lisp/cedet/semantic/db-ref.el lisp/cedet/semantic/find.el lisp/cedet/semantic/format.el lisp/cedet/semantic/sort.el |
| diffstat | 6 files changed, 4288 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/ctxt.el Fri Aug 28 19:18:35 2009 +0000 @@ -0,0 +1,613 @@ +;;; ctxt.el --- Context calculations for Semantic tools. + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, +;;; 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Semantic, as a tool, provides a nice list of searchable tags. +;; That information can provide some very accurate answers if the current +;; context of a position is known. +;; +;; This library provides the hooks needed for a language to specify how +;; the current context is calculated. +;; +(require 'semantic) +(eval-when-compile (require 'semantic/db)) + +;;; Code: +(defvar semantic-command-separation-character + ";" + "String which indicates the end of a command. +Used for identifying the end of a single command.") +(make-variable-buffer-local 'semantic-command-separation-character) + +(defvar semantic-function-argument-separation-character + "," + "String which indicates the end of an argument. +Used for identifying arguments to functions.") +(make-variable-buffer-local 'semantic-function-argument-separation-character) + +;;; Local Contexts +;; +;; These context are nested blocks of code, such as code in an +;; if clause +(define-overloadable-function semantic-up-context (&optional point bounds-type) + "Move point up one context from POINT. +Return non-nil if there are no more context levels. +Overloaded functions using `up-context' take no parameters. +BOUNDS-TYPE is a symbol representing a tag class to restrict +movement to. If this is nil, 'function is used. +This will find the smallest tag of that class (function, variable, +type, etc) and make sure non-nil is returned if you cannot +go up past the bounds of that tag." + (if point (goto-char point)) + (let ((nar (semantic-current-tag-of-class (or bounds-type 'function)))) + (if nar + (semantic-with-buffer-narrowed-to-tag nar (:override-with-args ())) + (when bounds-type + (error "No context of type %s to advance in" bounds-type)) + (:override-with-args ())))) + +(defun semantic-up-context-default () + "Move the point up and out one context level. +Works with languages that use parenthetical grouping." + ;; By default, assume that the language uses some form of parenthetical + ;; do dads for their context. + (condition-case nil + (progn + (up-list -1) + nil) + (error t))) + +(define-overloadable-function semantic-beginning-of-context (&optional point) + "Move POINT to the beginning of the current context. +Return non-nil if there is no upper context. +The default behavior uses `semantic-up-context'.") + +(defun semantic-beginning-of-context-default (&optional point) + "Move POINT to the beginning of the current context via parenthisis. +Return non-nil if there is no upper context." + (if point (goto-char point)) + (if (semantic-up-context) + t + (forward-char 1) + nil)) + +(define-overloadable-function semantic-end-of-context (&optional point) + "Move POINT to the end of the current context. +Return non-nil if there is no upper context. +Be default, this uses `semantic-up-context', and assumes parenthetical +block delimiters.") + +(defun semantic-end-of-context-default (&optional point) + "Move POINT to the end of the current context via parenthisis. +Return non-nil if there is no upper context." + (if point (goto-char point)) + (let ((start (point))) + (if (semantic-up-context) + t + ;; Go over the list, and back over the end parenthisis. + (condition-case nil + (progn + (forward-sexp 1) + (forward-char -1)) + (error + ;; If an error occurs, get the current tag from the cache, + ;; and just go to the end of that. Make sure we end up at least + ;; where start was so parse-region type calls work. + (if (semantic-current-tag) + (progn + (goto-char (semantic-tag-end (semantic-current-tag))) + (when (< (point) start) + (goto-char start))) + (goto-char start)) + t))) + nil)) + +(defun semantic-narrow-to-context () + "Narrow the buffer to the extent of the current context." + (let (b e) + (save-excursion + (if (semantic-beginning-of-context) + nil + (setq b (point)))) + (save-excursion + (if (semantic-end-of-context) + nil + (setq e (point)))) + (if (and b e) (narrow-to-region b e)))) + +(defmacro semantic-with-buffer-narrowed-to-context (&rest body) + "Execute BODY with the buffer narrowed to the current context." + `(save-restriction + (semantic-narrow-to-context) + ,@body)) +(put 'semantic-with-buffer-narrowed-to-context 'lisp-indent-function 0) +(add-hook 'edebug-setup-hook + (lambda () + (def-edebug-spec semantic-with-buffer-narrowed-to-context + (def-body)))) + +;;; Local Variables +;; +;; +(define-overloadable-function semantic-get-local-variables (&optional point) + "Get the local variables based on POINT's context. +Local variables are returned in Semantic tag format. +This can be overriden with `get-local-variables'." + ;; The working status is to let the parser work properly + (working-status-forms + (semantic-parser-working-message "Local") + "done" + (save-excursion + (if point (goto-char point)) + (let* ((semantic-working-type nil) + ;; Disable parsing messages + (working-status-dynamic-type nil) + (case-fold-search semantic-case-fold)) + (:override-with-args ()))))) + +(defun semantic-get-local-variables-default () + "Get local values from a specific context. +Uses the bovinator with the special top-symbol `bovine-inner-scope' +to collect tags, such as local variables or prototypes." + ;; This assumes a bovine parser. Make sure we don't do + ;; anything in that case. + (when (and semantic--parse-table (not (eq semantic--parse-table t)) + (not (semantic-parse-tree-unparseable-p))) + (let ((vars (semantic-get-cache-data 'get-local-variables))) + (if vars + (progn + ;;(message "Found cached vars.") + vars) + (let ((vars2 nil) + ;; We want nothing to do with funny syntaxing while doing this. + (semantic-unmatched-syntax-hook nil) + (start (point)) + (firstusefulstart nil) + ) + (while (not (semantic-up-context (point) 'function)) + (when (not vars) + (setq firstusefulstart (point))) + (save-excursion + (forward-char 1) + (setq vars + ;; Note to self: semantic-parse-region returns cooked + ;; but unlinked tags. File information is lost here + ;; and is added next. + (append (semantic-parse-region + (point) + (save-excursion (semantic-end-of-context) (point)) + 'bovine-inner-scope + nil + t) + vars)))) + ;; Modify the tags in place. + (setq vars2 vars) + (while vars2 + (semantic--tag-put-property (car vars2) :filename (buffer-file-name)) + (setq vars2 (cdr vars2))) + ;; Hash our value into the first context that produced useful results. + (when (and vars firstusefulstart) + (let ((end (save-excursion + (goto-char firstusefulstart) + (save-excursion + (unless (semantic-end-of-context) + (point)))))) + ;;(message "Caching values %d->%d." firstusefulstart end) + (semantic-cache-data-to-buffer + (current-buffer) firstusefulstart + (or end + ;; If the end-of-context fails, + ;; just use our cursor starting + ;; position. + start) + vars 'get-local-variables 'exit-cache-zone)) + ) + ;; Return our list. + vars))))) + +(define-overloadable-function semantic-get-local-arguments (&optional point) + "Get arguments (variables) from the current context at POINT. +Parameters are available if the point is in a function or method. +Return a list of tags unlinked from the originating buffer. +Arguments are obtained by overriding `get-local-arguments', or by the +default function `semantic-get-local-arguments-default'. This, must +return a list of tags, or a list of strings that will be converted to +tags." + (save-excursion + (if point (goto-char point)) + (let* ((case-fold-search semantic-case-fold) + (args (:override-with-args ())) + arg tags) + ;; Convert unsafe arguments to the right thing. + (while args + (setq arg (car args) + args (cdr args) + tags (cons (cond + ((semantic-tag-p arg) + ;; Return a copy of tag without overlay. + ;; The overlay is preserved. + (semantic-tag-copy arg nil t)) + ((stringp arg) + (semantic--tag-put-property + (semantic-tag-new-variable arg nil nil) + :filename (buffer-file-name))) + (t + (error "Unknown parameter element %S" arg))) + tags))) + (nreverse tags)))) + +(defun semantic-get-local-arguments-default () + "Get arguments (variables) from the current context. +Parameters are available if the point is in a function or method." + (let ((tag (semantic-current-tag))) + (if (and tag (semantic-tag-of-class-p tag 'function)) + (semantic-tag-function-arguments tag)))) + +(define-overloadable-function semantic-get-all-local-variables (&optional point) + "Get all local variables for this context, and parent contexts. +Local variables are returned in Semantic tag format. +Be default, this gets local variables, and local arguments. +Optional argument POINT is the location to start getting the variables from.") + +(defun semantic-get-all-local-variables-default (&optional point) + "Get all local variables for this context. +Optional argument POINT is the location to start getting the variables from. +That is a cons (LOCAL-ARGUMENTS . LOCAL-VARIABLES) where: + +- LOCAL-ARGUMENTS is collected by `semantic-get-local-arguments'. +- LOCAL-VARIABLES is collected by `semantic-get-local-variables'." + (save-excursion + (if point (goto-char point)) + (let ((case-fold-search semantic-case-fold)) + (append (semantic-get-local-arguments) + (semantic-get-local-variables))))) + +;;; Local context parsing +;; +;; Context parsing assumes a series of language independent commonalities. +;; These terms are used to describe those contexts: +;; +;; command - One command in the language. +;; symbol - The symbol the cursor is on. +;; This would include a series of type/field when applicable. +;; assignment - The variable currently being assigned to +;; function - The function call the cursor is on/in +;; argument - The index to the argument the cursor is on. +;; +;; +(define-overloadable-function semantic-end-of-command () + "Move to the end of the current command. +Be default, uses `semantic-command-separation-character'.") + +(defun semantic-end-of-command-default () + "Move to the end of the current command. +Depends on `semantic-command-separation-character' to find the +beginning and end of a command." + (semantic-with-buffer-narrowed-to-context + (let ((case-fold-search semantic-case-fold)) + (with-syntax-table semantic-lex-syntax-table + + (if (re-search-forward (regexp-quote semantic-command-separation-character) + nil t) + (forward-char -1) + ;; If there wasn't a command after this, we are the last + ;; command, and we are incomplete. + (goto-char (point-max))))))) + +(define-overloadable-function semantic-beginning-of-command () + "Move to the beginning of the current command. +Be default, uses `semantic-command-separation-character'.") + +(defun semantic-beginning-of-command-default () + "Move to the beginning of the current command. +Depends on `semantic-command-separation-character' to find the +beginning and end of a command." + (semantic-with-buffer-narrowed-to-context + (with-syntax-table semantic-lex-syntax-table + (let ((case-fold-search semantic-case-fold)) + (skip-chars-backward semantic-command-separation-character) + (if (re-search-backward (regexp-quote semantic-command-separation-character) + nil t) + (goto-char (match-end 0)) + ;; If there wasn't a command after this, we are the last + ;; command, and we are incomplete. + (goto-char (point-min))) + (skip-chars-forward " \t\n") + )))) + + +(defsubst semantic-point-at-beginning-of-command () + "Return the point at the beginning of the current command." + (save-excursion (semantic-beginning-of-command) (point))) + +(defsubst semantic-point-at-end-of-command () + "Return the point at the beginning of the current command." + (save-excursion (semantic-end-of-command) (point))) + +(defsubst semantic-narrow-to-command () + "Narrow the current buffer to the current command." + (narrow-to-region (semantic-point-at-beginning-of-command) + (semantic-point-at-end-of-command))) + +(defmacro semantic-with-buffer-narrowed-to-command (&rest body) + "Execute BODY with the buffer narrowed to the current command." + `(save-restriction + (semantic-narrow-to-command) + ,@body)) +(put 'semantic-with-buffer-narrowed-to-command 'lisp-indent-function 0) +(add-hook 'edebug-setup-hook + (lambda () + (def-edebug-spec semantic-with-buffer-narrowed-to-command + (def-body)))) + + +(define-overloadable-function semantic-ctxt-current-symbol (&optional point) + "Return the current symbol the cursor is on at POINT in a list. +The symbol includes all logical parts of a complex reference. +For example, in C the statement: + this.that().entry + +Would be object `this' calling method `that' which returns some structure +whose field `entry' is being reference. In this case, this function +would return the list: + ( \"this\" \"that\" \"entry\" )") + +(defun semantic-ctxt-current-symbol-default (&optional point) + "Return the current symbol the cursor is on at POINT in a list. +This will include a list of type/field names when applicable. +Depends on `semantic-type-relation-separator-character'." + (save-excursion + (if point (goto-char point)) + (let* ((fieldsep1 (mapconcat (lambda (a) (regexp-quote a)) + semantic-type-relation-separator-character + "\\|")) + ;; NOTE: The [ \n] expression below should used \\s-, but that + ;; doesn't work in C since \n means end-of-comment, and isn't + ;; really whitespace. + (fieldsep (concat "[ \t\n\r]*\\(" fieldsep1 "\\)[ \t\n\r]*\\(\\w\\|\\s_\\)")) + (case-fold-search semantic-case-fold) + (symlist nil) + end) + (with-syntax-table semantic-lex-syntax-table + (save-excursion + (cond ((looking-at "\\w\\|\\s_") + ;; In the middle of a symbol, move to the end. + (forward-sexp 1)) + ((looking-at fieldsep1) + ;; We are in a find spot.. do nothing. + nil + ) + ((save-excursion + (and (condition-case nil + (progn (forward-sexp -1) + (forward-sexp 1) + t) + (error nil)) + (looking-at fieldsep1))) + (setq symlist (list "")) + (forward-sexp -1) + ;; Skip array expressions. + (while (looking-at "\\s(") (forward-sexp -1)) + (forward-sexp 1)) + ) + ;; Set our end point. + (setq end (point)) + + ;; Now that we have gotten started, lets do the rest. + (condition-case nil + (while (save-excursion + (forward-char -1) + (looking-at "\\w\\|\\s_")) + ;; We have a symbol.. Do symbol things + (forward-sexp -1) + (setq symlist (cons (buffer-substring-no-properties (point) end) + symlist)) + ;; Skip the next syntactic expression backwards, then go forwards. + (let ((cp (point))) + (forward-sexp -1) + (forward-sexp 1) + ;; If we end up at the same place we started, we are at the + ;; beginning of a buffer, or narrowed to a command and + ;; have to stop. + (if (<= cp (point)) (error nil))) + (if (looking-at fieldsep) + (progn + (forward-sexp -1) + ;; Skip array expressions. + (while (and (looking-at "\\s(") (not (bobp))) + (forward-sexp -1)) + (forward-sexp 1) + (setq end (point))) + (error nil)) + ) + (error nil))) + symlist)))) + + +(define-overloadable-function semantic-ctxt-current-symbol-and-bounds (&optional point) + "Return the current symbol and bounds the cursor is on at POINT. +The symbol should be the same as returned by `semantic-ctxt-current-symbol'. +Return (PREFIX ENDSYM BOUNDS).") + +(defun semantic-ctxt-current-symbol-and-bounds-default (&optional point) + "Return the current symbol and bounds the cursor is on at POINT. +Uses `semantic-ctxt-current-symbol' to calculate the symbol. +Return (PREFIX ENDSYM BOUNDS)." + (save-excursion + (when point (goto-char (point))) + (let* ((prefix (semantic-ctxt-current-symbol)) + (endsym (car (reverse prefix))) + ;; @todo - Can we get this data direct from ctxt-current-symbol? + (bounds (save-excursion + (cond ((string= endsym "") + (cons (point) (point)) + ) + ((and prefix (looking-at endsym)) + (cons (point) (progn + (condition-case nil + (forward-sexp 1) + (error nil)) + (point)))) + (prefix + (condition-case nil + (cons (progn (forward-sexp -1) (point)) + (progn (forward-sexp 1) (point))) + (error nil))) + (t nil)))) + ) + (list prefix endsym bounds)))) + +(define-overloadable-function semantic-ctxt-current-assignment (&optional point) + "Return the current assignment near the cursor at POINT. +Return a list as per `semantic-ctxt-current-symbol'. +Return nil if there is nothing relevant.") + +(defun semantic-ctxt-current-assignment-default (&optional point) + "Return the current assignment near the cursor at POINT. +By default, assume that \"=\" indicates an assignment." + (if point (goto-char point)) + (let ((case-fold-search semantic-case-fold)) + (with-syntax-table semantic-lex-syntax-table + (condition-case nil + (semantic-with-buffer-narrowed-to-command + (save-excursion + (skip-chars-forward " \t=") + (condition-case nil (forward-char 1) (error nil)) + (re-search-backward "[^=]=\\([^=]\\|$\\)") + ;; We are at an equals sign. Go backwards a sexp, and + ;; we'll have the variable. Otherwise we threw an error + (forward-sexp -1) + (semantic-ctxt-current-symbol))) + (error nil))))) + +(define-overloadable-function semantic-ctxt-current-function (&optional point) + "Return the current function call the cursor is in at POINT. +The function returned is the one accepting the arguments that +the cursor is currently in. It will not return function symbol if the +cursor is on the text representing that function.") + +(defun semantic-ctxt-current-function-default (&optional point) + "Return the current function call the cursor is in at POINT. +The call will be identifed for C like langauges with the form + NAME ( args ... )" + (if point (goto-char point)) + (let ((case-fold-search semantic-case-fold)) + (with-syntax-table semantic-lex-syntax-table + (save-excursion + (semantic-up-context) + (when (looking-at "(") + (semantic-ctxt-current-symbol)))) + )) + +(define-overloadable-function semantic-ctxt-current-argument (&optional point) + "Return the index of the argument position the cursor is on at POINT.") + +(defun semantic-ctxt-current-argument-default (&optional point) + "Return the index of the argument the cursor is on at POINT. +Depends on `semantic-function-argument-separation-character'." + (if point (goto-char point)) + (let ((case-fold-search semantic-case-fold)) + (with-syntax-table semantic-lex-syntax-table + (when (semantic-ctxt-current-function) + (save-excursion + ;; Only get the current arg index if we are in function args. + (let ((p (point)) + (idx 1)) + (semantic-up-context) + (while (re-search-forward + (regexp-quote semantic-function-argument-separation-character) + p t) + (setq idx (1+ idx))) + idx)))))) + +(defun semantic-ctxt-current-thing () + "Calculate a thing identified by the current cursor position. +Calls previously defined `semantic-ctxt-current-...' calls until something +gets a match. See `semantic-ctxt-current-symbol', +`semantic-ctxt-current-function', and `semantic-ctxt-current-assignment' +for details on the return value." + (or (semantic-ctxt-current-symbol) + (semantic-ctxt-current-function) + (semantic-ctxt-current-assignment))) + +(define-overloadable-function semantic-ctxt-current-class-list (&optional point) + "Return a list of tag classes that are allowed at POINT. +If POINT is nil, the current buffer location is used. +For example, in Emacs Lisp, the symbol after a ( is most likely +a function. In a makefile, symbols after a : are rules, and symbols +after a $( are variables.") + +(defun semantic-ctxt-current-class-list-default (&optional point) + "Return a list of tag classes that are allowed at POINT. +Assume a functional typed language. Uses very simple rules." + (save-excursion + (if point (goto-char point)) + + (let ((tag (semantic-current-tag))) + (if tag + (cond ((semantic-tag-of-class-p tag 'function) + '(function variable type)) + ((or (semantic-tag-of-class-p tag 'type) + (semantic-tag-of-class-p tag 'variable)) + '(type)) + (t nil)) + '(type) + )))) + +(define-overloadable-function semantic-ctxt-current-mode (&optional point) + "Return the major mode active at POINT. +POINT defaults to the value of point in current buffer. +You should override this function in multiple mode buffers to +determine which major mode apply at point.") + +(defun semantic-ctxt-current-mode-default (&optional point) + "Return the major mode active at POINT. +POINT defaults to the value of point in current buffer. +This default implementation returns the current major mode." + major-mode) + +;;; Scoped Types +;; +;; Scoped types are types that the current code would have access to. +;; The come from the global namespace or from special commands such as "using" +(define-overloadable-function semantic-ctxt-scoped-types (&optional point) + "Return a list of type names currently in scope at POINT. +The return value can be a mixed list of either strings (names of +types that are in scope) or actual tags (type declared locally +that may or may not have a name.)") + +(defun semantic-ctxt-scoped-types-default (&optional point) + "Return a list of scoped types by name for the current context at POINT. +This is very different for various languages, and does nothing unless +overriden." + (if point (goto-char point)) + (let ((case-fold-search semantic-case-fold)) + ;; We need to look at TYPES within the bounds of locally parse arguments. + ;; C needs to find using statements and the like too. Bleh. + nil + )) + +(provide 'semantic/ctxt) + +;;; semantic-ctxt.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/db-find.el Fri Aug 28 19:18:35 2009 +0000 @@ -0,0 +1,1353 @@ +;;; db-find.el --- Searching through semantic databases. + +;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, +;;; 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: tags + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Databases of various forms can all be searched. +;; There are a few types of searches that can be done: +;; +;; Basic Name Search: +;; These searches scan a database table collection for tags based +;; on name. +;; +;; Basic Attribute Search: +;; These searches allow searching on specific attributes of tags, +;; such as name, type, or other attribute. +;; +;; Advanced Search: +;; These are searches that were needed to accomplish some +;; specialized tasks as discovered in utilities. Advanced searches +;; include matching methods defined outside some parent class. +;; +;; The reason for advanced searches are so that external +;; repositories such as the Emacs obarray, or java .class files can +;; quickly answer these needed questions without dumping the entire +;; symbol list into Emacs for additional refinement searches via +;; regular semanticdb search. +;; +;; How databases are decided upon is another important aspect of a +;; database search. When it comes to searching for a name, there are +;; these types of searches: +;; +;; Basic Search: +;; Basic search means that tags looking for a given name start +;; with a specific search path. Names are sought on that path +;; until it is empty or items on the path can no longer be found. +;; Use `semanticdb-dump-all-table-summary' to test this list. +;; Use `semanticdb-find-throttle-custom-list' to refine this list. +;; +;; Deep Search: +;; A deep search will search more than just the global namespace. +;; It will recurse into tags that contain more tags, and search +;; those too. +;; +;; Brute Search: +;; Brute search means that all tables in all databases in a given +;; project are searched. Brute searches are the search style as +;; written for semantic version 1.x. +;; +;; How does the search path work? +;; +;; A basic search starts with three parameters: +;; +;; (FINDME &optional PATH FIND-FILE-MATCH) +;; +;; FINDME is key to be searched for dependent on the type of search. +;; PATH is an indicator of which tables are to be searched. +;; FIND-FILE-MATCH indicates that any time a match is found, the +;; file associated with the tag should be read into a file. +;; +;; The PATH argument is then the most interesting argument. It can +;; have these values: +;; +;; nil - Take the current buffer, and use it's include list +;; buffer - Use that buffer's include list. +;; filename - Use that file's include list. If the file is not +;; in a buffer, see of there is a semanticdb table for it. If +;; not, read that file into a buffer. +;; tag - Get that tag's buffer of file file. See above. +;; table - Search that table, and it's include list. +;; +;; Search Results: +;; +;; Semanticdb returns the results in a specific format. There are a +;; series of routines for using those results, and results can be +;; passed in as a search-path for refinement searches with +;; semanticdb. Apropos for semanticdb.*find-result for more. +;; +;; Application: +;; +;; Here are applications where different searches are needed which +;; exist as of semantic 1.4.x +;; +;; eldoc - popup help +;; => Requires basic search using default path. (Header files ok) +;; tag jump - jump to a named tag +;; => Requires a brute search useing whole project. (Source files only) +;; completion - Completing symbol names in a smart way +;; => Basic search (headers ok) +;; type analysis - finding type definitions for variables & fcns +;; => Basic search (headers ok) +;; Class browser - organize types into some structure +;; => Brute search, or custom navigation. + +;; TODO: +;; During a search, load any unloaded DB files based on paths in the +;; current project. + +(require 'semantic/db) +(require 'semantic/db-ref) +(eval-when-compile + (require 'eieio) + ) + +;;; Code: +(defvar semanticdb-find-throttle-custom-list + '(repeat (radio (const 'local) + (const 'project) + (const 'unloaded) + (const 'system) + (const 'recursive) + (const 'omniscience))) + "Customization values for semanticdb find throttle. +See `semanticdb-find-throttle' for details.") + +(defcustom semanticdb-find-default-throttle + '(local project unloaded system recursive) + "The default throttle for `semanticdb-find' routines. +The throttle controls how detailed the list of database +tables is for a symbol lookup. The value is a list with +the following keys: + `file' - The file the search is being performed from. + This option is here for completeness only, and + is assumed to always be on. + `local' - Tables from the same local directory are included. + This includes files directly referenced by a file name + which might be in a different directory. + `project' - Tables from the same local project are included + If `project' is specified, then `local' is assumed. + `unloaded' - If a table is not in memory, load it. If it is not cached + on disk either, get the source, parse it, and create + the table. + `system' - Tables from system databases. These are specifically + tables from system header files, or language equivalent. + `recursive' - For include based searches, includes tables referenced + by included files. + `omniscience' - Included system databases which are omniscience, or + somehow know everything. Omniscience databases are found + in `semanticdb-project-system-databases'. + The Emacs Lisp system DB is an omniscience database." + :group 'semanticdb + :type semanticdb-find-throttle-custom-list) + +(defun semanticdb-find-throttle-active-p (access-type) + "Non-nil if ACCESS-TYPE is an active throttle type." + (or (memq access-type semanticdb-find-default-throttle) + (eq access-type 'file) + (and (eq access-type 'local) + (memq 'project semanticdb-find-default-throttle)) + )) + +;;; Index Class +;; +;; The find routines spend a lot of time looking stuff up. +;; Use this handy search index to cache data between searches. +;; This should allow searches to start running faster. +(defclass semanticdb-find-search-index (semanticdb-abstract-search-index) + ((include-path :initform nil + :documentation + "List of semanticdb tables from the include path.") + (type-cache :initform nil + :documentation + "Cache of all the data types accessible from this file. +Includes all types from all included files, merged namespaces, and +expunge duplicates.") + ) + "Concrete search index for `semanticdb-find'. +This class will cache data derived during various searches.") + +(defmethod semantic-reset ((idx semanticdb-find-search-index)) + "Reset the object IDX." + ;; Clear the include path. + (oset idx include-path nil) + (when (oref idx type-cache) + (semantic-reset (oref idx type-cache))) + ;; Clear the scope. Scope doesn't have the data it needs to track + ;; it's own reset. + (semantic-scope-reset-cache) + ) + +(defmethod semanticdb-synchronize ((idx semanticdb-find-search-index) + new-tags) + "Synchronize the search index IDX with some NEW-TAGS." + ;; Reset our parts. + (semantic-reset idx) + ;; Notify dependants by clearning their indicies. + (semanticdb-notify-references + (oref idx table) + (lambda (tab me) + (semantic-reset (semanticdb-get-table-index tab)))) + ) + +(defmethod semanticdb-partial-synchronize ((idx semanticdb-find-search-index) + new-tags) + "Synchronize the search index IDX with some changed NEW-TAGS." + ;; Only reset if include statements changed. + (if (semantic-find-tags-by-class 'include new-tags) + (progn + (semantic-reset idx) + ;; Notify dependants by clearning their indicies. + (semanticdb-notify-references + (oref idx table) + (lambda (tab me) + (semantic-reset (semanticdb-get-table-index tab)))) + ) + ;; Else, not an include, by just a type. + (when (oref idx type-cache) + (when (semanticdb-partial-synchronize (oref idx type-cache) new-tags) + ;; If the synchronize returns true, we need to notify. + ;; Notify dependants by clearning their indicies. + (semanticdb-notify-references + (oref idx table) + (lambda (tab me) + (let ((tab-idx (semanticdb-get-table-index tab))) + ;; Not a full reset? + (when (oref tab-idx type-cache) + (semanticdb-typecache-notify-reset + (oref tab-idx type-cache))) + ))) + )) + )) + + +;;; Path Translations +;; +;;; OVERLOAD Functions +;; +;; These routines needed to be overloaded by specific language modes. +;; They are needed for translating an INCLUDE tag into a semanticdb +;; TABLE object. +(define-overloadable-function semanticdb-find-translate-path (path brutish) + "Translate PATH into a list of semantic tables. +Path translation involves identifying the PATH input argument +in one of the following ways: + nil - Take the current buffer, and use it's include list + buffer - Use that buffer's include list. + filename - Use that file's include list. If the file is not + in a buffer, see of there is a semanticdb table for it. If + not, read that file into a buffer. + tag - Get that tag's buffer of file file. See above. + table - Search that table, and it's include list. + find result - Search the results of a previous find. + +In addition, once the base path is found, there is the possibility of +each added table adding yet more tables to the path, so this routine +can return a lengthy list. + +If argument BRUTISH is non-nil, then instead of using the include +list, use all tables found in the parent project of the table +identified by translating PATH. Such searches use brute force to +scan every available table. + +The return value is a list of objects of type `semanticdb-table' or +it's children. In the case of passing in a find result, the result +is returned unchanged. + +This routine uses `semanticdb-find-table-for-include' to translate +specific include tags into a semanticdb table. + +Note: When searching using a non-brutish method, the list of +included files will be cached between runs. Database-references +are used to track which files need to have their include lists +refreshed when things change. See `semanticdb-ref-test'. + +Note for overloading: If you opt to overload this function for your +major mode, and your routine takes a long time, be sure to call + + (semantic-throw-on-input 'your-symbol-here) + +so that it can be called from the idle work handler." + ) + +(defun semanticdb-find-translate-path-default (path brutish) + "Translate PATH into a list of semantic tables. +If BRUTISH is non nil, return all tables associated with PATH. +Default action as described in `semanticdb-find-translate-path'." + (if (semanticdb-find-results-p path) + ;; nil means perform the search over these results. + nil + (if brutish + (semanticdb-find-translate-path-brutish-default path) + (semanticdb-find-translate-path-includes-default path)))) + +(defun semanticdb-find-translate-path-brutish-default (path) + "Translate PATH into a list of semantic tables. +Default action as described in `semanticdb-find-translate-path'." + (let ((basedb + (cond ((null path) semanticdb-current-database) + ((semanticdb-table-p path) (oref path parent-db)) + (t (let ((tt (semantic-something-to-tag-table path))) + (save-excursion + ;; @todo - What does this DO ??!?! + (set-buffer (semantic-tag-buffer (car tt))) + semanticdb-current-database)))))) + (apply + #'nconc + (mapcar + (lambda (db) + (let ((tabs (semanticdb-get-database-tables db)) + (ret nil)) + ;; Only return tables of the same language (major-mode) + ;; as the current search environment. + (while tabs + + (semantic-throw-on-input 'translate-path-brutish) + + (if (semanticdb-equivalent-mode-for-search (car tabs) + (current-buffer)) + (setq ret (cons (car tabs) ret))) + (setq tabs (cdr tabs))) + ret)) + ;; FIXME: + ;; This should scan the current project directory list for all + ;; semanticdb files, perhaps handling proxies for them. + (semanticdb-current-database-list + (if basedb (oref basedb reference-directory) + default-directory)))) + )) + +(defun semanticdb-find-incomplete-cache-entries-p (cache) + "Are there any incomplete entries in CACHE?" + (let ((ans nil)) + (dolist (tab cache) + (when (and (semanticdb-table-child-p tab) + (not (number-or-marker-p (oref tab pointmax)))) + (setq ans t)) + ) + ans)) + +(defun semanticdb-find-need-cache-update-p (table) + "Non nil if the semanticdb TABLE cache needs to be updated." + ;; If we were passed in something related to a TABLE, + ;; do a caching lookup. + (let* ((index (semanticdb-get-table-index table)) + (cache (when index (oref index include-path))) + (incom (semanticdb-find-incomplete-cache-entries-p cache)) + (unl (semanticdb-find-throttle-active-p 'unloaded)) + ) + (if (and + cache ;; Must have a cache + (or + ;; If all entries are "full", or if 'unloaded + ;; OR + ;; is not in the throttle, it is ok to use the cache. + (not incom) (not unl) + )) + nil + ;;cache + ;; ELSE + ;; + ;; We need an update. + t)) + ) + +(defun semanticdb-find-translate-path-includes-default (path) + "Translate PATH into a list of semantic tables. +Default action as described in `semanticdb-find-translate-path'." + (let ((table (cond ((null path) + semanticdb-current-table) + ((bufferp path) + (semantic-buffer-local-value 'semanticdb-current-table path)) + ((and (stringp path) (file-exists-p path)) + (semanticdb-file-table-object path t)) + ((semanticdb-abstract-table-child-p path) + path) + (t nil)))) + (if table + ;; If we were passed in something related to a TABLE, + ;; do a caching lookup. + (let ((index (semanticdb-get-table-index table))) + (if (semanticdb-find-need-cache-update-p table) + ;; Lets go look up our indicies + (let ((ans (semanticdb-find-translate-path-includes--internal path))) + (oset index include-path ans) + ;; Once we have our new indicies set up, notify those + ;; who depend on us if we found something for them to + ;; depend on. + (when ans (semanticdb-refresh-references table)) + ans) + ;; ELSE + ;; + ;; Just return the cache. + (oref index include-path))) + ;; If we were passed in something like a tag list, or other boring + ;; searchable item, then instead do the regular thing without caching. + (semanticdb-find-translate-path-includes--internal path)))) + +(defvar semanticdb-find-lost-includes nil + "Include files that we cannot find associated with this buffer.") +(make-variable-buffer-local 'semanticdb-find-lost-includes) + +(defvar semanticdb-find-scanned-include-tags nil + "All include tags scanned, plus action taken on the tag. +Each entry is an alist: + (ACTION . TAG) +where ACTION is one of 'scanned, 'duplicate, 'lost. +and TAG is a clone of the include tag that was found.") +(make-variable-buffer-local 'semanticdb-find-scanned-include-tags) + +(defvar semanticdb-implied-include-tags nil + "Include tags implied for all files of a given mode. +Set this variable with `defvar-mode-local' for a particular mode so +that any symbols that exist for all files for that mode are included. + +Note: This could be used as a way to write a file in a langauge +to declare all the built-ins for that language.") + +(defun semanticdb-find-translate-path-includes--internal (path) + "Internal implementation of `semanticdb-find-translate-path-includes-default'. +This routine does not depend on the cache, but will always derive +a new path from the provided PATH." + (let ((includetags nil) + (curtable nil) + (matchedtables (list semanticdb-current-table)) + (matchedincludes nil) + (lostincludes nil) + (scannedincludes nil) + (incfname nil) + nexttable) + (cond ((null path) + (semantic-refresh-tags-safe) + (setq includetags (append + (semantic-find-tags-included (current-buffer)) + semanticdb-implied-include-tags) + curtable semanticdb-current-table + incfname (buffer-file-name)) + ) + ((semanticdb-table-p path) + (setq includetags (semantic-find-tags-included path) + curtable path + incfname (semanticdb-full-filename path)) + ) + ((bufferp path) + (save-excursion + (set-buffer path) + (semantic-refresh-tags-safe)) + (setq includetags (semantic-find-tags-included path) + curtable (save-excursion (set-buffer path) + semanticdb-current-table) + incfname (buffer-file-name path))) + (t + (setq includetags (semantic-find-tags-included path)) + (when includetags + ;; If we have some tags, derive a table from them. + ;; else we will do nothing, so the table is useless. + + ;; @todo - derive some tables + (message "Need to derive tables for %S in translate-path-includes--default." + path) + ))) + + ;; Make sure each found include tag has an originating file name associated + ;; with it. + (when incfname + (dolist (it includetags) + (semantic--tag-put-property it :filename incfname))) + + ;; Loop over all include tags adding to matchedtables + (while includetags + (semantic-throw-on-input 'semantic-find-translate-path-includes-default) + + ;; If we've seen this include string before, lets skip it. + (if (member (semantic-tag-name (car includetags)) matchedincludes) + (progn + (setq nexttable nil) + (push (cons 'duplicate (semantic-tag-clone (car includetags))) + scannedincludes) + ) + (setq nexttable (semanticdb-find-table-for-include (car includetags) curtable)) + (when (not nexttable) + ;; Save the lost include. + (push (car includetags) lostincludes) + (push (cons 'lost (semantic-tag-clone (car includetags))) + scannedincludes) + ) + ) + + ;; Push the include file, so if we can't find it, we only + ;; can't find it once. + (push (semantic-tag-name (car includetags)) matchedincludes) + + ;; (message "Scanning %s" (semantic-tag-name (car includetags))) + (when (and nexttable + (not (memq nexttable matchedtables)) + (semanticdb-equivalent-mode-for-search nexttable + (current-buffer)) + ) + ;; Add to list of tables + (push nexttable matchedtables) + + ;; Queue new includes to list + (if (semanticdb-find-throttle-active-p 'recursive) + ;; @todo - recursive includes need to have the originating + ;; buffer's location added to the path. + (let ((newtags + (cond + ((semanticdb-table-p nexttable) + (semanticdb-refresh-table nexttable) + ;; Use the method directly, or we will recurse + ;; into ourselves here. + (semanticdb-find-tags-by-class-method + nexttable 'include)) + (t ;; @todo - is this ever possible??? + (message "semanticdb-ftp - how did you do that?") + (semantic-find-tags-included + (semanticdb-get-tags nexttable))) + )) + (newincfname (semanticdb-full-filename nexttable)) + ) + + (push (cons 'scanned (semantic-tag-clone (car includetags))) + scannedincludes) + + ;; Setup new tags so we know where they are. + (dolist (it newtags) + (semantic--tag-put-property it :filename + newincfname)) + + (setq includetags (nconc includetags newtags))) + ;; ELSE - not recursive throttle + (push (cons 'scanned-no-recurse + (semantic-tag-clone (car includetags))) + scannedincludes) + ) + ) + (setq includetags (cdr includetags))) + + (setq semanticdb-find-lost-includes lostincludes) + (setq semanticdb-find-scanned-include-tags (reverse scannedincludes)) + + ;; Find all the omniscient databases for this major mode, and + ;; add them if needed + (when (and (semanticdb-find-throttle-active-p 'omniscience) + semanticdb-search-system-databases) + ;; We can append any mode-specific omniscience databases into + ;; our search list here. + (let ((systemdb semanticdb-project-system-databases) + (ans nil)) + (while systemdb + (setq ans (semanticdb-file-table + (car systemdb) + ;; I would expect most omniscient to return the same + ;; thing reguardless of filename, but we may have + ;; one that can return a table of all things the + ;; current file needs. + (buffer-file-name (current-buffer)))) + (when (not (memq ans matchedtables)) + (setq matchedtables (cons ans matchedtables))) + (setq systemdb (cdr systemdb)))) + ) + (nreverse matchedtables))) + +(define-overloadable-function semanticdb-find-load-unloaded (filename) + "Create a database table for FILENAME if it hasn't been parsed yet. +Assumes that FILENAME exists as a source file. +Assumes that a preexisting table does not exist, even if it +isn't in memory yet." + (if (semanticdb-find-throttle-active-p 'unloaded) + (:override) + (semanticdb-file-table-object filename t))) + +(defun semanticdb-find-load-unloaded-default (filename) + "Load an unloaded file in FILENAME using the default semanticdb loader." + (semanticdb-file-table-object filename)) + +(define-overloadable-function semanticdb-find-table-for-include (includetag &optional table) + "For a single INCLUDETAG found in TABLE, find a `semanticdb-table' object +INCLUDETAG is a semantic TAG of class 'include. +TABLE is a semanticdb table that identifies where INCLUDETAG came from. +TABLE is optional if INCLUDETAG has an overlay of :filename attribute." + ) + +(defun semanticdb-find-table-for-include-default (includetag &optional table) + "Default implementation of `semanticdb-find-table-for-include'. +Uses `semanticdb-current-database-list' as the search path. +INCLUDETAG and TABLE are documented in `semanticdb-find-table-for-include'. +Included databases are filtered based on `semanticdb-find-default-throttle'." + (if (not (eq (semantic-tag-class includetag) 'include)) + (signal 'wrong-type-argument (list includetag 'include))) + + (let ((name + ;; Note, some languages (like Emacs or Java) use include tag names + ;; that don't represent files! We want to have file names. + (semantic-tag-include-filename includetag)) + (originfiledir nil) + (roots nil) + (tmp nil) + (ans nil)) + + ;; INCLUDETAG should have some way to reference where it came + ;; from! If not, TABLE should provide the way. Each time we + ;; look up a tag, we may need to find it in some relative way + ;; and must set our current buffer eto the origin of includetag + ;; or nothing may work. + (setq originfiledir + (cond ((semantic-tag-file-name includetag) + ;; A tag may have a buffer, or a :filename property. + (file-name-directory (semantic-tag-file-name includetag))) + (table + (file-name-directory (semanticdb-full-filename table))) + (t + ;; @todo - what to do here? Throw an error maybe + ;; and fix usage bugs? + default-directory))) + + (cond + ;; Step 1: Relative path name + ;; + ;; If the name is relative, then it should be findable as relative + ;; to the source file that this tag originated in, and be fast. + ;; + ((and (semanticdb-find-throttle-active-p 'local) + (file-exists-p (expand-file-name name originfiledir))) + + (setq ans (semanticdb-find-load-unloaded + (expand-file-name name originfiledir))) + ) + ;; Step 2: System or Project level includes + ;; + ((or + ;; First, if it a system include, we can investigate that tags + ;; dependency file + (and (semanticdb-find-throttle-active-p 'system) + + ;; Sadly, not all languages make this distinction. + ;;(semantic-tag-include-system-p includetag) + + ;; Here, we get local and system files. + (setq tmp (semantic-dependency-tag-file includetag)) + ) + ;; Second, project files are active, we and we have EDE, + ;; we can find it using the same tool. + (and (semanticdb-find-throttle-active-p 'project) + ;; Make sure EDE is available, and we have a project + (featurep 'ede) (ede-current-project originfiledir) + ;; The EDE query is hidden in this call. + (setq tmp (semantic-dependency-tag-file includetag)) + ) + ) + (setq ans (semanticdb-find-load-unloaded tmp)) + ) + ;; Somewhere in our project hierarchy + ;; + ;; Remember: Roots includes system databases which can create + ;; specialized tables we can search. + ;; + ;; NOTE: Not used if EDE is active! + ((and (semanticdb-find-throttle-active-p 'project) + ;; And dont do this if it is a system include. Not supported by all languages, + ;; but when it is, this is a nice fast way to skip this step. + (not (semantic-tag-include-system-p includetag)) + ;; Don't do this if we have an EDE project. + (not (and (featurep 'ede) + ;; Note: We don't use originfiledir here because + ;; we want to know about the source file we are + ;; starting from. + (ede-current-project))) + ) + + (setq roots (semanticdb-current-database-list)) + + (while (and (not ans) roots) + (let* ((ref (if (slot-boundp (car roots) 'reference-directory) + (oref (car roots) reference-directory))) + (fname (cond ((null ref) nil) + ((file-exists-p (expand-file-name name ref)) + (expand-file-name name ref)) + ((file-exists-p (expand-file-name (file-name-nondirectory name) ref)) + (expand-file-name (file-name-nondirectory name) ref))))) + (when (and ref fname) + ;; There is an actual file. Grab it. + (setq ans (semanticdb-find-load-unloaded fname))) + + ;; ELSE + ;; + ;; NOTE: We used to look up omniscient databases here, but that + ;; is now handled one layer up. + ;; + ;; Missing: a database that knows where missing files are. Hmm. + ;; perhaps I need an override function for that? + + ) + + (setq roots (cdr roots)))) + ) + ans)) + + +;;; Perform interactive tests on the path/search mechanisms. +;; +(defun semanticdb-find-test-translate-path (&optional arg) + "Call and output results of `semanticdb-find-translate-path'. +With ARG non-nil, specify a BRUTISH translation. +See `semanticdb-find-default-throttle' and `semanticdb-project-roots' +for details on how this list is derived." + (interactive "P") + (semantic-fetch-tags) + (require 'data-debug) + (let ((start (current-time)) + (p (semanticdb-find-translate-path nil arg)) + (end (current-time)) + ) + (data-debug-new-buffer "*SEMANTICDB FTP ADEBUG*") + (message "Search of tags took %.2f seconds." + (semantic-elapsed-time start end)) + + (data-debug-insert-stuff-list p "*"))) + +(defun semanticdb-find-test-translate-path-no-loading (&optional arg) + "Call and output results of `semanticdb-find-translate-path'. +With ARG non-nil, specify a BRUTISH translation. +See `semanticdb-find-default-throttle' and `semanticdb-project-roots' +for details on how this list is derived." + (interactive "P") + (semantic-fetch-tags) + (require 'data-debug) + (let* ((semanticdb-find-default-throttle + (if (featurep 'semanticdb-find) + (remq 'unloaded semanticdb-find-default-throttle) + nil)) + (start (current-time)) + (p (semanticdb-find-translate-path nil arg)) + (end (current-time)) + ) + (data-debug-new-buffer "*SEMANTICDB FTP ADEBUG*") + (message "Search of tags took %.2f seconds." + (semantic-elapsed-time start end)) + + (data-debug-insert-stuff-list p "*"))) + +(defun semanticdb-find-adebug-lost-includes () + "Translate the current path, then display the lost includes. +Examines the variable `semanticdb-find-lost-includes'." + (interactive) + (require 'data-debug) + (semanticdb-find-translate-path nil nil) + (let ((lost semanticdb-find-lost-includes) + ) + + (if (not lost) + (message "There are no unknown includes for %s" + (buffer-name)) + + (data-debug-new-buffer "*SEMANTICDB lost-includes ADEBUG*") + (data-debug-insert-tag-list lost "*") + ))) + +(defun semanticdb-find-adebug-insert-scanned-tag-cons (consdata prefix prebuttontext) + "Insert a button representing scanned include CONSDATA. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the overlay button." + (let* ((start (point)) + (end nil) + (mode (car consdata)) + (tag (cdr consdata)) + (name (semantic-tag-name tag)) + (file (semantic-tag-file-name tag)) + (str1 (format "%S %s" mode name)) + (str2 (format " : %s" file)) + (tip nil)) + (insert prefix prebuttontext str1) + (setq end (point)) + (insert str2) + (put-text-property start end 'face + (cond ((eq mode 'scanned) + 'font-lock-function-name-face) + ((eq mode 'duplicate) + 'font-lock-comment-face) + ((eq mode 'lost) + 'font-lock-variable-name-face) + ((eq mode 'scanned-no-recurse) + 'font-lock-type-face))) + (put-text-property start end 'ddebug (cdr consdata)) + (put-text-property start end 'ddebug-indent(length prefix)) + (put-text-property start end 'ddebug-prefix prefix) + (put-text-property start end 'help-echo tip) + (put-text-property start end 'ddebug-function + 'data-debug-insert-tag-parts-from-point) + (insert "\n") + ) + ) + +(defun semanticdb-find-adebug-scanned-includes () + "Translate the current path, then display the lost includes. +Examines the variable `semanticdb-find-lost-includes'." + (interactive) + (require 'data-debug) + (semanticdb-find-translate-path nil nil) + (let ((scanned semanticdb-find-scanned-include-tags) + (data-debug-thing-alist + (cons + '((lambda (thing) (and (consp thing) + (symbolp (car thing)) + (memq (car thing) + '(scanned scanned-no-recurse + lost duplicate)))) + . semanticdb-find-adebug-insert-scanned-tag-cons) + data-debug-thing-alist)) + ) + + (if (not scanned) + (message "There are no includes scanned %s" + (buffer-name)) + + (data-debug-new-buffer "*SEMANTICDB scanned-includes ADEBUG*") + (data-debug-insert-stuff-list scanned "*") + ))) + +;;; FIND results and edebug +;; +(eval-after-load "cedet-edebug" + '(progn + (cedet-edebug-add-print-override + '(semanticdb-find-results-p object) + '(semanticdb-find-result-prin1-to-string object) ) + )) + + + +;;; API Functions +;; +;; Once you have a search result, use these routines to operate +;; on the search results at a higher level + +(defun semanticdb-strip-find-results (results &optional find-file-match) + "Strip a semanticdb search RESULTS to exclude objects. +This makes it appear more like the results of a `semantic-find-' call. +Optional FIND-FILE-MATCH loads all files associated with RESULTS +into buffers. This has the side effect of enabling `semantic-tag-buffer' to +return a value. +If FIND-FILE-MATCH is 'name, then only the filename is stored +in each tag instead of loading each file into a buffer. +If the input RESULTS are not going to be used again, and if +FIND-FILE-MATCH is nil, you can use `semanticdb-fast-strip-find-results' +instead." + (if find-file-match + ;; Load all files associated with RESULTS. + (let ((tmp results) + (output nil)) + (while tmp + (let ((tab (car (car tmp))) + (tags (cdr (car tmp)))) + (dolist (T tags) + ;; Normilzation gives specialty database tables a chance + ;; to convert into a more stable tag format. + (let* ((norm (semanticdb-normalize-one-tag tab T)) + (ntab (car norm)) + (ntag (cdr norm)) + (nametable ntab)) + + ;; If it didn't normalize, use what we had. + (if (not norm) + (setq nametable tab) + (setq output (append output (list ntag)))) + + ;; Find-file-match allows a tool to make sure the tag is + ;; 'live', somewhere in a buffer. + (cond ((eq find-file-match 'name) + (let ((f (semanticdb-full-filename nametable))) + (semantic--tag-put-property ntag :filename f))) + ((and find-file-match ntab) + (semanticdb-get-buffer ntab)) + ) + )) + ) + (setq tmp (cdr tmp))) + output) + ;; @todo - I could use nconc, but I don't know what the caller may do with + ;; RESULTS after this is called. Right now semantic-complete will + ;; recycling the input after calling this routine. + (apply #'append (mapcar #'cdr results)))) + +(defun semanticdb-fast-strip-find-results (results) + "Destructively strip a semanticdb search RESULTS to exclude objects. +This makes it appear more like the results of a `semantic-find-' call. +This is like `semanticdb-strip-find-results', except the input list RESULTS +will be changed." + (apply #'nconc (mapcar #'cdr results))) + +(defun semanticdb-find-results-p (resultp) + "Non-nil if RESULTP is in the form of a semanticdb search result. +This query only really tests the first entry in the list that is RESULTP, +but should be good enough for debugging assertions." + (and (listp resultp) + (listp (car resultp)) + (semanticdb-abstract-table-child-p (car (car resultp))) + (or (semantic-tag-p (car (cdr (car resultp)))) + (null (car (cdr (car resultp))))))) + +(defun semanticdb-find-result-prin1-to-string (result) + "Presuming RESULT satisfies `semanticdb-find-results-p', provide a short PRIN1 output." + (if (< (length result) 2) + (concat "#<FIND RESULT " + (mapconcat (lambda (a) + (concat "(" (object-name (car a) ) " . " + "#<TAG LIST " (number-to-string (length (cdr a))) ">)")) + result + " ") + ">") + ;; Longer results should have an abreviated form. + (format "#<FIND RESULT %d TAGS in %d FILES>" + (semanticdb-find-result-length result) + (length result)))) + +(defun semanticdb-find-result-with-nil-p (resultp) + "Non-nil of RESULTP is in the form of a semanticdb search result. +nil is a valid value where a TABLE usually is, but only if the TAG +results include overlays. +This query only really tests the first entry in the list that is RESULTP, +but should be good enough for debugging assertions." + (and (listp resultp) + (listp (car resultp)) + (let ((tag-to-test (car-safe (cdr (car resultp))))) + (or (and (semanticdb-abstract-table-child-p (car (car resultp))) + (or (semantic-tag-p tag-to-test) + (null tag-to-test))) + (and (null (car (car resultp))) + (or (semantic-tag-with-position-p tag-to-test) + (null tag-to-test)))) + ))) + +(defun semanticdb-find-result-length (result) + "Number of tags found in RESULT." + (let ((count 0)) + (mapc (lambda (onetable) + (setq count (+ count (1- (length onetable))))) + result) + count)) + +(defun semanticdb-find-result-nth (result n) + "In RESULT, return the Nth search result. +This is a 0 based search result, with the first match being element 0. + +The returned value is a cons cell: (TAG . TABLE) where TAG +is the tag at the Nth position. TABLE is the semanticdb table where +the TAG was found. Sometimes TABLE can be nil." + (let ((ans nil) + (anstable nil)) + ;; Loop over each single table hit. + (while (and (not ans) result) + ;; For each table result, get local length, and modify + ;; N to be that much less. + (let ((ll (length (cdr (car result))))) ;; local length + (if (> ll n) + ;; We have a local match. + (setq ans (nth n (cdr (car result))) + anstable (car (car result))) + ;; More to go. Decrement N. + (setq n (- n ll)))) + ;; Keep moving. + (setq result (cdr result))) + (cons ans anstable))) + +(defun semanticdb-find-result-test (result) + "Test RESULT by accessing all the tags in the list." + (if (not (semanticdb-find-results-p result)) + (error "Does not pass `semanticdb-find-results-p.\n")) + (let ((len (semanticdb-find-result-length result)) + (i 0)) + (while (< i len) + (let ((tag (semanticdb-find-result-nth result i))) + (if (not (semantic-tag-p (car tag))) + (error "%d entry is not a tag" i))) + (setq i (1+ i))))) + +(defun semanticdb-find-result-nth-in-buffer (result n) + "In RESULT, return the Nth search result. +Like `semanticdb-find-result-nth', except that only the TAG +is returned, and the buffer it is found it will be made current. +If the result tag has no position information, the originating buffer +is still made current." + (let* ((ret (semanticdb-find-result-nth result n)) + (ans (car ret)) + (anstable (cdr ret))) + ;; If we have a hit, double-check the find-file + ;; entry. If the file must be loaded, then gat that table's + ;; source file into a buffer. + + (if anstable + (let ((norm (semanticdb-normalize-one-tag anstable ans))) + (when norm + ;; The normalized tags can now be found based on that + ;; tags table. + (semanticdb-set-buffer (car norm)) + ;; Now reset ans + (setq ans (cdr norm)) + )) + ) + ;; Return the tag. + ans)) + +(defun semanticdb-find-result-mapc (fcn result) + "Apply FCN to each element of find RESULT for side-effects only. +FCN takes two arguments. The first is a TAG, and the +second is a DB from wence TAG originated. +Returns result." + (mapc (lambda (sublst) + (mapc (lambda (tag) + (funcall fcn tag (car sublst))) + (cdr sublst))) + result) + result) + +;;; Search Logging +;; +;; Basic logging to see what the search routines are doing. +(defvar semanticdb-find-log-flag nil + "Non-nil means log the process of searches.") + +(defvar semanticdb-find-log-buffer-name "*SemanticDB Find Log*" + "The name of the logging buffer.") + +(defun semanticdb-find-toggle-logging () + "Toggle sematnicdb logging." + (interactive) + (setq semanticdb-find-log-flag (null semanticdb-find-log-flag)) + (message "Semanticdb find logging is %sabled" + (if semanticdb-find-log-flag "en" "dis"))) + +(defun semanticdb-reset-log () + "Reset the log buffer." + (interactive) + (when semanticdb-find-log-flag + (save-excursion + (set-buffer (get-buffer-create semanticdb-find-log-buffer-name)) + (erase-buffer) + ))) + +(defun semanticdb-find-log-move-to-end () + "Move to the end of the semantic log." + (let ((cb (current-buffer)) + (cw (selected-window))) + (unwind-protect + (progn + (set-buffer semanticdb-find-log-buffer-name) + (if (get-buffer-window (current-buffer) 'visible) + (select-window (get-buffer-window (current-buffer) 'visible))) + (goto-char (point-max))) + (if cw (select-window cw)) + (set-buffer cb)))) + +(defun semanticdb-find-log-new-search (forwhat) + "Start a new search FORWHAT." + (when semanticdb-find-log-flag + (save-excursion + (set-buffer (get-buffer-create semanticdb-find-log-buffer-name)) + (insert (format "New Search: %S\n" forwhat)) + ) + (semanticdb-find-log-move-to-end))) + +(defun semanticdb-find-log-activity (table result) + "Log that TABLE has been searched and RESULT was found." + (when semanticdb-find-log-flag + (save-excursion + (set-buffer semanticdb-find-log-buffer-name) + (insert "Table: " (object-print table) + " Result: " (int-to-string (length result)) " tags" + "\n") + ) + (semanticdb-find-log-move-to-end))) + +;;; Semanticdb find API functions +;; +;; These are the routines actually used to perform searches. +;; +(defun semanticdb-find-tags-collector (function &optional path find-file-match + brutish) + "Collect all tags returned by FUNCTION over PATH. +The FUNCTION must take two arguments. The first is TABLE, +which is a semanticdb table containing tags. The second argument +to FUNCTION is TAGS. TAGS may be a list of tags. If TAGS is non-nil, then +FUNCTION should search the TAG list, not through TABLE. + +See `semanticdb-find-translate-path' for details on PATH. +FIND-FILE-MATCH indicates that any time a match is found, the file +associated with that tag should be loaded into a buffer. + +Note: You should leave FIND-FILE-MATCH as nil. It is far more +efficient to take the results from any search and use +`semanticdb-strip-find-results' instead. This argument is here +for backward compatibility. + +If optional argument BRUTISH is non-nil, then ignore include statements, +and search all tables in this project tree." + (let (found match) + (save-excursion + ;; If path is a buffer, set ourselves up in that buffer + ;; so that the override methods work correctly. + (when (bufferp path) (set-buffer path)) + (if (semanticdb-find-results-p path) + ;; When we get find results, loop over that. + (dolist (tableandtags path) + (semantic-throw-on-input 'semantic-find-translate-path) + ;; If FIND-FILE-MATCH is non-nil, skip tables of class + ;; `semanticdb-search-results-table', since those are system + ;; databases and not associated with a file. + (unless (and find-file-match + (obj-of-class-p + (car tableandtags) semanticdb-search-results-table)) + (when (setq match (funcall function + (car tableandtags) (cdr tableandtags))) + (when find-file-match + (save-excursion (semanticdb-set-buffer (car tableandtags)))) + (push (cons (car tableandtags) match) found))) + ) + ;; Only log searches across data bases. + (semanticdb-find-log-new-search nil) + ;; If we get something else, scan the list of tables resulting + ;; from translating it into a list of objects. + (dolist (table (semanticdb-find-translate-path path brutish)) + (semantic-throw-on-input 'semantic-find-translate-path) + ;; If FIND-FILE-MATCH is non-nil, skip tables of class + ;; `semanticdb-search-results-table', since those are system + ;; databases and not associated with a file. + (unless (and find-file-match + (obj-of-class-p table semanticdb-search-results-table)) + (when (and table (setq match (funcall function table nil))) + (semanticdb-find-log-activity table match) + (when find-file-match + (save-excursion (semanticdb-set-buffer table))) + (push (cons table match) found)))))) + ;; At this point, FOUND has had items pushed onto it. + ;; This means items are being returned in REVERSE order + ;; of the tables searched, so if you just get th CAR, then + ;; too-bad, you may have some system-tag that has no + ;; buffer associated with it. + + ;; It must be reversed. + (nreverse found))) + +(defun semanticdb-find-tags-by-name (name &optional path find-file-match) + "Search for all tags matching NAME on PATH. +See `semanticdb-find-translate-path' for details on PATH. +FIND-FILE-MATCH indicates that any time a match is found, the file +associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-find-tags-by-name-method table name tags)) + path find-file-match)) + +(defun semanticdb-find-tags-by-name-regexp (regexp &optional path find-file-match) + "Search for all tags matching REGEXP on PATH. +See `semanticdb-find-translate-path' for details on PATH. +FIND-FILE-MATCH indicates that any time a match is found, the file +associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-find-tags-by-name-regexp-method table regexp tags)) + path find-file-match)) + +(defun semanticdb-find-tags-for-completion (prefix &optional path find-file-match) + "Search for all tags matching PREFIX on PATH. +See `semanticdb-find-translate-path' for details on PATH. +FIND-FILE-MATCH indicates that any time a match is found, the file +associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-find-tags-for-completion-method table prefix tags)) + path find-file-match)) + +(defun semanticdb-find-tags-by-class (class &optional path find-file-match) + "Search for all tags of CLASS on PATH. +See `semanticdb-find-translate-path' for details on PATH. +FIND-FILE-MATCH indicates that any time a match is found, the file +associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-find-tags-by-class-method table class tags)) + path find-file-match)) + +;;; Deep Searches +(defun semanticdb-deep-find-tags-by-name (name &optional path find-file-match) + "Search for all tags matching NAME on PATH. +Search also in all components of top level tags founds. +See `semanticdb-find-translate-path' for details on PATH. +FIND-FILE-MATCH indicates that any time a match is found, the file +associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-deep-find-tags-by-name-method table name tags)) + path find-file-match)) + +(defun semanticdb-deep-find-tags-by-name-regexp (regexp &optional path find-file-match) + "Search for all tags matching REGEXP on PATH. +Search also in all components of top level tags founds. +See `semanticdb-find-translate-path' for details on PATH. +FIND-FILE-MATCH indicates that any time a match is found, the file +associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-deep-find-tags-by-name-regexp-method table regexp tags)) + path find-file-match)) + +(defun semanticdb-deep-find-tags-for-completion (prefix &optional path find-file-match) + "Search for all tags matching PREFIX on PATH. +Search also in all components of top level tags founds. +See `semanticdb-find-translate-path' for details on PATH. +FIND-FILE-MATCH indicates that any time a match is found, the file +associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-deep-find-tags-for-completion-method table prefix tags)) + path find-file-match)) + +;;; Brutish Search Routines +(defun semanticdb-brute-deep-find-tags-by-name (name &optional path find-file-match) + "Search for all tags matching NAME on PATH. +See `semanticdb-find-translate-path' for details on PATH. +The argument BRUTISH will be set so that searching includes all tables +in the current project. +FIND-FILE-MATCH indicates that any time a matchi is found, the file +associated wit that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-deep-find-tags-by-name-method table name tags)) + path find-file-match t)) + +(defun semanticdb-brute-deep-find-tags-for-completion (prefix &optional path find-file-match) + "Search for all tags matching PREFIX on PATH. +See `semanticdb-find-translate-path' for details on PATH. +The argument BRUTISH will be set so that searching includes all tables +in the current project. +FIND-FILE-MATCH indicates that any time a matchi is found, the file +associated wit that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-deep-find-tags-for-completion-method table prefix tags)) + path find-file-match t)) + +(defun semanticdb-brute-find-tags-by-class (class &optional path find-file-match) + "Search for all tags of CLASS on PATH. +See `semanticdb-find-translate-path' for details on PATH. +The argument BRUTISH will be set so that searching includes all tables +in the current project. +FIND-FILE-MATCH indicates that any time a match is found, the file +associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-find-tags-by-class-method table class tags)) + path find-file-match t)) + +;;; Specialty Search Routines +(defun semanticdb-find-tags-external-children-of-type + (type &optional path find-file-match) + "Search for all tags defined outside of TYPE w/ TYPE as a parent. +See `semanticdb-find-translate-path' for details on PATH. +FIND-FILE-MATCH indicates that any time a match is found, the file +associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-find-tags-external-children-of-type-method table type tags)) + path find-file-match)) + +(defun semanticdb-find-tags-subclasses-of-type + (type &optional path find-file-match) + "Search for all tags of class type defined that subclass TYPE. +See `semanticdb-find-translate-path' for details on PATH. +FIND-FILE-MATCH indicates that any time a match is found, the file +associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-find-tags-subclasses-of-type-method table type tags)) + path find-file-match t)) + +;;; METHODS +;; +;; Default methods for semanticdb database and table objects. +;; Override these with system databases to as new types of back ends. + +;;; Top level Searches +(defmethod semanticdb-find-tags-by-name-method ((table semanticdb-abstract-table) name &optional tags) + "In TABLE, find all occurances of tags with NAME. +Optional argument TAGS is a list of tags to search. +Returns a table of all matching tags." + (semantic-find-tags-by-name name (or tags (semanticdb-get-tags table)))) + +(defmethod semanticdb-find-tags-by-name-regexp-method ((table semanticdb-abstract-table) regexp &optional tags) + "In TABLE, find all occurances of tags matching REGEXP. +Optional argument TAGS is a list of tags to search. +Returns a table of all matching tags." + (semantic-find-tags-by-name-regexp regexp (or tags (semanticdb-get-tags table)))) + +(defmethod semanticdb-find-tags-for-completion-method ((table semanticdb-abstract-table) prefix &optional tags) + "In TABLE, find all occurances of tags matching PREFIX. +Optional argument TAGS is a list of tags to search. +Returns a table of all matching tags." + (semantic-find-tags-for-completion prefix (or tags (semanticdb-get-tags table)))) + +(defmethod semanticdb-find-tags-by-class-method ((table semanticdb-abstract-table) class &optional tags) + "In TABLE, find all occurances of tags of CLASS. +Optional argument TAGS is a list of tags to search. +Returns a table of all matching tags." + (semantic-find-tags-by-class class (or tags (semanticdb-get-tags table)))) + +(defmethod semanticdb-find-tags-external-children-of-type-method ((table semanticdb-abstract-table) parent &optional tags) + "In TABLE, find all occurances of tags whose parent is the PARENT type. +Optional argument TAGS is a list of tags to search. +Returns a table of all matching tags." + (semantic-find-tags-external-children-of-type parent (or tags (semanticdb-get-tags table)))) + +(defmethod semanticdb-find-tags-subclasses-of-type-method ((table semanticdb-abstract-table) parent &optional tags) + "In TABLE, find all occurances of tags whose parent is the PARENT type. +Optional argument TAGS is a list of tags to search. +Returns a table of all matching tags." + (semantic-find-tags-subclasses-of-type parent (or tags (semanticdb-get-tags table)))) + +;;; Deep Searches +(defmethod semanticdb-deep-find-tags-by-name-method ((table semanticdb-abstract-table) name &optional tags) + "In TABLE, find all occurances of tags with NAME. +Search in all tags in TABLE, and all components of top level tags in +TABLE. +Optional argument TAGS is a list of tags to search. +Return a table of all matching tags." + (semantic-find-tags-by-name name (semantic-flatten-tags-table (or tags (semanticdb-get-tags table))))) + +(defmethod semanticdb-deep-find-tags-by-name-regexp-method ((table semanticdb-abstract-table) regexp &optional tags) + "In TABLE, find all occurances of tags matching REGEXP. +Search in all tags in TABLE, and all components of top level tags in +TABLE. +Optional argument TAGS is a list of tags to search. +Return a table of all matching tags." + (semantic-find-tags-by-name-regexp regexp (semantic-flatten-tags-table (or tags (semanticdb-get-tags table))))) + +(defmethod semanticdb-deep-find-tags-for-completion-method ((table semanticdb-abstract-table) prefix &optional tags) + "In TABLE, find all occurances of tags matching PREFIX. +Search in all tags in TABLE, and all components of top level tags in +TABLE. +Optional argument TAGS is a list of tags to search. +Return a table of all matching tags." + (semantic-find-tags-for-completion prefix (semantic-flatten-tags-table (or tags (semanticdb-get-tags table))))) + +(provide 'semantic/db-find) + +;;; semanticdb-find.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/db-ref.el Fri Aug 28 19:18:35 2009 +0000 @@ -0,0 +1,161 @@ +;;; db-ref.el --- Handle cross-db file references + +;;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Handle cross-database file references. +;; +;; Any given database may be referred to by some other database. For +;; example, if a .cpp file has a #include in a header, then that +;; header file should have a reference to the .cpp file that included +;; it. +;; +;; This is critical for purposes where a file (such as a .cpp file) +;; needs to have its caches flushed because of changes in the +;; header. Changing a header may cause a referring file to be +;; reparsed due to account for changes in defined macros, or perhaps +;; a change to files the header includes. + + +;;; Code: +(defmethod semanticdb-add-reference ((dbt semanticdb-abstract-table) + include-tag) + "Add a reference for the database table DBT based on INCLUDE-TAG. +DBT is the database table that owns the INCLUDE-TAG. The reference +will be added to the database that INCLUDE-TAG refers to." + ;; NOTE: I should add a check to make sure include-tag is in DB. + ;; but I'm too lazy. + (let* ((semanticdb-find-default-throttle + (if (featurep 'semanticdb-find) + (remq 'unloaded semanticdb-find-default-throttle) + nil)) + (refdbt (semanticdb-find-table-for-include include-tag dbt)) + ;;(fullfile (semanticdb-full-filename dbt)) + ) + (when refdbt + ;; Add our filename (full path) + ;; (object-add-to-list refdbt 'file-refs fullfile) + + ;; Add our database. + (object-add-to-list refdbt 'db-refs dbt) + t))) + +(defmethod semanticdb-check-references ((dbt semanticdb-abstract-table)) + "Check and cleanup references in the database DBT. +Abstract tables would be difficult to reference." + ;; Not sure how an abstract table can have references. + nil) + +(defmethod semanticdb-includes-in-table ((dbt semanticdb-abstract-table)) + "Return a list of direct includes in table DBT." + (semantic-find-tags-by-class 'include (semanticdb-get-tags dbt))) + + +(defmethod semanticdb-check-references ((dbt semanticdb-table)) + "Check and cleanup references in the database DBT. +Any reference to a file that cannot be found, or whos file no longer +refers to DBT will be removed." + (let ((refs (oref dbt db-refs)) + (myexpr (concat "\\<" (oref dbt file))) + ) + (while refs + (let* ((ok t) + (db (car refs)) + (f (when (semanticdb-table-child-p db) + (semanticdb-full-filename db))) + ) + + ;; The file was deleted + (when (and f (not (file-exists-p f))) + (setq ok nil)) + + ;; The reference no longer includes the textual reference? + (let* ((refs (semanticdb-includes-in-table db)) + (inc (semantic-find-tags-by-name-regexp + myexpr refs))) + (when (not inc) + (setq ok nil))) + + ;; Remove not-ok databases from the list. + (when (not ok) + (object-remove-from-list dbt 'db-refs db) + )) + (setq refs (cdr refs))))) + +(defmethod semanticdb-refresh-references ((dbt semanticdb-abstract-table)) + "Refresh references to DBT in other files." + ;; alternate tables can't be edited, so can't be changed. + nil + ) + +(defmethod semanticdb-refresh-references ((dbt semanticdb-table)) + "Refresh references to DBT in other files." + (let ((refs (semanticdb-includes-in-table dbt)) + ) + (while refs + (if (semanticdb-add-reference dbt (car refs)) + nil + ;; If we succeeded, then do... nothing? + nil + ) + (setq refs (cdr refs))) + )) + +(defmethod semanticdb-notify-references ((dbt semanticdb-table) + method) + "Notify all references of the table DBT using method. +METHOD takes two arguments. + (METHOD TABLE-TO-NOTIFY DBT) +TABLE-TO-NOTIFY is a semanticdb-table which is being notified. +DBT, the second argument is DBT." + (mapc (lambda (R) (funcall method R dbt)) + (oref dbt db-refs))) + +;;; DEBUG +;; +(defclass semanticdb-ref-adebug () + ((i-depend-on :initarg :i-depend-on) + (local-table :initarg :local-table) + (i-include :initarg :i-include)) + "Simple class to allow ADEBUG to show a nice list.") + +(defun semanticdb-ref-test (refresh) + "Dump out the list of references for the current buffer. +If REFRESH is non-nil, cause the current table to have it's references +refreshed before dumping the result." + (interactive "p") + ;; If we need to refresh... then do so. + (when refresh + (semanticdb-refresh-references semanticdb-current-table)) + ;; Do the debug system + (let* ((tab semanticdb-current-table) + (myrefs (oref tab db-refs)) + (myinc (semanticdb-includes-in-table tab)) + (adbc (semanticdb-ref-adebug "DEBUG" + :i-depend-on myrefs + :local-table tab + :i-include myinc))) + (data-debug-new-buffer "*References ADEBUG*") + (data-debug-insert-object-slots adbc "!")) + ) + +(provide 'semantic/db-ref) +;;; semanticdb-ref.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/find.el Fri Aug 28 19:18:35 2009 +0000 @@ -0,0 +1,795 @@ +;;; find.el --- Search routines for Semantic + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Routines for searching through lists of tags. +;; There are several groups of tag search routines: +;; +;; 1) semantic-brute-find-tag-by-* +;; These routines use brute force hierarchical search to scan +;; through lists of tags. They include some parameters +;; used for compatibility with the semantic 1.x search routines. +;; +;; 1.5) semantic-brute-find-first-tag-by-* +;; Like 1, except seraching stops on the first match for the given +;; information. +;; +;; 2) semantic-find-tag-by-* +;; These prefered search routines attempt to scan through lists +;; in an intelligent way based on questions asked. +;; +;; 3) semantic-find-*-overlay +;; These routines use overlays to return tags based on a buffer position. +;; +;; 4) ... + +(require 'semantic/tag) + +;;; Code: + +;;; Overlay Search Routines +;; +;; These routines provide fast access to tokens based on a buffer that +;; has parsed tokens in it. Uses overlays to perform the hard work. +(defun semantic-find-tag-by-overlay (&optional positionormarker buffer) + "Find all tags covering POSITIONORMARKER by using overlays. +If POSITIONORMARKER is nil, use the current point. +Optional BUFFER is used if POSITIONORMARKER is a number, otherwise the current +buffer is used. This finds all tags covering the specified position +by checking for all overlays covering the current spot. They are then sorted +from largest to smallest via the start location." + (save-excursion + (when positionormarker + (if (markerp positionormarker) + (set-buffer (marker-buffer positionormarker)) + (if (bufferp buffer) + (set-buffer buffer)))) + (let ((ol (semantic-overlays-at (or positionormarker (point)))) + (ret nil)) + (while ol + (let ((tmp (semantic-overlay-get (car ol) 'semantic))) + (when (and tmp + ;; We don't need with-position because no tag w/out + ;; a position could exist in an overlay. + (semantic-tag-p tmp)) + (setq ret (cons tmp ret)))) + (setq ol (cdr ol))) + (sort ret (lambda (a b) (< (semantic-tag-start a) + (semantic-tag-start b))))))) + +(defun semantic-find-tag-by-overlay-in-region (start end &optional buffer) + "Find all tags which exist in whole or in part between START and END. +Uses overlays to determine positin. +Optional BUFFER argument specifies the buffer to use." + (save-excursion + (if buffer (set-buffer buffer)) + (let ((ol (semantic-overlays-in start end)) + (ret nil)) + (while ol + (let ((tmp (semantic-overlay-get (car ol) 'semantic))) + (when (and tmp + ;; See above about position + (semantic-tag-p tmp)) + (setq ret (cons tmp ret)))) + (setq ol (cdr ol))) + (sort ret (lambda (a b) (< (semantic-tag-start a) + (semantic-tag-start b))))))) + +(defun semantic-find-tag-by-overlay-next (&optional start buffer) + "Find the next tag after START in BUFFER. +If START is in an overlay, find the tag which starts next, +not the current tag." + (save-excursion + (if buffer (set-buffer buffer)) + (if (not start) (setq start (point))) + (let ((os start) (ol nil)) + (while (and os (< os (point-max)) (not ol)) + (setq os (semantic-overlay-next-change os)) + (when os + ;; Get overlays at position + (setq ol (semantic-overlays-at os)) + ;; find the overlay that belongs to semantic + ;; and starts at the found position. + (while (and ol (listp ol)) + (if (and (semantic-overlay-get (car ol) 'semantic) + (semantic-tag-p + (semantic-overlay-get (car ol) 'semantic)) + (= (semantic-overlay-start (car ol)) os)) + (setq ol (car ol))) + (when (listp ol) (setq ol (cdr ol)))))) + ;; convert ol to a tag + (when (and ol (semantic-tag-p (semantic-overlay-get ol 'semantic))) + (semantic-overlay-get ol 'semantic))))) + +(defun semantic-find-tag-by-overlay-prev (&optional start buffer) + "Find the next tag before START in BUFFER. +If START is in an overlay, find the tag which starts next, +not the current tag." + (save-excursion + (if buffer (set-buffer buffer)) + (if (not start) (setq start (point))) + (let ((os start) (ol nil)) + (while (and os (> os (point-min)) (not ol)) + (setq os (semantic-overlay-previous-change os)) + (when os + ;; Get overlays at position + (setq ol (semantic-overlays-at (1- os))) + ;; find the overlay that belongs to semantic + ;; and ENDS at the found position. + ;; + ;; Use end because we are going backward. + (while (and ol (listp ol)) + (if (and (semantic-overlay-get (car ol) 'semantic) + (semantic-tag-p + (semantic-overlay-get (car ol) 'semantic)) + (= (semantic-overlay-end (car ol)) os)) + (setq ol (car ol))) + (when (listp ol) (setq ol (cdr ol)))))) + ;; convert ol to a tag + (when (and ol + (semantic-tag-p (semantic-overlay-get ol 'semantic))) + (semantic-overlay-get ol 'semantic))))) + +(defun semantic-find-tag-parent-by-overlay (tag) + "Find the parent of TAG by overlays. +Overlays are a fast way of finding this information for active buffers." + (let ((tag (nreverse (semantic-find-tag-by-overlay + (semantic-tag-start tag))))) + ;; This is a lot like `semantic-current-tag-parent', but + ;; it uses a position to do it's work. Assumes two tags don't share + ;; the same start unless they are siblings. + (car (cdr tag)))) + +(defun semantic-current-tag () + "Return the current tag in the current buffer. +If there are more than one in the same location, return the +smallest tag. Return nil if there is no tag here." + (car (nreverse (semantic-find-tag-by-overlay)))) + +(defun semantic-current-tag-parent () + "Return the current tags parent in the current buffer. +A tag's parent would be a containing structure, such as a type +containing a field. Return nil if there is no parent." + (car (cdr (nreverse (semantic-find-tag-by-overlay))))) + +(defun semantic-current-tag-of-class (class) + "Return the current (smallest) tags of CLASS in the current buffer. +If the smallest tag is not of type CLASS, keep going upwards until one +is found. +Uses `semantic-tag-class' for classification." + (let ((tags (nreverse (semantic-find-tag-by-overlay)))) + (while (and tags + (not (eq (semantic-tag-class (car tags)) class))) + (setq tags (cdr tags))) + (car tags))) + +;;; Search Routines +;; +;; These are routines that search a single tags table. +;; +;; The original API (see COMPATIBILITY section below) in semantic 1.4 +;; had these usage statistics: +;; +;; semantic-find-nonterminal-by-name 17 +;; semantic-find-nonterminal-by-name-regexp 8 - Most doing completion +;; semantic-find-nonterminal-by-position 13 +;; semantic-find-nonterminal-by-token 21 +;; semantic-find-nonterminal-by-type 2 +;; semantic-find-nonterminal-standard 1 +;; +;; semantic-find-nonterminal-by-function (not in other searches) 1 +;; +;; New API: As above w/out `search-parts' or `search-includes' arguments. +;; Extra fcn: Specific to completion which is what -name-regexp is +;; mostly used for +;; +;; As for the sarguments "search-parts" and "search-includes" here +;; are stats: +;; +;; search-parts: 4 - charting x2, find-doc, senator (sans db) +;; +;; Implement command to flatten a tag table. Call new API Fcn w/ +;; flattened table for same results. +;; +;; search-include: 2 - analyze x2 (sans db) +;; +;; Not used effectively. Not to be re-implemented here. + +(defsubst semantic--find-tags-by-function (predicate &optional table) + "Find tags for which PREDICATE is non-nil in TABLE. +PREDICATE is a lambda expression which accepts on TAG. +TABLE is a semantic tags table. See `semantic-something-to-tag-table'." + (let ((tags (semantic-something-to-tag-table table)) + (result nil)) +; (mapc (lambda (tag) (and (funcall predicate tag) +; (setq result (cons tag result)))) +; tags) + ;; A while loop is actually faster. Who knew + (while tags + (and (funcall predicate (car tags)) + (setq result (cons (car tags) result))) + (setq tags (cdr tags))) + (nreverse result))) + +;; I can shave off some time by removing the funcall (see above) +;; and having the question be inlined in the while loop. +;; Strangely turning the upper level fcns into macros had a larger +;; impact. +(defmacro semantic--find-tags-by-macro (form &optional table) + "Find tags for which FORM is non-nil in TABLE. +TABLE is a semantic tags table. See `semantic-something-to-tag-table'." + `(let ((tags (semantic-something-to-tag-table ,table)) + (result nil)) + (while tags + (and ,form + (setq result (cons (car tags) result))) + (setq tags (cdr tags))) + (nreverse result))) + +;;; Top level Searches +;; +(defsubst semantic-find-first-tag-by-name (name &optional table) + "Find the first tag with NAME in TABLE. +NAME is a string. +TABLE is a semantic tags table. See `semantic-something-to-tag-table'. +This routine uses `assoc' to quickly find the first matching entry." + (funcall (if semantic-case-fold 'assoc-ignore-case 'assoc) + name (semantic-something-to-tag-table table))) + +(defmacro semantic-find-tags-by-name (name &optional table) + "Find all tags with NAME in TABLE. +NAME is a string. +TABLE is a tag table. See `semantic-something-to-tag-table'." + `(let ((case-fold-search semantic-case-fold)) + (semantic--find-tags-by-macro + (string= ,name (semantic-tag-name (car tags))) + ,table))) + +(defmacro semantic-find-tags-for-completion (prefix &optional table) + "Find all tags whos name begins with PREFIX in TABLE. +PREFIX is a string. +TABLE is a tag table. See `semantic-something-to-tag-table'. +While it would be nice to use `try-completion' or `all-completions', +those functions do not return the tags, only a string. +Uses `compare-strings' for fast comparison." + `(let ((l (length ,prefix))) + (semantic--find-tags-by-macro + (eq (compare-strings ,prefix 0 nil + (semantic-tag-name (car tags)) 0 l + semantic-case-fold) + t) + ,table))) + +(defmacro semantic-find-tags-by-name-regexp (regexp &optional table) + "Find all tags with name matching REGEXP in TABLE. +REGEXP is a string containing a regular expression, +TABLE is a tag table. See `semantic-something-to-tag-table'. +Consider using `semantic-find-tags-for-completion' if you are +attempting to do completions." + `(let ((case-fold-search semantic-case-fold)) + (semantic--find-tags-by-macro + (string-match ,regexp (semantic-tag-name (car tags))) + ,table))) + +(defmacro semantic-find-tags-by-class (class &optional table) + "Find all tags of class CLASS in TABLE. +CLASS is a symbol representing the class of the token, such as +'variable, of 'function.. +TABLE is a tag table. See `semantic-something-to-tag-table'." + `(semantic--find-tags-by-macro + (eq ,class (semantic-tag-class (car tags))) + ,table)) + +(defmacro semantic-find-tags-by-type (type &optional table) + "Find all tags of with a type TYPE in TABLE. +TYPE is a string or tag representing a data type as defined in the +language the tags were parsed from, such as \"int\", or perhaps +a tag whose name is that of a struct or class. +TABLE is a tag table. See `semantic-something-to-tag-table'." + `(semantic--find-tags-by-macro + (semantic-tag-of-type-p (car tags) ,type) + ,table)) + +(defmacro semantic-find-tags-of-compound-type (&optional table) + "Find all tags which are a compound type in TABLE. +Compound types are structures, or other data type which +is not of a primitive nature, such as int or double. +Used in completion." + `(semantic--find-tags-by-macro + (semantic-tag-type-compound-p (car tags)) + ,table)) + +(define-overloadable-function semantic-find-tags-by-scope-protection (scopeprotection parent &optional table) + "Find all tags accessable by SCOPEPROTECTION. +SCOPEPROTECTION is a symbol which can be returned by the method +`semantic-tag-protection'. A hard-coded order is used to determine a match. +PARENT is a tag representing the PARENT slot needed for +`semantic-tag-protection'. +TABLE is a list of tags (a subset of PARENT members) to scan. If TABLE is nil, +the type members of PARENT are used. +See `semantic-tag-protected-p' for details on which tags are returned." + (if (not (eq (semantic-tag-class parent) 'type)) + (signal 'wrong-type-argument '(semantic-find-tags-by-scope-protection + parent + semantic-tag-class type)) + (:override))) + +(defun semantic-find-tags-by-scope-protection-default + (scopeprotection parent &optional table) + "Find all tags accessable by SCOPEPROTECTION. +SCOPEPROTECTION is a symbol which can be returned by the method +`semantic-tag-protection'. A hard-coded order is used to determine a match. +PARENT is a tag representing the PARENT slot needed for +`semantic-tag-protection'. +TABLE is a list of tags (a subset of PARENT members) to scan. If TABLE is nil, +the type members of PARENT are used. +See `semantic-tag-protected-p' for details on which tags are returned." + (if (not table) (setq table (semantic-tag-type-members parent))) + (if (null scopeprotection) + table + (semantic--find-tags-by-macro + (not (semantic-tag-protected-p (car tags) scopeprotection parent)) + table))) + +(defsubst semantic-find-tags-included (&optional table) + "Find all tags in TABLE that are of the 'include class. +TABLE is a tag table. See `semantic-something-to-tag-table'." + (semantic-find-tags-by-class 'include table)) + +;;; Deep Searches + +(defmacro semantic-deep-find-tags-by-name (name &optional table) + "Find all tags with NAME in TABLE. +Search in top level tags, and their components, in TABLE. +NAME is a string. +TABLE is a tag table. See `semantic-flatten-tags-table'. +See also `semantic-find-tags-by-name'." + `(semantic-find-tags-by-name + ,name (semantic-flatten-tags-table ,table))) + +(defmacro semantic-deep-find-tags-for-completion (prefix &optional table) + "Find all tags whos name begins with PREFIX in TABLE. +Search in top level tags, and their components, in TABLE. +TABLE is a tag table. See `semantic-flatten-tags-table'. +See also `semantic-find-tags-for-completion'." + `(semantic-find-tags-for-completion + ,prefix (semantic-flatten-tags-table ,table))) + +(defmacro semantic-deep-find-tags-by-name-regexp (regexp &optional table) + "Find all tags with name matching REGEXP in TABLE. +Search in top level tags, and their components, in TABLE. +REGEXP is a string containing a regular expression, +TABLE is a tag table. See `semantic-flatten-tags-table'. +See also `semantic-find-tags-by-name-regexp'. +Consider using `semantic-deep-find-tags-for-completion' if you are +attempting to do completions." + `(semantic-find-tags-by-name-regexp + ,regexp (semantic-flatten-tags-table ,table))) + +;;; Specialty Searches +;; +(defun semantic-find-tags-external-children-of-type (type &optional table) + "Find all tags in whose parent is TYPE in TABLE. +These tags are defined outside the scope of the original TYPE declaration. +TABLE is a tag table. See `semantic-something-to-tag-table'." + (semantic--find-tags-by-macro + (equal (semantic-tag-external-member-parent (car tags)) + type) + table)) + +(defun semantic-find-tags-subclasses-of-type (type &optional table) + "Find all tags of class type in whose parent is TYPE in TABLE. +These tags are defined outside the scope of the original TYPE declaration. +TABLE is a tag table. See `semantic-something-to-tag-table'." + (semantic--find-tags-by-macro + (and (eq (semantic-tag-class (car tags)) 'type) + (or (member type (semantic-tag-type-superclasses (car tags))) + (member type (semantic-tag-type-interfaces (car tags))))) + table)) + +;; +;; ************************** Compatibility *************************** +;; + +;;; Old Style Brute Force Search Routines +;; +;; These functions will search through tags lists explicity for +;; desired information. + +;; The -by-name nonterminal search can use the built in fcn +;; `assoc', which is faster than looping ourselves, so we will +;; not use `semantic-brute-find-tag-by-function' to do this, +;; instead erroring on the side of speed. + +(defun semantic-brute-find-first-tag-by-name + (name streamorbuffer &optional search-parts search-include) + "Find a tag NAME within STREAMORBUFFER. NAME is a string. +If SEARCH-PARTS is non-nil, search children of tags. +If SEARCH-INCLUDE was never implemented. + +Use `semantic-find-first-tag-by-name' instead." + (let* ((stream (semantic-something-to-tag-table streamorbuffer)) + (assoc-fun (if semantic-case-fold + #'assoc-ignore-case + #'assoc)) + (m (funcall assoc-fun name stream))) + (if m + m + (let ((toklst stream) + (children nil)) + (while (and (not m) toklst) + (if search-parts + (progn + (setq children (semantic-tag-components-with-overlays + (car toklst))) + (if children + (setq m (semantic-brute-find-first-tag-by-name + name children search-parts search-include))))) + (setq toklst (cdr toklst))) + (if (not m) + ;; Go to dependencies, and search there. + nil) + m)))) + +(defmacro semantic-brute-find-tag-by-class + (class streamorbuffer &optional search-parts search-includes) + "Find all tags with a class CLASS within STREAMORBUFFER. +CLASS is a symbol representing the class of the tags to find. +See `semantic-tag-class'. +Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to +`semantic-brute-find-tag-by-function'. + +Use `semantic-find-tag-by-class' instead." + `(semantic-brute-find-tag-by-function + (lambda (tag) (eq ,class (semantic-tag-class tag))) + ,streamorbuffer ,search-parts ,search-includes)) + +(defmacro semantic-brute-find-tag-standard + (streamorbuffer &optional search-parts search-includes) + "Find all tags in STREAMORBUFFER which define simple class types. +See `semantic-tag-class'. +Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to +`semantic-brute-find-tag-by-function'." + `(semantic-brute-find-tag-by-function + (lambda (tag) (member (semantic-tag-class tag) + '(function variable type))) + ,streamorbuffer ,search-parts ,search-includes)) + +(defun semantic-brute-find-tag-by-type + (type streamorbuffer &optional search-parts search-includes) + "Find all tags with type TYPE within STREAMORBUFFER. +TYPE is a string which is the name of the type of the tags returned. +See `semantic-tag-type'. +Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to +`semantic-brute-find-tag-by-function'." + (semantic-brute-find-tag-by-function + (lambda (tag) + (let ((ts (semantic-tag-type tag))) + (if (and (listp ts) + (or (= (length ts) 1) + (eq (semantic-tag-class ts) 'type))) + (setq ts (semantic-tag-name ts))) + (equal type ts))) + streamorbuffer search-parts search-includes)) + +(defun semantic-brute-find-tag-by-type-regexp + (regexp streamorbuffer &optional search-parts search-includes) + "Find all tags with type matching REGEXP within STREAMORBUFFER. +REGEXP is a regular expression which matches the name of the type of the +tags returned. See `semantic-tag-type'. +Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to +`semantic-brute-find-tag-by-function'." + (semantic-brute-find-tag-by-function + (lambda (tag) + (let ((ts (semantic-tag-type tag))) + (if (listp ts) + (setq ts + (if (eq (semantic-tag-class ts) 'type) + (semantic-tag-name ts) + (car ts)))) + (and ts (string-match regexp ts)))) + streamorbuffer search-parts search-includes)) + +(defun semantic-brute-find-tag-by-name-regexp + (regex streamorbuffer &optional search-parts search-includes) + "Find all tags whose name match REGEX in STREAMORBUFFER. +Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to +`semantic-brute-find-tag-by-function'." + (semantic-brute-find-tag-by-function + (lambda (tag) (string-match regex (semantic-tag-name tag))) + streamorbuffer search-parts search-includes) + ) + +(defun semantic-brute-find-tag-by-property + (property value streamorbuffer &optional search-parts search-includes) + "Find all tags with PROPERTY equal to VALUE in STREAMORBUFFER. +Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to +`semantic-brute-find-tag-by-function'." + (semantic-brute-find-tag-by-function + (lambda (tag) (equal (semantic--tag-get-property tag property) value)) + streamorbuffer search-parts search-includes) + ) + +(defun semantic-brute-find-tag-by-attribute + (attr streamorbuffer &optional search-parts search-includes) + "Find all tags with a given ATTR in STREAMORBUFFER. +ATTR is a symbol key into the attributes list. +Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to +`semantic-brute-find-tag-by-function'." + (semantic-brute-find-tag-by-function + (lambda (tag) (semantic-tag-get-attribute tag attr)) + streamorbuffer search-parts search-includes) + ) + +(defun semantic-brute-find-tag-by-attribute-value + (attr value streamorbuffer &optional search-parts search-includes) + "Find all tags with a given ATTR equal to VALUE in STREAMORBUFFER. +ATTR is a symbol key into the attributes list. +VALUE is the value that ATTR should match. +Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to +`semantic-brute-find-tag-by-function'." + (semantic-brute-find-tag-by-function + (lambda (tag) (equal (semantic-tag-get-attribute tag attr) value)) + streamorbuffer search-parts search-includes) + ) + +(defun semantic-brute-find-tag-by-function + (function streamorbuffer &optional search-parts search-includes) + "Find all tags for which FUNCTION's value is non-nil within STREAMORBUFFER. +FUNCTION must return non-nil if an element of STREAM will be included +in the new list. + +If optional argument SEARCH-PARTS is non-nil, all sub-parts of tags +are searched. The overloadable function `semantic-tag-componenets' is +used for the searching child lists. If SEARCH-PARTS is the symbol +'positiononly, then only children that have positional information are +searched. + +If SEARCH-INCLUDES has not been implemented. +This parameter hasn't be active for a while and is obsolete." + (let ((stream (semantic-something-to-tag-table streamorbuffer)) + (sl nil) ;list of tag children + (nl nil) ;new list + (case-fold-search semantic-case-fold)) + (dolist (tag stream) + (if (not (semantic-tag-p tag)) + ;; `semantic-tag-components-with-overlays' can return invalid + ;; tags if search-parts is not equal to 'positiononly + nil ;; Ignore them! + (if (funcall function tag) + (setq nl (cons tag nl))) + (and search-parts + (setq sl (if (eq search-parts 'positiononly) + (semantic-tag-components-with-overlays tag) + (semantic-tag-components tag)) + ) + (setq nl (nconc nl + (semantic-brute-find-tag-by-function + function sl + search-parts)))))) + (setq nl (nreverse nl)) + nl)) + +(defun semantic-brute-find-first-tag-by-function + (function streamorbuffer &optional search-parts search-includes) + "Find the first tag which FUNCTION match within STREAMORBUFFER. +FUNCTION must return non-nil if an element of STREAM will be included +in the new list. + +The following parameters were never implemented. + +If optional argument SEARCH-PARTS, all sub-parts of tags are searched. +The overloadable function `semantic-tag-components' is used for +searching. +If SEARCH-INCLUDES is non-nil, then all include files are also +searched for matches." + (let ((stream (semantic-something-to-tag-table streamorbuffer)) + (found nil) + (case-fold-search semantic-case-fold)) + (while (and (not found) stream) + (if (funcall function (car stream)) + (setq found (car stream))) + (setq stream (cdr stream))) + found)) + + +;;; Old Positional Searches +;; +;; Are these useful anymore? +;; +(defun semantic-brute-find-tag-by-position (position streamorbuffer + &optional nomedian) + "Find a tag covering POSITION within STREAMORBUFFER. +POSITION is a number, or marker. If NOMEDIAN is non-nil, don't do +the median calculation, and return nil." + (save-excursion + (if (markerp position) (set-buffer (marker-buffer position))) + (let* ((stream (if (bufferp streamorbuffer) + (save-excursion + (set-buffer streamorbuffer) + (semantic-fetch-tags)) + streamorbuffer)) + (prev nil) + (found nil)) + (while (and stream (not found)) + ;; perfect fit + (if (and (>= position (semantic-tag-start (car stream))) + (<= position (semantic-tag-end (car stream)))) + (setq found (car stream)) + ;; Median between to objects. + (if (and prev (not nomedian) + (>= position (semantic-tag-end prev)) + (<= position (semantic-tag-start (car stream)))) + (let ((median (/ (+ (semantic-tag-end prev) + (semantic-tag-start (car stream))) + 2))) + (setq found + (if (> position median) + (car stream) + prev))))) + ;; Next!!! + (setq prev (car stream) + stream (cdr stream))) + found))) + +(defun semantic-brute-find-innermost-tag-by-position + (position streamorbuffer &optional nomedian) + "Find a list of tags covering POSITION within STREAMORBUFFER. +POSITION is a number, or marker. If NOMEDIAN is non-nil, don't do +the median calculation, and return nil. +This function will find the topmost item, and recurse until no more +details are available of findable." + (let* ((returnme nil) + (current (semantic-brute-find-tag-by-position + position streamorbuffer nomedian)) + (nextstream (and current + (if (eq (semantic-tag-class current) 'type) + (semantic-tag-type-members current) + nil)))) + (while nextstream + (setq returnme (cons current returnme)) + (setq current (semantic-brute-find-tag-by-position + position nextstream nomedian)) + (setq nextstream (and current + ;; NOTE TO SELF: + ;; Looking at this after several years away, + ;; what does this do??? + (if (eq (semantic-tag-class current) 'token) + (semantic-tag-type-members current) + nil)))) + (nreverse (cons current returnme)))) + +;;; Compatibility Aliases +(semantic-alias-obsolete 'semantic-find-nonterminal-by-overlay + 'semantic-find-tag-by-overlay) + +(semantic-alias-obsolete 'semantic-find-nonterminal-by-overlay-in-region + 'semantic-find-tag-by-overlay-in-region) + +(semantic-alias-obsolete 'semantic-find-nonterminal-by-overlay-next + 'semantic-find-tag-by-overlay-next) + +(semantic-alias-obsolete 'semantic-find-nonterminal-by-overlay-prev + 'semantic-find-tag-by-overlay-prev) + +(semantic-alias-obsolete 'semantic-find-nonterminal-parent-by-overlay + 'semantic-find-tag-parent-by-overlay) + +(semantic-alias-obsolete 'semantic-current-nonterminal + 'semantic-current-tag) + +(semantic-alias-obsolete 'semantic-current-nonterminal-parent + 'semantic-current-tag-parent) + +(semantic-alias-obsolete 'semantic-current-nonterminal-of-type + 'semantic-current-tag-of-class) + +(semantic-alias-obsolete 'semantic-find-nonterminal-by-name + 'semantic-brute-find-first-tag-by-name) + +(semantic-alias-obsolete 'semantic-find-nonterminal-by-token + 'semantic-brute-find-tag-by-class) + +(semantic-alias-obsolete 'semantic-find-nonterminal-standard + 'semantic-brute-find-tag-standard) + +(semantic-alias-obsolete 'semantic-find-nonterminal-by-type + 'semantic-brute-find-tag-by-type) + +(semantic-alias-obsolete 'semantic-find-nonterminal-by-type-regexp + 'semantic-brute-find-tag-by-type-regexp) + +(semantic-alias-obsolete 'semantic-find-nonterminal-by-name-regexp + 'semantic-brute-find-tag-by-name-regexp) + +(semantic-alias-obsolete 'semantic-find-nonterminal-by-property + 'semantic-brute-find-tag-by-property) + +(semantic-alias-obsolete 'semantic-find-nonterminal-by-extra-spec + 'semantic-brute-find-tag-by-attribute) + +(semantic-alias-obsolete 'semantic-find-nonterminal-by-extra-spec-value + 'semantic-brute-find-tag-by-attribute-value) + +(semantic-alias-obsolete 'semantic-find-nonterminal-by-function + 'semantic-brute-find-tag-by-function) + +(semantic-alias-obsolete 'semantic-find-nonterminal-by-function-first-match + 'semantic-brute-find-first-tag-by-function) + +(semantic-alias-obsolete 'semantic-find-nonterminal-by-position + 'semantic-brute-find-tag-by-position) + +(semantic-alias-obsolete 'semantic-find-innermost-nonterminal-by-position + 'semantic-brute-find-innermost-tag-by-position) + +;;; TESTING +;; +(defun semantic-find-benchmark () + "Run some simple benchmarks to see how we are doing. +Optional argument ARG is the number of iterations to run." + (interactive) + (require 'benchmark) + (let ((f-name nil) + (b-name nil) + (f-comp) + (b-comp) + (f-regex) + ) + (garbage-collect) + (setq f-name + (benchmark-run-compiled + 1000 (semantic-find-first-tag-by-name "class3" + "test/test.cpp"))) + (garbage-collect) + (setq b-name + (benchmark-run-compiled + 1000 (semantic-brute-find-first-tag-by-name "class3" + "test/test.cpp"))) + (garbage-collect) + (setq f-comp + (benchmark-run-compiled + 1000 (semantic-find-tags-for-completion "method" + "test/test.cpp"))) + (garbage-collect) + (setq b-comp + (benchmark-run-compiled + 1000 (semantic-brute-find-tag-by-name-regexp "^method" + "test/test.cpp"))) + (garbage-collect) + (setq f-regex + (benchmark-run-compiled + 1000 (semantic-find-tags-by-name-regexp "^method" + "test/test.cpp"))) + + (message "Name [new old] [ %.3f %.3f ] Complete [newc/new old] [ %.3f/%.3f %.3f ]" + (car f-name) (car b-name) + (car f-comp) (car f-regex) + (car b-comp)) + )) + + +(provide 'semantic/find) + +;;; semantic-find.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/format.el Fri Aug 28 19:18:35 2009 +0000 @@ -0,0 +1,774 @@ +;;; format.el --- Routines for formatting tags + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, +;;; 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Once a language file has been parsed into a TAG, it is often useful +;; then display that tag information in browsers, completion engines, or +;; help routines. The functions and setup in this file provide ways +;; to reformat a tag into different standard output types. +;; +;; In addition, macros for setting up customizable variables that let +;; the user choose their default format type are also provided. +;; + +;;; Code: +(eval-when-compile (require 'font-lock)) +(require 'semantic/tag) +(require 'ezimage) + +;;; Tag to text overload functions +;; +;; abbreviations, prototypes, and coloring support. +(defvar semantic-format-tag-functions + '(semantic-format-tag-name + semantic-format-tag-canonical-name + semantic-format-tag-abbreviate + semantic-format-tag-summarize + semantic-format-tag-summarize-with-file + semantic-format-tag-short-doc + semantic-format-tag-prototype + semantic-format-tag-concise-prototype + semantic-format-tag-uml-abbreviate + semantic-format-tag-uml-prototype + semantic-format-tag-uml-concise-prototype + semantic-format-tag-prin1 + ) + "List of functions which convert a tag to text. +Each function must take the parameters TAG &optional PARENT COLOR. +TAG is the tag to convert. +PARENT is a parent tag or name which refers to the structure +or class which contains TAG. PARENT is NOT a class which a TAG +would claim as a parent. +COLOR indicates that the generated text should be colored using +`font-lock'.") + +(semantic-varalias-obsolete 'semantic-token->text-functions + 'semantic-format-tag-functions) +(defvar semantic-format-tag-custom-list + (append '(radio) + (mapcar (lambda (f) (list 'const f)) + semantic-format-tag-functions) + '(function)) + "A List used by customizeable variables to choose a tag to text function. +Use this variable in the :type field of a customizable variable.") + +(semantic-varalias-obsolete 'semantic-token->text-custom-list + 'semantic-format-tag-custom-list) + +(defcustom semantic-format-use-images-flag ezimage-use-images + "Non-nil means semantic format functions use images. +Images can be used as icons instead of some types of text strings." + :group 'semantic + :type 'boolean) + +(defvar semantic-function-argument-separator "," + "Text used to separate arguments when creating text from tags.") +(make-variable-buffer-local 'semantic-function-argument-separator) + +(defvar semantic-format-parent-separator "::" + "Text used to separate names when between namespaces/classes and functions.") +(make-variable-buffer-local 'semantic-format-parent-separator) + +(defun semantic-test-all-format-tag-functions (&optional arg) + "Test all outputs from `semantic-format-tag-functions'. +Output is generated from the function under `point'. +Optional argument ARG specifies not to use color." + (interactive "P") + (semantic-fetch-tags) + (let* ((tag (semantic-current-tag)) + (par (semantic-current-tag-parent)) + (fns semantic-format-tag-functions)) + (with-output-to-temp-buffer "*format-tag*" + (princ "Tag->format function tests:") + (while fns + (princ "\n") + (princ (car fns)) + (princ ":\n ") + (let ((s (funcall (car fns) tag par (not arg)))) + (save-excursion + (set-buffer "*format-tag*") + (goto-char (point-max)) + (insert s))) + (setq fns (cdr fns)))) + )) + +(defvar semantic-format-face-alist + `( (function . font-lock-function-name-face) + (variable . font-lock-variable-name-face) + (type . font-lock-type-face) + ;; These are different between Emacsen. + (include . ,(if (featurep 'xemacs) + 'font-lock-preprocessor-face + 'font-lock-constant-face)) + (package . ,(if (featurep 'xemacs) + 'font-lock-preprocessor-face + 'font-lock-constant-face)) + ;; Not a tag, but instead a feature of output + (label . font-lock-string-face) + (comment . font-lock-comment-face) + (keyword . font-lock-keyword-face) + (abstract . italic) + (static . underline) + (documentation . font-lock-doc-face) + ) + "Face used to colorize tags of different types. +Override the value locally if a language supports other tag types. +When adding new elements, try to use symbols also returned by the parser. +The form of an entry in this list is of the form: + ( SYMBOL . FACE ) +where SYMBOL is a tag type symbol used with semantic. FACE +is a symbol representing a face. +Faces used are generated in `font-lock' for consistency, and will not +be used unless font lock is a feature.") + +(semantic-varalias-obsolete 'semantic-face-alist + 'semantic-format-face-alist) + + + +;;; Coloring Functions +;; +(defun semantic--format-colorize-text (text face-class) + "Apply onto TEXT a color associated with FACE-CLASS. +FACE-CLASS is a tag type found in `semantic-face-alist'. See this variable +for details on adding new types." + (if (featurep 'font-lock) + (let ((face (cdr-safe (assoc face-class semantic-format-face-alist))) + (newtext (concat text))) + (put-text-property 0 (length text) 'face face newtext) + newtext) + text)) + +(make-obsolete 'semantic-colorize-text + 'semantic--format-colorize-text) + +(defun semantic--format-colorize-merge-text (precoloredtext face-class) + "Apply onto PRECOLOREDTEXT a color associated with FACE-CLASS. +FACE-CLASS is a tag type found in 'semantic-face-alist'. See this +variable for details on adding new types." + (let ((face (cdr-safe (assoc face-class semantic-format-face-alist))) + (newtext (concat precoloredtext)) + ) + (if (featurep 'xemacs) + (add-text-properties 0 (length newtext) (list 'face face) newtext) + (alter-text-property 0 (length newtext) 'face + (lambda (current-face) + (let ((cf + (cond ((facep current-face) + (list current-face)) + ((listp current-face) + current-face) + (t nil))) + (nf + (cond ((facep face) + (list face)) + ((listp face) + face) + (t nil)))) + (append cf nf))) + newtext)) + newtext)) + +;;; Function Arguments +;; +(defun semantic--format-tag-arguments (args formatter color) + "Format the argument list ARGS with FORMATTER. +FORMATTER is a function used to format a tag. +COLOR specifies if color should be used." + (let ((out nil)) + (while args + (push (if (and formatter + (semantic-tag-p (car args)) + (not (string= (semantic-tag-name (car args)) "")) + ) + (funcall formatter (car args) nil color) + (semantic-format-tag-name-from-anything + (car args) nil color 'variable)) + out) + (setq args (cdr args))) + (mapconcat 'identity (nreverse out) semantic-function-argument-separator) + )) + +;;; Data Type +(define-overloadable-function semantic-format-tag-type (tag color) + "Convert the data type of TAG to a string usable in tag formatting. +It is presumed that TYPE is a string or semantic tag.") + +(defun semantic-format-tag-type-default (tag color) + "Convert the data type of TAG to a string usable in tag formatting. +Argument COLOR specifies to colorize the text." + (let* ((type (semantic-tag-type tag)) + (out (cond ((semantic-tag-p type) + (let* ((typetype (semantic-tag-type type)) + (name (semantic-tag-name type)) + (str (if typetype + (concat typetype " " name) + name))) + (if color + (semantic--format-colorize-text + str + 'type) + str))) + ((and (listp type) + (stringp (car type))) + (car type)) + ((stringp type) + type) + (t nil)))) + (if (and color out) + (setq out (semantic--format-colorize-text out 'type)) + out) + )) + + +;;; Abstract formatting functions + +(defun semantic-format-tag-prin1 (tag &optional parent color) + "Convert TAG to a string that is the print name for TAG. +PARENT and COLOR are ignored." + (format "%S" tag)) + +(defun semantic-format-tag-name-from-anything (anything &optional + parent color + colorhint) + "Convert just about anything into a name like string. +Argument ANYTHING is the thing to be converted. +Optional argument PARENT is the parent type if TAG is a detail. +Optional argument COLOR means highlight the prototype with font-lock colors. +Optional COLORHINT is the type of color to use if ANYTHING is not a tag +with a tag class. See `semantic--format-colorize-text' for a definition +of FACE-CLASS for which this is used." + (cond ((stringp anything) + (semantic--format-colorize-text anything colorhint)) + ((semantic-tag-p anything) + (let ((ans (semantic-format-tag-name anything parent color))) + ;; If ANS is empty string or nil, then the name wasn't + ;; supplied. The implication is as in C where there is a data + ;; type but no name for a prototype from an include file, or + ;; an argument just wasn't used in the body of the fcn. + (if (or (null ans) (string= ans "")) + (setq ans (semantic-format-tag-type anything color))) + ans)) + ((and (listp anything) + (stringp (car anything))) + (semantic--format-colorize-text (car anything) colorhint)))) + +(define-overloadable-function semantic-format-tag-name (tag &optional parent color) + "Return the name string describing TAG. +The name is the shortest possible representation. +Optional argument PARENT is the parent type if TAG is a detail. +Optional argument COLOR means highlight the prototype with font-lock colors.") + +(defun semantic-format-tag-name-default (tag &optional parent color) + "Return an abbreviated string describing TAG. +Optional argument PARENT is the parent type if TAG is a detail. +Optional argument COLOR means highlight the prototype with font-lock colors." + (let ((name (semantic-tag-name tag)) + (destructor + (if (eq (semantic-tag-class tag) 'function) + (semantic-tag-function-destructor-p tag)))) + (when destructor + (setq name (concat "~" name))) + (if color + (setq name (semantic--format-colorize-text name (semantic-tag-class tag)))) + name)) + +(defun semantic--format-tag-parent-tree (tag parent) + "Under Consideration. + +Return a list of parents for TAG. +PARENT is the first parent, or nil. If nil, then an attempt to +determine PARENT is made. +Once PARENT is identified, additional parents are looked for. +The return list first element is the nearest parent, and the last +item is the first parent which may be a string. The root parent may +not be the actual first parent as there may just be a failure to find +local definitions." + ;; First, validate the PARENT argument. + (unless parent + ;; All mechanisms here must be fast as often parent + ;; is nil because there isn't one. + (setq parent (or (semantic-tag-function-parent tag) + (save-excursion + (semantic-go-to-tag tag) + (semantic-current-tag-parent))))) + (when (stringp parent) + (setq parent (semantic-find-first-tag-by-name + parent (current-buffer)))) + ;; Try and find a trail of parents from PARENT + (let ((rlist (list parent)) + ) + ;; IMPLELEMENT ME!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + (reverse rlist))) + +(define-overloadable-function semantic-format-tag-canonical-name (tag &optional parent color) + "Return a canonical name for TAG. +A canonical name includes the names of any parents or namespaces preceeding +the tag. +Optional argument PARENT is the parent type if TAG is a detail. +Optional argument COLOR means highlight the prototype with font-lock colors.") + +(defun semantic-format-tag-canonical-name-default (tag &optional parent color) + "Return a canonical name for TAG. +A canonical name includes the names of any parents or namespaces preceeding +the tag with colons separating them. +Optional argument PARENT is the parent type if TAG is a detail. +Optional argument COLOR means highlight the prototype with font-lock colors." + (let ((parent-input-str + (if (and parent + (semantic-tag-p parent) + (semantic-tag-of-class-p parent 'type)) + (concat + ;; Choose a class of 'type as the default parent for something. + ;; Just a guess though. + (semantic-format-tag-name-from-anything parent nil color 'type) + ;; Default separator between class/namespace and others. + semantic-format-parent-separator) + "")) + (tag-parent-str + (or (when (and (semantic-tag-of-class-p tag 'function) + (semantic-tag-function-parent tag)) + (concat (semantic-tag-function-parent tag) + semantic-format-parent-separator)) + "")) + ) + (concat parent-input-str + tag-parent-str + (semantic-format-tag-name tag parent color)) + )) + +(define-overloadable-function semantic-format-tag-abbreviate (tag &optional parent color) + "Return an abbreviated string describing TAG. +The abbreviation is to be short, with possible symbols indicating +the type of tag, or other information. +Optional argument PARENT is the parent type if TAG is a detail. +Optional argument COLOR means highlight the prototype with font-lock colors.") + +(defun semantic-format-tag-abbreviate-default (tag &optional parent color) + "Return an abbreviated string describing TAG. +Optional argument PARENT is a parent tag in the tag hierarchy. +In this case PARENT refers to containment, not inheritance. +Optional argument COLOR means highlight the prototype with font-lock colors. +This is a simple C like default." + ;; Do lots of complex stuff here. + (let ((class (semantic-tag-class tag)) + (name (semantic-format-tag-canonical-name tag parent color)) + (suffix "") + (prefix "") + str) + (cond ((eq class 'function) + (setq suffix "()")) + ((eq class 'include) + (setq suffix "<>")) + ((eq class 'variable) + (setq suffix (if (semantic-tag-variable-default tag) + "=" ""))) + ((eq class 'label) + (setq suffix ":")) + ((eq class 'code) + (setq prefix "{" + suffix "}")) + ((eq class 'type) + (setq suffix "{}")) + ) + (setq str (concat prefix name suffix)) + str)) + +;; Semantic 1.2.x had this misspelling. Keep it for backwards compatibiity. +(semantic-alias-obsolete + 'semantic-summerize-nonterminal 'semantic-format-tag-summarize) + +(define-overloadable-function semantic-format-tag-summarize (tag &optional parent color) + "Summarize TAG in a reasonable way. +Optional argument PARENT is the parent type if TAG is a detail. +Optional argument COLOR means highlight the prototype with font-lock colors.") + +(defun semantic-format-tag-summarize-default (tag &optional parent color) + "Summarize TAG in a reasonable way. +Optional argument PARENT is the parent type if TAG is a detail. +Optional argument COLOR means highlight the prototype with font-lock colors." + (let* ((proto (semantic-format-tag-prototype tag nil color)) + (names (if parent + semantic-symbol->name-assoc-list-for-type-parts + semantic-symbol->name-assoc-list)) + (tsymb (semantic-tag-class tag)) + (label (capitalize (or (cdr-safe (assoc tsymb names)) + (symbol-name tsymb))))) + (if color + (setq label (semantic--format-colorize-text label 'label))) + (concat label ": " proto))) + +(define-overloadable-function semantic-format-tag-summarize-with-file (tag &optional parent color) + "Like `semantic-format-tag-summarize', but with the file name. +Optional argument PARENT is the parent type if TAG is a detail. +Optional argument COLOR means highlight the prototype with font-lock colors.") + +(defun semantic-format-tag-summarize-with-file-default (tag &optional parent color) + "Summarize TAG in a reasonable way. +Optional argument PARENT is the parent type if TAG is a detail. +Optional argument COLOR means highlight the prototype with font-lock colors." + (let* ((proto (semantic-format-tag-prototype tag nil color)) + (file (semantic-tag-file-name tag)) + ) + ;; Nothing for tag? Try parent. + (when (and (not file) (and parent)) + (setq file (semantic-tag-file-name parent))) + ;; Don't include the file name if we can't find one, or it is the + ;; same as the current buffer. + (if (or (not file) + (string= file (buffer-file-name (current-buffer)))) + proto + (setq file (file-name-nondirectory file)) + (when color + (setq file (semantic--format-colorize-text file 'label))) + (concat file ": " proto)))) + +(define-overloadable-function semantic-format-tag-short-doc (tag &optional parent color) + "Display a short form of TAG's documentation. (Comments, or docstring.) +Optional argument PARENT is the parent type if TAG is a detail. +Optional argument COLOR means highlight the prototype with font-lock colors.") + +(defun semantic-format-tag-short-doc-default (tag &optional parent color) + "Display a short form of TAG's documentation. (Comments, or docstring.) +Optional argument PARENT is the parent type if TAG is a detail. +Optional argument COLOR means highlight the prototype with font-lock colors." + (let* ((fname (or (semantic-tag-file-name tag) + (when parent (semantic-tag-file-name parent)))) + (buf (or (semantic-tag-buffer tag) + (when parent (semantic-tag-buffer parent)))) + (doc (semantic-tag-docstring tag buf))) + (when (and (not doc) (not buf) fname) + ;; If there is no doc, and no buffer, but we have a filename, + ;; lets try again. + (setq buf (find-file-noselect fname)) + (setq doc (semantic-tag-docstring tag buf))) + (when (not doc) + (setq doc (semantic-documentation-for-tag tag)) + ) + (setq doc + (if (not doc) + ;; No doc, use summarize. + (semantic-format-tag-summarize tag parent color) + ;; We have doc. Can we devise a single line? + (if (string-match "$" doc) + (substring doc 0 (match-beginning 0)) + doc) + )) + (when color + (setq doc (semantic--format-colorize-text doc 'documentation))) + doc + )) + +;;; Prototype generation +;; +(define-overloadable-function semantic-format-tag-prototype (tag &optional parent color) + "Return a prototype for TAG. +This function should be overloaded, though it need not be used. +This is because it can be used to create code by language independent +tools. +Optional argument PARENT is the parent type if TAG is a detail. +Optional argument COLOR means highlight the prototype with font-lock colors.") + +(defun semantic-format-tag-prototype-default (tag &optional parent color) + "Default method for returning a prototype for TAG. +This will work for C like languages. +Optional argument PARENT is the parent type if TAG is a detail. +Optional argument COLOR means highlight the prototype with font-lock colors." + (let* ((class (semantic-tag-class tag)) + (name (semantic-format-tag-name tag parent color)) + (type (if (member class '(function variable type)) + (semantic-format-tag-type tag color))) + (args (if (member class '(function type)) + (semantic--format-tag-arguments + (if (eq class 'function) + (semantic-tag-function-arguments tag) + (list "") + ;;(semantic-tag-type-members tag) + ) + #'semantic-format-tag-prototype + color))) + (const (semantic-tag-get-attribute tag :constant-flag)) + (tm (semantic-tag-get-attribute tag :typemodifiers)) + (mods (append + (if const '("const") nil) + (cond ((stringp tm) (list tm)) + ((consp tm) tm) + (t nil)) + )) + (array (if (eq class 'variable) + (let ((deref + (semantic-tag-get-attribute + tag :dereference)) + (r "")) + (while (and deref (/= deref 0)) + (setq r (concat r "[]") + deref (1- deref))) + r))) + ) + (if args + (setq args + (concat " " + (if (eq class 'type) "{" "(") + args + (if (eq class 'type) "}" ")")))) + (when mods + (setq mods (concat (mapconcat 'identity mods " ") " "))) + (concat (or mods "") + (if type (concat type " ")) + name + (or args "") + (or array "")))) + +(define-overloadable-function semantic-format-tag-concise-prototype (tag &optional parent color) + "Return a concise prototype for TAG. +Optional argument PARENT is the parent type if TAG is a detail. +Optional argument COLOR means highlight the prototype with font-lock colors.") + +(defun semantic-format-tag-concise-prototype-default (tag &optional parent color) + "Return a concise prototype for TAG. +This default function will make a cheap concise prototype using C like syntax. +Optional argument PARENT is the parent type if TAG is a detail. +Optional argument COLOR means highlight the prototype with font-lock colors." + (let ((class (semantic-tag-class tag))) + (cond + ((eq class 'type) + (concat (semantic-format-tag-name tag parent color) "{}")) + ((eq class 'function) + (concat (semantic-format-tag-name tag parent color) + " (" + (semantic--format-tag-arguments + (semantic-tag-function-arguments tag) + 'semantic-format-tag-concise-prototype + color) + ")")) + ((eq class 'variable) + (let* ((deref (semantic-tag-get-attribute + tag :dereference)) + (array "") + ) + (while (and deref (/= deref 0)) + (setq array (concat array "[]") + deref (1- deref))) + (concat (semantic-format-tag-name tag parent color) + array))) + (t + (semantic-format-tag-abbreviate tag parent color))))) + +;;; UML display styles +;; +(defcustom semantic-uml-colon-string " : " + "*String used as a color separator between parts of a UML string. +In UML, a variable may appear as `varname : type'. +Change this variable to change the output separator." + :group 'semantic + :type 'string) + +(defcustom semantic-uml-no-protection-string "" + "*String used to describe when no protection is specified. +Used by `semantic-format-tag-uml-protection-to-string'." + :group 'semantic + :type 'string) + +(defun semantic--format-uml-post-colorize (text tag parent) + "Add color to TEXT created from TAG and PARENT. +Adds augmentation for `abstract' and `static' entries." + (if (semantic-tag-abstract-p tag parent) + (setq text (semantic--format-colorize-merge-text text 'abstract))) + (if (semantic-tag-static-p tag parent) + (setq text (semantic--format-colorize-merge-text text 'static))) + text + ) + +(defun semantic-uml-attribute-string (tag &optional parent) + "Return a string for TAG, a child of PARENT representing a UML attribute. +UML attribute strings are things like {abstract} or {leaf}." + (cond ((semantic-tag-abstract-p tag parent) + "{abstract}") + ((semantic-tag-leaf-p tag parent) + "{leaf}") + )) + +(defvar semantic-format-tag-protection-image-alist + '(("+" . ezimage-unlock) + ("#" . ezimage-key) + ("-" . ezimage-lock) + ) + "Association of protection strings, and images to use.") + +(defvar semantic-format-tag-protection-symbol-to-string-assoc-list + '((public . "+") + (protected . "#") + (private . "-") + ) + "Association list of the form (SYMBOL . \"STRING\") for protection symbols. +This associates a symbol, such as 'public with the st ring \"+\".") + +(define-overloadable-function semantic-format-tag-uml-protection-to-string (protection-symbol color) + "Convert PROTECTION-SYMBOL to a string for UML. +By default, uses `semantic-format-tag-protection-symbol-to-string-assoc-list' +to convert. +By defaul character returns are: + public -- + + private -- - + protected -- #. +If PROTECTION-SYMBOL is unknown, then the return value is +`semantic-uml-no-protection-string'. +COLOR indicates if we should use an image on the text.") + +(defun semantic-format-tag-uml-protection-to-string-default (protection-symbol color) + "Convert PROTECTION-SYMBOL to a string for UML. +Uses `semantic-format-tag-protection-symbol-to-string-assoc-list' to convert. +If PROTECTION-SYMBOL is unknown, then the return value is +`semantic-uml-no-protection-string'. +COLOR indicates if we should use an image on the text." + (let* ((ezimage-use-images (and semantic-format-use-images-flag color)) + (key (assoc protection-symbol + semantic-format-tag-protection-symbol-to-string-assoc-list)) + (str (or (cdr-safe key) semantic-uml-no-protection-string))) + (ezimage-image-over-string + (copy-sequence str) ; make a copy to keep the original pristine. + semantic-format-tag-protection-image-alist))) + +(defsubst semantic-format-tag-uml-protection (tag parent color) + "Retrieve the protection string for TAG with PARENT. +Argument COLOR specifies that color should be added to the string as +needed." + (semantic-format-tag-uml-protection-to-string + (semantic-tag-protection tag parent) + color)) + +(defun semantic--format-tag-uml-type (tag color) + "Format the data type of TAG to a string usable for formatting. +COLOR indicates if it should be colorized." + (let ((str (semantic-format-tag-type tag color))) + (if str + (concat semantic-uml-colon-string str)))) + +(define-overloadable-function semantic-format-tag-uml-abbreviate (tag &optional parent color) + "Return a UML style abbreviation for TAG. +Optional argument PARENT is the parent type if TAG is a detail. +Optional argument COLOR means highlight the prototype with font-lock colors.") + +(defun semantic-format-tag-uml-abbreviate-default (tag &optional parent color) + "Return a UML style abbreviation for TAG. +Optional argument PARENT is the parent type if TAG is a detail. +Optional argument COLOR means highlight the prototype with font-lock colors." + (let* ((name (semantic-format-tag-name tag parent color)) + (type (semantic--format-tag-uml-type tag color)) + (protstr (semantic-format-tag-uml-protection tag parent color)) + (text nil)) + (setq text + (concat + protstr + (if type (concat name type) + name))) + (if color + (setq text (semantic--format-uml-post-colorize text tag parent))) + text)) + +(define-overloadable-function semantic-format-tag-uml-prototype (tag &optional parent color) + "Return a UML style prototype for TAG. +Optional argument PARENT is the parent type if TAG is a detail. +Optional argument COLOR means highlight the prototype with font-lock colors.") + +(defun semantic-format-tag-uml-prototype-default (tag &optional parent color) + "Return a UML style prototype for TAG. +Optional argument PARENT is the parent type if TAG is a detail. +Optional argument COLOR means highlight the prototype with font-lock colors." + (let* ((class (semantic-tag-class tag)) + (cp (semantic-format-tag-name tag parent color)) + (type (semantic--format-tag-uml-type tag color)) + (prot (semantic-format-tag-uml-protection tag parent color)) + (argtext + (cond ((eq class 'function) + (concat + " (" + (semantic--format-tag-arguments + (semantic-tag-function-arguments tag) + #'semantic-format-tag-uml-prototype + color) + ")")) + ((eq class 'type) + "{}"))) + (text nil)) + (setq text (concat prot cp argtext type)) + (if color + (setq text (semantic--format-uml-post-colorize text tag parent))) + text + )) + +(define-overloadable-function semantic-format-tag-uml-concise-prototype (tag &optional parent color) + "Return a UML style concise prototype for TAG. +Optional argument PARENT is the parent type if TAG is a detail. +Optional argument COLOR means highlight the prototype with font-lock colors.") + +(defun semantic-format-tag-uml-concise-prototype-default (tag &optional parent color) + "Return a UML style concise prototype for TAG. +Optional argument PARENT is the parent type if TAG is a detail. +Optional argument COLOR means highlight the prototype with font-lock colors." + (let* ((cp (semantic-format-tag-concise-prototype tag parent color)) + (type (semantic--format-tag-uml-type tag color)) + (prot (semantic-format-tag-uml-protection tag parent color)) + (text nil) + ) + (setq text (concat prot cp type)) + (if color + (setq text (semantic--format-uml-post-colorize text tag parent))) + text + )) + + +;;; Compatibility and aliases +;; +(semantic-alias-obsolete 'semantic-prin1-nonterminal + 'semantic-format-tag-prin1) + +(semantic-alias-obsolete 'semantic-name-nonterminal + 'semantic-format-tag-name) + +(semantic-alias-obsolete 'semantic-abbreviate-nonterminal + 'semantic-format-tag-abbreviate) + +(semantic-alias-obsolete 'semantic-summarize-nonterminal + 'semantic-format-tag-summarize) + +(semantic-alias-obsolete 'semantic-prototype-nonterminal + 'semantic-format-tag-prototype) + +(semantic-alias-obsolete 'semantic-concise-prototype-nonterminal + 'semantic-format-tag-concise-prototype) + +(semantic-alias-obsolete 'semantic-uml-abbreviate-nonterminal + 'semantic-format-tag-uml-abbreviate) + +(semantic-alias-obsolete 'semantic-uml-prototype-nonterminal + 'semantic-format-tag-uml-prototype) + +(semantic-alias-obsolete 'semantic-uml-concise-prototype-nonterminal + 'semantic-format-tag-uml-concise-prototype) + + +(provide 'semantic/format) + +;;; semantic-format.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/sort.el Fri Aug 28 19:18:35 2009 +0000 @@ -0,0 +1,592 @@ +;;; sort.el --- Utilities for sorting and re-arranging tag tables. + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, +;;; 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Tag tables originate in the order they appear in a buffer, or source file. +;; It is often useful to re-arrange them is some predictable way for browsing +;; purposes. Re-organization may be alphabetical, or even a complete +;; reorganization of parents and children. +;; +;; Originally written in semantic-util.el +;; + +(require 'assoc) +(require 'semantic) +(require 'semantic/db) +(eval-when-compile + (require 'semantic/find) + (require 'semantic/db-find)) + +;;; Alphanumeric sorting +;; +;; Takes a list of tags, and sorts them in a case-insensitive way +;; at a single level. + +;;; Code: +(defun semantic-string-lessp-ci (s1 s2) + "Case insensitive version of `string-lessp'. +Argument S1 and S2 are the strings to compare." + ;; Use downcase instead of upcase because an average name + ;; has more lower case characters. + (if (fboundp 'compare-strings) + (eq (compare-strings s1 0 nil s2 0 nil t) -1) + (string-lessp (downcase s1) (downcase s2)))) + +(defun semantic-sort-tag-type (tag) + "Return a type string for TAG guaranteed to be a string." + (let ((ty (semantic-tag-type tag))) + (cond ((stringp ty) + ty) + ((listp ty) + (or (car ty) "")) + (t "")))) + +(defun semantic-tag-lessp-name-then-type (A B) + "Return t if tag A is < tag B. +First sorts on name, then sorts on the name of the :type of +each tag." + (let ((na (semantic-tag-name A)) + (nb (semantic-tag-name B)) + ) + (if (string-lessp na nb) + t ; a sure thing. + (if (string= na nb) + ;; If equal, test the :type which might be different. + (let* ((ta (semantic-tag-type A)) + (tb (semantic-tag-type B)) + (tas (cond ((stringp ta) + ta) + ((semantic-tag-p ta) + (semantic-tag-name ta)) + (t nil))) + (tbs (cond ((stringp tb) + tb) + ((semantic-tag-p tb) + (semantic-tag-name tb)) + (t nil)))) + (if (and (stringp tas) (stringp tbs)) + (string< tas tbs) + ;; This is if A == B, and no types in A or B + nil)) + ;; This nil is if A > B, but not = + nil)))) + +(defun semantic-sort-tags-by-name-increasing (tags) + "Sort TAGS by name in increasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) + (string-lessp (semantic-tag-name a) + (semantic-tag-name b))))) + +(defun semantic-sort-tags-by-name-decreasing (tags) + "Sort TAGS by name in decreasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) + (string-lessp (semantic-tag-name b) + (semantic-tag-name a))))) + +(defun semantic-sort-tags-by-type-increasing (tags) + "Sort TAGS by type in increasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) + (string-lessp (semantic-sort-tag-type a) + (semantic-sort-tag-type b))))) + +(defun semantic-sort-tags-by-type-decreasing (tags) + "Sort TAGS by type in decreasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) + (string-lessp (semantic-sort-tag-type b) + (semantic-sort-tag-type a))))) + +(defun semantic-sort-tags-by-name-increasing-ci (tags) + "Sort TAGS by name in increasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) + (semantic-string-lessp-ci (semantic-tag-name a) + (semantic-tag-name b))))) + +(defun semantic-sort-tags-by-name-decreasing-ci (tags) + "Sort TAGS by name in decreasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) + (semantic-string-lessp-ci (semantic-tag-name b) + (semantic-tag-name a))))) + +(defun semantic-sort-tags-by-type-increasing-ci (tags) + "Sort TAGS by type in increasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) + (semantic-string-lessp-ci (semantic-sort-tag-type a) + (semantic-sort-tag-type b))))) + +(defun semantic-sort-tags-by-type-decreasing-ci (tags) + "Sort TAGS by type in decreasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) + (semantic-string-lessp-ci (semantic-sort-tag-type b) + (semantic-sort-tag-type a))))) + +(defun semantic-sort-tags-by-name-then-type-increasing (tags) + "Sort TAGS by name, then type in increasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) (semantic-tag-lessp-name-then-type a b)))) + +(defun semantic-sort-tags-by-name-then-type-decreasing (tags) + "Sort TAGS by name, then type in increasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) (semantic-tag-lessp-name-then-type b a)))) + + +(semantic-alias-obsolete 'semantic-sort-tokens-by-name-increasing + 'semantic-sort-tags-by-name-increasing) +(semantic-alias-obsolete 'semantic-sort-tokens-by-name-decreasing + 'semantic-sort-tags-by-name-decreasing) +(semantic-alias-obsolete 'semantic-sort-tokens-by-type-increasing + 'semantic-sort-tags-by-type-increasing) +(semantic-alias-obsolete 'semantic-sort-tokens-by-type-decreasing + 'semantic-sort-tags-by-type-decreasing) +(semantic-alias-obsolete 'semantic-sort-tokens-by-name-increasing-ci + 'semantic-sort-tags-by-name-increasing-ci) +(semantic-alias-obsolete 'semantic-sort-tokens-by-name-decreasing-ci + 'semantic-sort-tags-by-name-decreasing-ci) +(semantic-alias-obsolete 'semantic-sort-tokens-by-type-increasing-ci + 'semantic-sort-tags-by-type-increasing-ci) +(semantic-alias-obsolete 'semantic-sort-tokens-by-type-decreasing-ci + 'semantic-sort-tags-by-type-decreasing-ci) + + +;;; Unique +;; +;; Scan a list of tags, removing duplicates. +;; This must first sort the tags by name alphabetically ascending. +;; +;; Useful for completion lists, or other situations where the +;; other data isn't as useful. + +(defun semantic-unique-tag-table-by-name (tags) + "Scan a list of TAGS, removing duplicate names. +This must first sort the tags by name alphabetically ascending. +For more complex uniqueness testing used by the semanticdb +typecaching system, see `semanticdb-typecache-merge-streams'." + (let ((sorted (semantic-sort-tags-by-name-increasing + (copy-sequence tags))) + (uniq nil)) + (while sorted + (if (or (not uniq) + (not (string= (semantic-tag-name (car sorted)) + (semantic-tag-name (car uniq))))) + (setq uniq (cons (car sorted) uniq))) + (setq sorted (cdr sorted)) + ) + (nreverse uniq))) + +(defun semantic-unique-tag-table (tags) + "Scan a list of TAGS, removing duplicates. +This must first sort the tags by position ascending. +TAGS are removed only if they are equivalent, as can happen when +multiple tag sources are scanned. +For more complex uniqueness testing used by the semanticdb +typecaching system, see `semanticdb-typecache-merge-streams'." + (let ((sorted (sort (copy-sequence tags) + (lambda (a b) + (cond ((not (semantic-tag-with-position-p a)) + t) + ((not (semantic-tag-with-position-p b)) + nil) + (t + (< (semantic-tag-start a) + (semantic-tag-start b))))))) + (uniq nil)) + (while sorted + (if (or (not uniq) + (not (semantic-equivalent-tag-p (car sorted) (car uniq)))) + (setq uniq (cons (car sorted) uniq))) + (setq sorted (cdr sorted)) + ) + (nreverse uniq))) + + +;;; Tag Table Flattening +;; +;; In the 1.4 search API, there was a parameter "search-parts" which +;; was used to find tags inside other tags. This was used +;; infrequently, mostly for completion/jump routines. These types +;; of commands would be better off with a flattened list, where all +;; tags appear at the top level. + +(defun semantic-flatten-tags-table (&optional table) + "Flatten the tags table TABLE. +All tags in TABLE, and all components of top level tags +in TABLE will appear at the top level of list. +Tags promoted to the top of the list will still appear +unmodified as components of their parent tags." + (let* ((table (semantic-something-to-tag-table table)) + ;; Initialize the starting list with our table. + (lists (list table))) + (mapc (lambda (tag) + (let ((components (semantic-tag-components tag))) + (if (and components + ;; unpositined tags can be hazardous to + ;; completion. Do we need any type of tag + ;; here? - EL + (semantic-tag-with-position-p (car components))) + (setq lists (cons + (semantic-flatten-tags-table components) + lists))))) + table) + (apply 'append (nreverse lists)) + )) + + +;;; Buckets: +;; +;; A list of tags can be grouped into buckets based on the tag class. +;; Bucketize means to take a list of tags at a given level in a tag +;; table, and reorganize them into buckets based on class. +;; +(defvar semantic-bucketize-tag-class + ;; Must use lambda because `semantic-tag-class' is a macro. + (lambda (tok) (semantic-tag-class tok)) + "Function used to get a symbol describing the class of a tag. +This function must take one argument of a semantic tag. +It should return a symbol found in `semantic-symbol->name-assoc-list' +which `semantic-bucketize' uses to bin up tokens. +To create new bins for an application augment +`semantic-symbol->name-assoc-list', and +`semantic-symbol->name-assoc-list-for-type-parts' in addition +to setting this variable (locally in your function).") + +(defun semantic-bucketize (tags &optional parent filter) + "Sort TAGS into a group of buckets based on tag class. +Unknown classes are placed in a Misc bucket. +Type bucket names are defined by either `semantic-symbol->name-assoc-list'. +If PARENT is specified, then TAGS belong to this PARENT in some way. +This will use `semantic-symbol->name-assoc-list-for-type-parts' to +generate bucket names. +Optional argument FILTER is a filter function to be applied to each bucket. +The filter function will take one argument, which is a list of tokens, and +may re-organize the list with side-effects." + (let* ((name-list (if parent + semantic-symbol->name-assoc-list-for-type-parts + semantic-symbol->name-assoc-list)) + (sn name-list) + (bins (make-vector (1+ (length sn)) nil)) + ask tagtype + (nsn nil) + (num 1) + (out nil)) + ;; Build up the bucket vector + (while sn + (setq nsn (cons (cons (car (car sn)) num) nsn) + sn (cdr sn) + num (1+ num))) + ;; Place into buckets + (while tags + (setq tagtype (funcall semantic-bucketize-tag-class (car tags)) + ask (assq tagtype nsn) + num (or (cdr ask) 0)) + (aset bins num (cons (car tags) (aref bins num))) + (setq tags (cdr tags))) + ;; Remove from buckets into a list. + (setq num 1) + (while (< num (length bins)) + (when (aref bins num) + (setq out + (cons (cons + (cdr (nth (1- num) name-list)) + ;; Filtering, First hacked by David Ponce david@dponce.com + (funcall (or filter 'nreverse) (aref bins num))) + out))) + (setq num (1+ num))) + (if (aref bins 0) + (setq out (cons (cons "Misc" + (funcall (or filter 'nreverse) (aref bins 0))) + out))) + (nreverse out))) + +;;; Adoption +;; +;; Some languages allow children of a type to be defined outside +;; the syntactic scope of that class. These routines will find those +;; external members, and bring them together in a cloned copy of the +;; class tag. +;; +(defvar semantic-orphaned-member-metaparent-type "class" + "In `semantic-adopt-external-members', the type of 'type for metaparents. +A metaparent is a made-up type semantic token used to hold the child list +of orphaned members of a named type.") +(make-variable-buffer-local 'semantic-orphaned-member-metaparent-type) + +(defvar semantic-mark-external-member-function nil + "Function called when an externally defined orphan is found. +By default, the token is always marked with the `adopted' property. +This function should be locally bound by a program that needs +to add additional behaviors into the token list. +This function is called with two arguments. The first is TOKEN which is +a shallow copy of the token to be modified. The second is the PARENT +which is adopting TOKEN. This function should return TOKEN (or a copy of it) +which is then integrated into the revised token list.") + +(defun semantic-adopt-external-members (tags) + "Rebuild TAGS so that externally defined members are regrouped. +Some languages such as C++ and CLOS permit the declaration of member +functions outside the definition of the class. It is easier to study +the structure of a program when such methods are grouped together +more logically. + +This function uses `semantic-tag-external-member-p' to +determine when a potential child is an externally defined member. + +Note: Applications which use this function must account for token +types which do not have a position, but have children which *do* +have positions. + +Applications should use `semantic-mark-external-member-function' +to modify all tags which are found as externally defined to some +type. For example, changing the token type for generating extra +buckets with the bucket function." + (let ((parent-buckets nil) + (decent-list nil) + (out nil) + (tmp nil) + ) + ;; Rebuild the output list, stripping out all parented + ;; external entries + (while tags + (cond + ((setq tmp (semantic-tag-external-member-parent (car tags))) + (let ((tagcopy (semantic-tag-clone (car tags))) + (a (assoc tmp parent-buckets))) + (semantic--tag-put-property-no-side-effect tagcopy 'adopted t) + (if a + ;; If this parent is already in the list, append. + (setcdr (nthcdr (1- (length a)) a) (list tagcopy)) + ;; If not, prepend this new parent bucket into our list + (setq parent-buckets + (cons (cons tmp (list tagcopy)) parent-buckets))) + )) + ((eq (semantic-tag-class (car tags)) 'type) + ;; Types need to be rebuilt from scratch so we can add in new + ;; children to the child list. Only the top-level cons + ;; cells need to be duplicated so we can hack out the + ;; child list later. + (setq out (cons (semantic-tag-clone (car tags)) out)) + (setq decent-list (cons (car out) decent-list)) + ) + (t + ;; Otherwise, append this tag to our new output list. + (setq out (cons (car tags) out))) + ) + (setq tags (cdr tags))) + ;; Rescan out, by descending into all types and finding parents + ;; for all entries moved into the parent-buckets. + (while decent-list + (let* ((bucket (assoc (semantic-tag-name (car decent-list)) + parent-buckets)) + (bucketkids (cdr bucket))) + (when bucket + ;; Run our secondary marking function on the children + (if semantic-mark-external-member-function + (setq bucketkids + (mapcar (lambda (tok) + (funcall semantic-mark-external-member-function + tok (car decent-list))) + bucketkids))) + ;; We have some extra kids. Merge. + (semantic-tag-put-attribute + (car decent-list) :members + (append (semantic-tag-type-members (car decent-list)) + bucketkids)) + ;; Nuke the bucket label so it is not found again. + (setcar bucket nil)) + (setq decent-list + (append (cdr decent-list) + ;; get embedded types to scan and make copies + ;; of them. + (mapcar + (lambda (tok) (semantic-tag-clone tok)) + (semantic-find-tags-by-class 'type + (semantic-tag-type-members (car decent-list))))) + ))) + ;; Scan over all remaining lost external methods, and tack them + ;; onto the end. + (while parent-buckets + (if (car (car parent-buckets)) + (let* ((tmp (car parent-buckets)) + (fauxtag (semantic-tag-new-type + (car tmp) + semantic-orphaned-member-metaparent-type + nil ;; Part list + nil ;; parents (unknown) + )) + (bucketkids (cdr tmp))) + (semantic-tag-set-faux fauxtag) ;; properties + (if semantic-mark-external-member-function + (setq bucketkids + (mapcar (lambda (tok) + (funcall semantic-mark-external-member-function + tok fauxtag)) + bucketkids))) + (semantic-tag-put-attribute fauxtag :members bucketkids) + ;; We have a bunch of methods with no parent in this file. + ;; Create a meta-type to hold it. + (setq out (cons fauxtag out)) + )) + (setq parent-buckets (cdr parent-buckets))) + ;; Return the new list. + (nreverse out))) + + +;;; External children +;; +;; In order to adopt external children, we need a few overload methods +;; to enable the feature. +;; +(define-overloadable-function semantic-tag-external-member-parent (tag) + "Return a parent for TAG when TAG is an external member. +TAG is an external member if it is defined at a toplevel and +has some sort of label defining a parent. The parent return will +be a string. + +The default behavior, if not overridden with +`tag-member-parent' gets the 'parent extra +specifier of TAG. + +If this function is overridden, use +`semantic-tag-external-member-parent-default' to also +include the default behavior, and merely extend your own." + ) + +(defun semantic-tag-external-member-parent-default (tag) + "Return the name of TAGs parent only if TAG is not defined in it's parent." + ;; Use only the extra spec because a type has a parent which + ;; means something completely different. + (let ((tp (semantic-tag-get-attribute tag :parent))) + (when (stringp tp) + tp) + )) + +(semantic-alias-obsolete 'semantic-nonterminal-external-member-parent + 'semantic-tag-external-member-parent) + +(define-overloadable-function semantic-tag-external-member-p (parent tag) + "Return non-nil if PARENT is the parent of TAG. +TAG is an external member of PARENT when it is somehow tagged +as having PARENT as it's parent. +PARENT and TAG must both be semantic tags. + +The default behavior, if not overridden with +`tag-external-member-p' is to match :parent attribute in +the name of TAG. + +If this function is overridden, use +`semantic-tag-external-member-children-p-default' to also +include the default behavior, and merely extend your own." + ) + +(defun semantic-tag-external-member-p-default (parent tag) + "Return non-nil if PARENT is the parent of TAG." + ;; Use only the extra spec because a type has a parent which + ;; means something completely different. + (let ((tp (semantic-tag-external-member-parent tag))) + (and (stringp tp) + (string= (semantic-tag-name parent) tp)) + )) + +(semantic-alias-obsolete 'semantic-nonterminal-external-member-p + 'semantic-tag-external-member-p) + +(define-overloadable-function semantic-tag-external-member-children (tag &optional usedb) + "Return the list of children which are not *in* TAG. +If optional argument USEDB is non-nil, then also search files in +the Semantic Database. If USEDB is a list of databases, search those +databases. + +Children in this case are functions or types which are members of +TAG, such as the parts of a type, but which are not defined inside +the class. C++ and CLOS both permit methods of a class to be defined +outside the bounds of the class' definition. + +The default behavior, if not overridden with +`tag-external-member-children' is to search using +`semantic-tag-external-member-p' in all top level definitions +with a parent of TAG. + +If this function is overridden, use +`semantic-tag-external-member-children-default' to also +include the default behavior, and merely extend your own." + ) + +(defun semantic-tag-external-member-children-default (tag &optional usedb) + "Return list of external children for TAG. +Optional argument USEDB specifies if the semantic database is used. +See `semantic-tag-external-member-children' for details." + (if (and usedb + (fboundp 'semanticdb-minor-mode-p) + (semanticdb-minor-mode-p)) + (let ((m (semanticdb-find-tags-external-children-of-type + (semantic-tag-name tag)))) + (if m (apply #'append (mapcar #'cdr m)))) + (semantic--find-tags-by-function + `(lambda (tok) + ;; This bit of annoying backquote forces the contents of + ;; tag into the generated lambda. + (semantic-tag-external-member-p ',tag tok)) + (current-buffer)) + )) + +(define-overloadable-function semantic-tag-external-class (tag) + "Return a list of real tags that faux TAG might represent. + +In some languages, a method can be defined on an object which is +not in the same file. In this case, +`semantic-adopt-external-members' will create a faux-tag. If it +is necessary to get the tag from which for faux TAG was most +likely derived, then this function is needed." + (unless (semantic-tag-faux-p tag) + (signal 'wrong-type-argument (list tag 'semantic-tag-faux-p))) + (:override) + ) + +(defun semantic-tag-external-class-default (tag) + "Return a list of real tags that faux TAG might represent. +See `semantic-tag-external-class' for details." + (if (and (fboundp 'semanticdb-minor-mode-p) + (semanticdb-minor-mode-p)) + (let* ((semanticdb-search-system-databases nil) + (m (semanticdb-find-tags-by-class + (semantic-tag-class tag) + (semanticdb-find-tags-by-name (semantic-tag-name tag))))) + (semanticdb-strip-find-results m 'name)) + ;; Presumably, if the tag is faux, it is not local. + nil + )) + +(semantic-alias-obsolete 'semantic-nonterminal-external-member-children + 'semantic-tag-external-member-children) + +(provide 'semantic/sort) + +;;; semantic-sort.el ends here