--- /dev/null
+;;; 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)
+\f
+;;; 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
+;;; 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))
+
+\f
+;;; 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 "*")
+ )))
+\f
+;;; 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) )
+ ))
+
+
+\f
+;;; 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))
+\f
+;;; 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
+;;; 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
+;;; 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:
+\f
+;;; 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)))
+\f
+;;; 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))
+\f
+;;
+;; ************************** 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))))
+\f
+;;; 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
+;;; 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)
+
+
+\f
+;;; 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)
+ ))
+
+\f
+;;; 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
+ ))
+
+\f
+;;; 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
+;;; 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)
+
+\f
+;;; 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)))
+
+\f
+;;; 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))
+ ))
+
+\f
+;;; 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)))
+\f
+;;; 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)))
+
+\f
+;;; 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
projects / emacs.git / commitdiff