semantic/cedet/sb.el, semantic/cedet/scope.el: New files.
--- /dev/null
+;;; semantic/db-global.el --- Semantic database extensions for GLOBAL
+
+;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 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:
+;;
+;; Use GNU Global for by-name database searches.
+;;
+;; This will work as an "omniscient" database for a given project.
+;;
+
+(require 'cedet-global)
+(require 'semantic/db-search)
+(require 'semantic/symref/global)
+
+(eval-when-compile
+ ;; For generic function searching.
+ (require 'eieio)
+ (require 'eieio-opt)
+ )
+;;; Code:
+(defun semanticdb-enable-gnu-global-databases (mode)
+ "Enable the use of the GNU Global SemanticDB back end for all files of MODE.
+This will add an instance of a GNU Global database to each buffer
+in a GNU Global supported hierarchy."
+ (interactive
+ (list (completing-read
+ "Emable in Mode: " obarray
+ #'(lambda (s) (get s 'mode-local-symbol-table))
+ t (symbol-name major-mode))))
+
+ ;; First, make sure the version is ok.
+ (cedet-gnu-global-version-check)
+
+ ;; Make sure mode is a symbol.
+ (when (stringp mode)
+ (setq mode (intern mode)))
+
+ (let ((ih (mode-local-value mode 'semantic-init-mode-hooks)))
+ (eval `(setq-mode-local
+ ,mode semantic-init-mode-hooks
+ (cons 'semanticdb-enable-gnu-global-hook ih))))
+
+ )
+
+(defun semanticdb-enable-gnu-global-hook ()
+ "Add support for GNU Global in the current buffer via semantic-init-hook.
+MODE is the major mode to support."
+ (semanticdb-enable-gnu-global-in-buffer t))
+
+(defun semanticdb-enable-gnu-global-in-buffer (&optional dont-err-if-not-available)
+ "Enable a GNU Global database in the current buffer.
+Argument DONT-ERR-IF-NOT-AVAILABLE will throw an error if GNU Global
+is not available for this directory."
+ (interactive "P")
+ (if (cedet-gnu-global-root)
+ (setq
+ ;; Add to the system database list.
+ semanticdb-project-system-databases
+ (cons (semanticdb-project-database-global "global")
+ semanticdb-project-system-databases)
+ ;; Apply the throttle.
+ semanticdb-find-default-throttle
+ (append semanticdb-find-default-throttle
+ '(omniscience))
+ )
+ (if dont-err-if-not-available
+ (message "No Global support in %s" default-directory)
+ (error "No Global support in %s" default-directory))
+ ))
+
+;;; Classes:
+(defclass semanticdb-table-global (semanticdb-search-results-table)
+ ((major-mode :initform nil)
+ )
+ "A table for returning search results from GNU Global.")
+
+(defclass semanticdb-project-database-global
+ ;; @todo - convert to one DB per directory.
+ (semanticdb-project-database eieio-instance-tracker)
+ ()
+ "Database representing a GNU Global tags file.")
+
+(defmethod semanticdb-equivalent-mode ((table semanticdb-table-global) &optional buffer)
+ "Return t, pretend that this table's mode is equivalent to BUFFER.
+Equivalent modes are specified by by `semantic-equivalent-major-modes'
+local variable."
+ ;; @todo - hack alert!
+ t)
+
+;;; Filename based methods
+;;
+(defmethod semanticdb-get-database-tables ((obj semanticdb-project-database-global))
+ "For a global database, there are no explicit tables.
+For each file hit, get the traditional semantic table from that file."
+ ;; We need to return something since there is always the "master table"
+ ;; The table can then answer file name type questions.
+ (when (not (slot-boundp obj 'tables))
+ (let ((newtable (semanticdb-table-global "GNU Global Search Table")))
+ (oset obj tables (list newtable))
+ (oset newtable parent-db obj)
+ (oset newtable tags nil)
+ ))
+
+ (call-next-method))
+
+(defmethod semanticdb-file-table ((obj semanticdb-project-database-global) filename)
+ "From OBJ, return FILENAME's associated table object."
+ ;; We pass in "don't load". I wonder if we need to avoid that or not?
+ (car (semanticdb-get-database-tables obj))
+ )
+
+;;; Search Overrides
+;;
+;; Only NAME based searches work with GLOBAL as that is all it tracks.
+;;
+(defmethod semanticdb-find-tags-by-name-method
+ ((table semanticdb-table-global) name &optional tags)
+ "Find all tags named NAME in TABLE.
+Return a list of tags."
+ (if tags
+ ;; If TAGS are passed in, then we don't need to do work here.
+ (call-next-method)
+ ;; Call out to GNU Global for some results.
+ (let* ((semantic-symref-tool 'global)
+ (result (semantic-symref-find-tags-by-name name 'project))
+ )
+ (when result
+ ;; We could ask to keep the buffer open, but that annoys
+ ;; people.
+ (semantic-symref-result-get-tags result))
+ )))
+
+(defmethod semanticdb-find-tags-by-name-regexp-method
+ ((table semanticdb-table-global) regex &optional tags)
+ "Find all tags with name matching REGEX in TABLE.
+Optional argument TAGS is a list of tags to search.
+Return a list of tags."
+ (if tags (call-next-method)
+ ;; YOUR IMPLEMENTATION HERE
+ (let* ((semantic-symref-tool 'global)
+ (result (semantic-symref-find-tags-by-regexp regex 'project))
+ )
+ (when result
+ (semantic-symref-result-get-tags result))
+ )))
+
+(defmethod semanticdb-find-tags-for-completion-method
+ ((table semanticdb-table-global) 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."
+ (if tags (call-next-method)
+ (let* ((semantic-symref-tool 'global)
+ (result (semantic-symref-find-tags-by-completion prefix 'project))
+ (faketags nil)
+ )
+ (when result
+ (dolist (T (oref result :hit-text))
+ ;; We should look up each tag one at a time, but I'm lazy!
+ ;; Doing this may be good enough.
+ (setq faketags (cons
+ (semantic-tag T 'function :faux t)
+ faketags))
+ )
+ faketags))))
+
+;;; Deep Searches
+;;
+;; If your language does not have a `deep' concept, these can be left
+;; alone, otherwise replace with implementations similar to those
+;; above.
+;;
+(defmethod semanticdb-deep-find-tags-by-name-method
+ ((table semanticdb-table-global) name &optional tags)
+ "Find all tags name NAME in TABLE.
+Optional argument TAGS is a list of tags t
+Like `semanticdb-find-tags-by-name-method' for global."
+ (semanticdb-find-tags-by-name-method table name tags))
+
+(defmethod semanticdb-deep-find-tags-by-name-regexp-method
+ ((table semanticdb-table-global) regex &optional tags)
+ "Find all tags with name matching REGEX in TABLE.
+Optional argument TAGS is a list of tags to search.
+Like `semanticdb-find-tags-by-name-method' for global."
+ (semanticdb-find-tags-by-name-regexp-method table regex tags))
+
+(defmethod semanticdb-deep-find-tags-for-completion-method
+ ((table semanticdb-table-global) prefix &optional tags)
+ "In TABLE, find all occurances of tags matching PREFIX.
+Optional argument TAGS is a list of tags to search.
+Like `semanticdb-find-tags-for-completion-method' for global."
+ (semanticdb-find-tags-for-completion-method table prefix tags))
+
+;;; TEST
+;;
+;; Here is a testing fcn to try out searches via the GNU Global database.
+(defvar semanticdb-test-gnu-global-startfile "~/src/global-5.7.3/global/global.c"
+ "File to use for testing.")
+
+(defun semanticdb-test-gnu-global (searchfor &optional standardfile)
+ "Test the GNU Global semanticdb.
+Argument SEARCHFOR is the text to search for.
+If optional arg STANDARDFILE is non nil, use a standard file w/ global enabled."
+ (interactive "sSearch For Tag: \nP")
+
+ (require 'data-debug)
+ (save-excursion
+ (when standardfile
+ (set-buffer (find-file-noselect semanticdb-test-gnu-global-startfile)))
+
+ (condition-case err
+ (semanticdb-enable-gnu-global-in-buffer)
+ (error (if standardfile
+ (error err)
+ (set-buffer (find-file-noselect semanticdb-test-gnu-global-startfile))
+ (semanticdb-enable-gnu-global-in-buffer))))
+
+ (let* ((db (semanticdb-project-database-global "global"))
+ (tab (semanticdb-file-table db (buffer-file-name)))
+ (result (semanticdb-deep-find-tags-for-completion-method tab searchfor))
+ )
+ (data-debug-new-buffer "*SemanticDB Gnu Global Result*")
+ (data-debug-insert-thing result "?" "")
+ )))
+
+(provide 'semantic/db-global)
+
+;;; semantic/db-global.el ends here
--- /dev/null
+;;; semantic/ia-sb.el --- Speedbar analysis display interactor
+
+;;; Copyright (C) 2002, 2003, 2004, 2006, 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:
+;;
+;; Speedbar node for displaying derived context information.
+;;
+
+(require 'semantic/analyze)
+(require 'speedbar)
+
+;;; Code:
+(defvar semantic-ia-sb-key-map nil
+ "Keymap used when in semantic analysis display mode.")
+
+(if semantic-ia-sb-key-map
+ nil
+ (setq semantic-ia-sb-key-map (speedbar-make-specialized-keymap))
+
+ ;; Basic featuers.
+ (define-key semantic-ia-sb-key-map "\C-m" 'speedbar-edit-line)
+ (define-key semantic-ia-sb-key-map "I" 'semantic-ia-sb-show-tag-info)
+ )
+
+(defvar semantic-ia-sb-easymenu-definition
+ '( "---"
+; [ "Expand" speedbar-expand-line nil ]
+; [ "Contract" speedbar-contract-line nil ]
+ [ "Tag Information" semantic-ia-sb-show-tag-info t ]
+ [ "Jump to Tag" speedbar-edit-line t ]
+ [ "Complete" speedbar-edit-line t ]
+ )
+ "Extra menu items Analysis mode.")
+
+;; Make sure our special speedbar major mode is loaded
+(speedbar-add-expansion-list '("Analyze"
+ semantic-ia-sb-easymenu-definition
+ semantic-ia-sb-key-map
+ semantic-ia-speedbar))
+
+(speedbar-add-mode-functions-list
+ (list "Analyze"
+ ;;'(speedbar-item-info . eieio-speedbar-item-info)
+ '(speedbar-line-directory . semantic-ia-sb-line-path)))
+
+(defun semantic-speedbar-analysis ()
+ "Start Speedbar in semantic analysis mode.
+The analyzer displays information about the current context, plus a smart
+list of possible completions."
+ (interactive)
+ ;; Make sure that speedbar is active
+ (speedbar-frame-mode 1)
+ ;; Now, throw us into Analyze mode on speedbar.
+ (speedbar-change-initial-expansion-list "Analyze")
+ )
+
+(defun semantic-ia-speedbar (directory zero)
+ "Create buttons in speedbar which define the current analysis at POINT.
+DIRECTORY is the current directory, which is ignored, and ZERO is 0."
+ (let ((analysis nil)
+ (scope nil)
+ (buffer nil)
+ (completions nil)
+ (cf (selected-frame))
+ (cnt nil)
+ (mode-local-active-mode nil)
+ )
+ ;; Try and get some sort of analysis
+ (condition-case nil
+ (progn
+ (speedbar-select-attached-frame)
+ (setq buffer (current-buffer))
+ (setq mode-local-active-mode major-mode)
+ (save-excursion
+ ;; Get the current scope
+ (setq scope (semantic-calculate-scope (point)))
+ ;; Get the analysis
+ (setq analysis (semantic-analyze-current-context (point)))
+ (setq cnt (semantic-find-tag-by-overlay))
+ (when analysis
+ (setq completions (semantic-analyze-possible-completions analysis))
+ )
+ ))
+ (error nil))
+ (select-frame cf)
+ (save-excursion
+ (set-buffer speedbar-buffer)
+ ;; If we have something, do something spiff with it.
+ (erase-buffer)
+ (speedbar-insert-separator "Buffer/Function")
+ ;; Note to self: Turn this into an expandable file name.
+ (speedbar-make-tag-line 'bracket ? nil nil
+ (buffer-name buffer)
+ nil nil 'speedbar-file-face 0)
+
+ (when cnt
+ (semantic-ia-sb-string-list cnt
+ 'speedbar-tag-face
+ 'semantic-sb-token-jump))
+ (when analysis
+ ;; If this analyzer happens to point at a complete symbol, then
+ ;; see if we can dig up some documentation for it.
+ (semantic-ia-sb-show-doc analysis))
+
+ (when analysis
+ ;; Let different classes draw more buttons.
+ (semantic-ia-sb-more-buttons analysis)
+ (when completions
+ (speedbar-insert-separator "Completions")
+ (semantic-ia-sb-completion-list completions
+ 'speedbar-tag-face
+ 'semantic-ia-sb-complete))
+ )
+
+ ;; Show local variables
+ (when scope
+ (semantic-ia-sb-show-scope scope))
+
+ )))
+
+(defmethod semantic-ia-sb-show-doc ((context semantic-analyze-context))
+ "Show documentation about CONTEXT iff CONTEXT points at a complete symbol."
+ (let ((sym (car (reverse (oref context prefix))))
+ (doc nil))
+ (when (semantic-tag-p sym)
+ (setq doc (semantic-documentation-for-tag sym))
+ (when doc
+ (speedbar-insert-separator "Documentation")
+ (insert doc)
+ (insert "\n")
+ ))
+ ))
+
+(defun semantic-ia-sb-show-scope (scope)
+ "Show SCOPE information."
+ (let ((localvars (when scope
+ (oref scope localvar)))
+ )
+ (when localvars
+ (speedbar-insert-separator "Local Variables")
+ (semantic-ia-sb-string-list localvars
+ 'speedbar-tag-face
+ ;; This is from semantic-sb
+ 'semantic-sb-token-jump))))
+
+(defmethod semantic-ia-sb-more-buttons ((context semantic-analyze-context))
+ "Show a set of speedbar buttons specific to CONTEXT."
+ (let ((prefix (oref context prefix)))
+ (when prefix
+ (speedbar-insert-separator "Prefix")
+ (semantic-ia-sb-string-list prefix
+ 'speedbar-tag-face
+ 'semantic-sb-token-jump))
+ ))
+
+(defmethod semantic-ia-sb-more-buttons ((context semantic-analyze-context-assignment))
+ "Show a set of speedbar buttons specific to CONTEXT."
+ (call-next-method)
+ (let ((assignee (oref context assignee)))
+ (when assignee
+ (speedbar-insert-separator "Assignee")
+ (semantic-ia-sb-string-list assignee
+ 'speedbar-tag-face
+ 'semantic-sb-token-jump))))
+
+(defmethod semantic-ia-sb-more-buttons ((context semantic-analyze-context-functionarg))
+ "Show a set of speedbar buttons specific to CONTEXT."
+ (call-next-method)
+ (let ((func (oref context function)))
+ (when func
+ (speedbar-insert-separator "Function")
+ (semantic-ia-sb-string-list func
+ 'speedbar-tag-face
+ 'semantic-sb-token-jump)
+ ;; An index for the argument the prefix is in:
+ (let ((arg (oref context argument))
+ (args (semantic-tag-function-arguments (car func)))
+ (idx 0)
+ )
+ (speedbar-insert-separator
+ (format "Argument #%d" (oref context index)))
+ (if args
+ (semantic-ia-sb-string-list args
+ 'speedbar-tag-face
+ 'semantic-sb-token-jump
+ (oref context index)
+ 'speedbar-selected-face)
+ ;; Else, no args list, so use what the context had.
+ (semantic-ia-sb-string-list arg
+ 'speedbar-tag-face
+ 'semantic-sb-token-jump))
+ ))))
+
+(defun semantic-ia-sb-string-list (list face function &optional idx idxface)
+ "Create some speedbar buttons from LIST.
+Each button will use FACE, and be activated with FUNCTION.
+Optional IDX is an index into LIST to apply IDXFACE instead."
+ (let ((count 1))
+ (while list
+ (let* ((usefn nil)
+ (string (cond ((stringp (car list))
+ (car list))
+ ((semantic-tag-p (car list))
+ (setq usefn (semantic-tag-with-position-p (car list)))
+ (semantic-format-tag-uml-concise-prototype (car list)))
+ (t "<No Tag>")))
+ (localface (if (or (not idx) (/= idx count))
+ face
+ idxface))
+ )
+ (if (semantic-tag-p (car list))
+ (speedbar-make-tag-line 'angle ?i
+ 'semantic-ia-sb-tag-info (car list)
+ string (if usefn function) (car list) localface
+ 0)
+ (speedbar-make-tag-line 'statictag ??
+ nil nil
+ string (if usefn function) (car list) localface
+ 0))
+ (setq list (cdr list)
+ count (1+ count)))
+ )))
+
+(defun semantic-ia-sb-completion-list (list face function)
+ "Create some speedbar buttons from LIST.
+Each button will use FACE, and be activated with FUNCTION."
+ (while list
+ (let* ((documentable nil)
+ (string (cond ((stringp (car list))
+ (car list))
+ ((semantic-tag-p (car list))
+ (setq documentable t)
+ (semantic-format-tag-uml-concise-prototype (car list)))
+ (t "foo"))))
+ (if documentable
+ (speedbar-make-tag-line 'angle ?i
+ 'semantic-ia-sb-tag-info
+ (car list)
+ string function (car list) face
+ 0)
+ (speedbar-make-tag-line 'statictag ? nil nil
+ string function (car list) face
+ 0))
+ (setq list (cdr list)))))
+
+(defun semantic-ia-sb-show-tag-info ()
+ "Display information about the tag on the current line.
+Same as clicking on the <i> button.
+See `semantic-ia-sb-tag-info' for more."
+ (interactive)
+ (let ((tok nil))
+ (save-excursion
+ (end-of-line)
+ (forward-char -1)
+ (setq tok (get-text-property (point) 'speedbar-token)))
+ (semantic-ia-sb-tag-info nil tok 0)))
+
+(defun semantic-ia-sb-tag-info (text tag indent)
+ "Display as much information as we can about tag.
+Show the information in a shrunk split-buffer and expand
+out as many details as possible.
+TEXT, TAG, and INDENT are speedbar function arguments."
+ (when (semantic-tag-p tag)
+ (unwind-protect
+ (let ((ob nil))
+ (speedbar-select-attached-frame)
+ (setq ob (current-buffer))
+ (with-output-to-temp-buffer "*Tag Information*"
+ ;; Output something about this tag:
+ (save-excursion
+ (set-buffer "*Tag Information*")
+ (goto-char (point-max))
+ (insert
+ (semantic-format-tag-prototype tag nil t)
+ "\n")
+ (let ((typetok
+ (condition-case nil
+ (save-excursion
+ (set-buffer ob)
+ ;; @todo - We need a context to derive a scope from.
+ (semantic-analyze-tag-type tag nil))
+ (error nil))))
+ (if typetok
+ (insert (semantic-format-tag-prototype
+ typetok nil t))
+ ;; No type found by the analyzer
+ ;; The below used to try and select the buffer from the last
+ ;; analysis, but since we are already in the correct buffer, I
+ ;; don't think that is needed.
+ (let ((type (semantic-tag-type tag)))
+ (cond ((semantic-tag-p type)
+ (setq type (semantic-tag-name type)))
+ ((listp type)
+ (setq type (car type))))
+ (if (semantic-lex-keyword-p type)
+ (setq typetok
+ (semantic-lex-keyword-get type 'summary))))
+ (if typetok
+ (insert typetok))
+ ))
+ ))
+ ;; Make it small
+ (shrink-window-if-larger-than-buffer
+ (get-buffer-window "*Tag Information*")))
+ (select-frame speedbar-frame))))
+
+(defun semantic-ia-sb-line-path (&optional depth)
+ "Return the file name associated with DEPTH."
+ (save-match-data
+ (let* ((tok (speedbar-line-token))
+ (buff (if (semantic-tag-buffer tok)
+ (semantic-tag-buffer tok)
+ (current-buffer))))
+ (buffer-file-name buff))))
+
+(defun semantic-ia-sb-complete (text tag indent)
+ "At point in the attached buffer, complete the symbol clicked on.
+TEXT TAG and INDENT are the details."
+ ;; Find the specified bounds from the current analysis.
+ (speedbar-select-attached-frame)
+ (unwind-protect
+ (let* ((a (semantic-analyze-current-context (point)))
+ (bounds (oref a bounds))
+ (movepoint nil)
+ )
+ (save-excursion
+ (if (and (<= (point) (cdr bounds)) (>= (point) (car bounds)))
+ (setq movepoint t))
+ (goto-char (car bounds))
+ (delete-region (car bounds) (cdr bounds))
+ (insert (semantic-tag-name tag))
+ (if movepoint (setq movepoint (point)))
+ ;; I'd like to use this to add fancy () or what not at the end
+ ;; but we need the parent file whih requires an upgrade to the
+ ;; analysis tool.
+ ;;(semantic-insert-foreign-tag tag ??))
+ )
+ (if movepoint
+ (let ((cf (selected-frame)))
+ (speedbar-select-attached-frame)
+ (goto-char movepoint)
+ (select-frame cf))))
+ (select-frame speedbar-frame)))
+
+(provide 'semantic/ia-sb)
+
+;;; semantic/ia-sb.el ends here
--- /dev/null
+;;; semantic/sb.el --- Semantic tag display for speedbar
+
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+;;; 2007, 2008 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:
+;;
+;; Convert a tag table into speedbar buttons.
+
+;;; TODO:
+
+;; Use semanticdb to find which semanticdb-table is being used for each
+;; file/tag. Replace `semantic-sb-with-tag-buffer' to instead call
+;; children with the new `with-mode-local' instead.
+
+(require 'semantic)
+(require 'semantic/util)
+(require 'speedbar)
+;; (require 'inversion)
+;; (eval-and-compile
+;; (inversion-require 'speedbar "0.15beta1"))
+
+(defcustom semantic-sb-autoexpand-length 1
+ "*Length of a semantic bucket to autoexpand in place.
+This will replace the named bucket that would have usually occured here."
+ :group 'speedbar
+ :type 'integer)
+
+(defcustom semantic-sb-button-format-tag-function 'semantic-format-tag-abbreviate
+ "*Function called to create the text for a but from a token."
+ :group 'speedbar
+ :type semantic-format-tag-custom-list)
+
+(defcustom semantic-sb-info-format-tag-function 'semantic-format-tag-summarize
+ "*Function called to create the text for info display from a token."
+ :group 'speedbar
+ :type semantic-format-tag-custom-list)
+
+;;; Code:
+;;
+
+;;; Buffer setting for correct mode manipulation.
+(defun semantic-sb-tag-set-buffer (tag)
+ "Set the current buffer to something associated with TAG.
+use the `speedbar-line-file' to get this info if needed."
+ (if (semantic-tag-buffer tag)
+ (set-buffer (semantic-tag-buffer tag))
+ (let ((f (speedbar-line-file)))
+ (set-buffer (find-file-noselect f)))))
+
+(defmacro semantic-sb-with-tag-buffer (tag &rest forms)
+ "Set the current buffer to the origin of TAG and execute FORMS.
+Restore the old current buffer when completed."
+ `(save-excursion
+ (semantic-sb-tag-set-buffer ,tag)
+ ,@forms))
+(put 'semantic-sb-with-tag-buffer 'lisp-indent-function 1)
+
+;;; Button Generation
+;;
+;; Here are some button groups:
+;;
+;; +> Function ()
+;; @ return_type
+;; +( arg1
+;; +| arg2
+;; +) arg3
+;;
+;; +> Variable[1] =
+;; @ type
+;; = default value
+;;
+;; +> keywrd Type
+;; +> type part
+;;
+;; +> -> click to see additional information
+
+(define-overloadable-function semantic-sb-tag-children-to-expand (tag)
+ "For TAG, return a list of children that TAG expands to.
+If this returns a value, then a +> icon is created.
+If it returns nil, then a => icon is created.")
+
+(defun semantic-sb-tag-children-to-expand-default (tag)
+ "For TAG, the children for type, variable, and function classes."
+ (semantic-sb-with-tag-buffer tag
+ (semantic-tag-components tag)))
+
+(defun semantic-sb-one-button (tag depth &optional prefix)
+ "Insert TAG as a speedbar button at DEPTH.
+Optional PREFIX is used to specify special marker characters."
+ (let* ((class (semantic-tag-class tag))
+ (edata (semantic-sb-tag-children-to-expand tag))
+ (type (semantic-tag-type tag))
+ (abbrev (semantic-sb-with-tag-buffer tag
+ (funcall semantic-sb-button-format-tag-function tag)))
+ (start (point))
+ (end (progn
+ (insert (int-to-string depth) ":")
+ (point))))
+ (insert-char ? (1- depth) nil)
+ (put-text-property end (point) 'invisible nil)
+ ;; take care of edata = (nil) -- a yucky but hard to clean case
+ (if (and edata (listp edata) (and (<= (length edata) 1) (not (car edata))))
+ (setq edata nil))
+ (if (and (not edata)
+ (member class '(variable function))
+ type)
+ (setq edata t))
+ ;; types are a bit unique. Variable types can have special meaning.
+ (if edata
+ (speedbar-insert-button (if prefix (concat " +" prefix) " +>")
+ 'speedbar-button-face
+ 'speedbar-highlight-face
+ 'semantic-sb-show-extra
+ tag t)
+ (speedbar-insert-button (if prefix (concat " " prefix) " =>")
+ nil nil nil nil t))
+ (speedbar-insert-button abbrev
+ 'speedbar-tag-face
+ 'speedbar-highlight-face
+ 'semantic-sb-token-jump
+ tag t)
+ ;; This is very bizarre. When this was just after the insertion
+ ;; of the depth: text, the : would get erased, but only for the
+ ;; auto-expanded short- buckets. Move back for a later version
+ ;; version of Emacs 21 CVS
+ (put-text-property start end 'invisible t)
+ ))
+
+(defun semantic-sb-speedbar-data-line (depth button text &optional
+ text-fun text-data)
+ "Insert a semantic token data element.
+DEPTH is the current depth. BUTTON is the text for the button.
+TEXT is the actual info with TEXT-FUN to occur when it happens.
+Argument TEXT-DATA is the token data to pass to TEXT-FUN."
+ (let ((start (point))
+ (end (progn
+ (insert (int-to-string depth) ":")
+ (point))))
+ (put-text-property start end 'invisible t)
+ (insert-char ? depth nil)
+ (put-text-property end (point) 'invisible nil)
+ (speedbar-insert-button button nil nil nil nil t)
+ (speedbar-insert-button text
+ 'speedbar-tag-face
+ (if text-fun 'speedbar-highlight-face)
+ text-fun text-data t)
+ ))
+
+(defun semantic-sb-maybe-token-to-button (obj indent &optional
+ prefix modifiers)
+ "Convert OBJ, which was returned from the semantic parser, into a button.
+This OBJ might be a plain string (simple type or untyped variable)
+or a complete tag.
+Argument INDENT is the indentation used when making the button.
+Optional PREFIX is the character to use when marking the line.
+Optional MODIFIERS is additional text needed for variables."
+ (let ((myprefix (or prefix ">")))
+ (if (stringp obj)
+ (semantic-sb-speedbar-data-line indent myprefix obj)
+ (if (listp obj)
+ (progn
+ (if (and (stringp (car obj))
+ (= (length obj) 1))
+ (semantic-sb-speedbar-data-line indent myprefix
+ (concat
+ (car obj)
+ (or modifiers "")))
+ (semantic-sb-one-button obj indent prefix)))))))
+
+(defun semantic-sb-insert-details (tag indent)
+ "Insert details about TAG at level INDENT."
+ (let ((tt (semantic-tag-class tag))
+ (type (semantic-tag-type tag)))
+ (cond ((eq tt 'type)
+ (let ((parts (semantic-tag-type-members tag))
+ (newparts nil))
+ ;; Lets expect PARTS to be a list of either strings,
+ ;; or variable tokens.
+ (when (semantic-tag-p (car parts))
+ ;; Bucketize into groups
+ (semantic-sb-with-tag-buffer (car parts)
+ (setq newparts (semantic-bucketize parts)))
+ (when (> (length newparts) semantic-sb-autoexpand-length)
+ ;; More than one bucket, insert inline
+ (semantic-sb-insert-tag-table (1- indent) newparts)
+ (setq parts nil))
+ ;; Dump the strings in.
+ (while parts
+ (semantic-sb-maybe-token-to-button (car parts) indent)
+ (setq parts (cdr parts))))))
+ ((eq tt 'variable)
+ (if type
+ (semantic-sb-maybe-token-to-button type indent "@"))
+ (let ((default (semantic-tag-variable-default tag)))
+ (if default
+ (semantic-sb-maybe-token-to-button default indent "=")))
+ )
+ ((eq tt 'function)
+ (if type
+ (semantic-sb-speedbar-data-line
+ indent "@"
+ (if (stringp type) type
+ (semantic-tag-name type))))
+ ;; Arguments to the function
+ (let ((args (semantic-tag-function-arguments tag)))
+ (if (and args (car args))
+ (progn
+ (semantic-sb-maybe-token-to-button (car args) indent "(")
+ (setq args (cdr args))
+ (while (> (length args) 1)
+ (semantic-sb-maybe-token-to-button (car args)
+ indent
+ "|")
+ (setq args (cdr args)))
+ (if args
+ (semantic-sb-maybe-token-to-button
+ (car args) indent ")"))
+ ))))
+ (t
+ (let ((components
+ (save-excursion
+ (when (and (semantic-tag-overlay tag)
+ (semantic-tag-buffer tag))
+ (set-buffer (semantic-tag-buffer tag)))
+ (semantic-sb-tag-children-to-expand tag))))
+ ;; Well, it wasn't one of the many things we expect.
+ ;; Lets just insert them in with no decoration.
+ (while components
+ (semantic-sb-one-button (car components) indent)
+ (setq components (cdr components)))
+ ))
+ )
+ ))
+
+(defun semantic-sb-detail-parent ()
+ "Return the first parent token of the current line that includes a location."
+ (save-excursion
+ (beginning-of-line)
+ (let ((dep (if (looking-at "[0-9]+:")
+ (1- (string-to-number (match-string 0)))
+ 0)))
+ (re-search-backward (concat "^"
+ (int-to-string dep)
+ ":")
+ nil t))
+ (beginning-of-line)
+ (if (looking-at "[0-9]+: +[-+][>()@|] \\([^\n]+\\)$")
+ (let ((prop nil))
+ (goto-char (match-beginning 1))
+ (setq prop (get-text-property (point) 'speedbar-token))
+ (if (semantic-tag-with-position-p prop)
+ prop
+ (semantic-sb-detail-parent)))
+ nil)))
+
+(defun semantic-sb-show-extra (text token indent)
+ "Display additional information about the token as an expansion.
+TEXT TOKEN and INDENT are the details."
+ (cond ((string-match "+" text) ;we have to expand this file
+ (speedbar-change-expand-button-char ?-)
+ (speedbar-with-writable
+ (save-excursion
+ (end-of-line) (forward-char 1)
+ (save-restriction
+ (narrow-to-region (point) (point))
+ ;; Add in stuff specific to this type of token.
+ (semantic-sb-insert-details token (1+ indent))))))
+ ((string-match "-" text) ;we have to contract this node
+ (speedbar-change-expand-button-char ?+)
+ (speedbar-delete-subblock indent))
+ (t (error "Ooops... not sure what to do")))
+ (speedbar-center-buffer-smartly))
+
+(defun semantic-sb-token-jump (text token indent)
+ "Jump to the location specified in token.
+TEXT TOKEN and INDENT are the details."
+ (let ((file
+ (or
+ (cond ((fboundp 'speedbar-line-path)
+ (speedbar-line-directory indent))
+ ((fboundp 'speedbar-line-directory)
+ (speedbar-line-directory indent)))
+ ;; If speedbar cannot figure this out, extract the filename from
+ ;; the token. True for Analysis mode.
+ (semantic-tag-file-name token)))
+ (parent (semantic-sb-detail-parent)))
+ (let ((f (selected-frame)))
+ (dframe-select-attached-frame speedbar-frame)
+ (run-hooks 'speedbar-before-visiting-tag-hook)
+ (select-frame f))
+ ;; Sometimes FILE may be nil here. If you are debugging a problem
+ ;; when this happens, go back and figure out why FILE is nil and try
+ ;; and fix the source.
+ (speedbar-find-file-in-frame file)
+ (save-excursion (speedbar-stealthy-updates))
+ (semantic-go-to-tag token parent)
+ (switch-to-buffer (current-buffer))
+ ;; Reset the timer with a new timeout when cliking a file
+ ;; in case the user was navigating directories, we can cancel
+ ;; that other timer.
+ ;; (speedbar-set-timer dframe-update-speed)
+ ;;(recenter)
+ (speedbar-maybee-jump-to-attached-frame)
+ (run-hooks 'speedbar-visiting-tag-hook)))
+
+(defun semantic-sb-expand-group (text token indent)
+ "Expand a group which has semantic tokens.
+TEXT TOKEN and INDENT are the details."
+ (cond ((string-match "+" text) ;we have to expand this file
+ (speedbar-change-expand-button-char ?-)
+ (speedbar-with-writable
+ (save-excursion
+ (end-of-line) (forward-char 1)
+ (save-restriction
+ (narrow-to-region (point-min) (point))
+ (semantic-sb-buttons-plain (1+ indent) token)))))
+ ((string-match "-" text) ;we have to contract this node
+ (speedbar-change-expand-button-char ?+)
+ (speedbar-delete-subblock indent))
+ (t (error "Ooops... not sure what to do")))
+ (speedbar-center-buffer-smartly))
+
+(defun semantic-sb-buttons-plain (level tokens)
+ "Create buttons at LEVEL using TOKENS."
+ (let ((sordid (speedbar-create-tag-hierarchy tokens)))
+ (while sordid
+ (cond ((null (car-safe sordid)) nil)
+ ((consp (car-safe (cdr-safe (car-safe sordid))))
+ ;; A group!
+ (speedbar-make-tag-line 'curly ?+ 'semantic-sb-expand-group
+ (cdr (car sordid))
+ (car (car sordid))
+ nil nil 'speedbar-tag-face
+ level))
+ (t ;; Assume that this is a token.
+ (semantic-sb-one-button (car sordid) level)))
+ (setq sordid (cdr sordid)))))
+
+(defun semantic-sb-insert-tag-table (level table)
+ "At LEVEL, insert the tag table TABLE.
+Use arcane knowledge about the semantic tokens in the tagged elements
+to create much wiser decisions about how to sort and group these items."
+ (semantic-sb-buttons level table))
+
+(defun semantic-sb-buttons (level lst)
+ "Create buttons at LEVEL using LST sorting into type buckets."
+ (save-restriction
+ (narrow-to-region (point-min) (point))
+ (let (tmp)
+ (while lst
+ (setq tmp (car lst))
+ (if (cdr tmp)
+ (if (<= (length (cdr tmp)) semantic-sb-autoexpand-length)
+ (semantic-sb-buttons-plain (1+ level) (cdr tmp))
+ (speedbar-make-tag-line 'curly ?+ 'semantic-sb-expand-group
+ (cdr tmp)
+ (car (car lst))
+ nil nil 'speedbar-tag-face
+ (1+ level))))
+ (setq lst (cdr lst))))))
+
+(defun semantic-sb-fetch-tag-table (file)
+ "Load FILE into a buffer, and generate tags using the Semantic parser.
+Returns the tag list, or t for an error."
+ (let ((out nil))
+ (if (and (featurep 'semanticdb) (semanticdb-minor-mode-p)
+ (not speedbar-power-click)
+ ;; If the database is loaded and running, try to get
+ ;; tokens from it.
+ (setq out (semanticdb-file-stream file)))
+ ;; Successful DB query.
+ nil
+ ;; No database, do it the old way.
+ (save-excursion
+ (set-buffer (find-file-noselect file))
+ (if (or (not (featurep 'semantic))
+ (not semantic--parse-table))
+ (setq out t)
+ (if speedbar-power-click (semantic-clear-toplevel-cache))
+ (setq out (semantic-fetch-tags)))))
+ (if (listp out)
+ (condition-case nil
+ (progn
+ ;; This brings externally defind methods into
+ ;; their classes, and creates meta classes for
+ ;; orphans.
+ (setq out (semantic-adopt-external-members out))
+ ;; Dump all the tokens into buckets.
+ (semantic-sb-with-tag-buffer (car out)
+ (semantic-bucketize out)))
+ (error t))
+ t)))
+
+;; Link ourselves into the tagging process.
+(add-to-list 'speedbar-dynamic-tags-function-list
+ '(semantic-sb-fetch-tag-table . semantic-sb-insert-tag-table))
+
+(provide 'semantic/sb)
+
+;;; semantic/sb.el ends here
--- /dev/null
+;;; semantic/scope.el --- Analyzer Scope Calculations
+
+;; 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:
+;;
+;; Calculate information about the current scope.
+;;
+;; Manages the current scope as a structure that can be cached on a
+;; per-file basis and recycled between different occurances of
+;; analysis on different parts of a file.
+;;
+;; Pattern for Scope Calculation
+;;
+;; Step 1: Calculate DataTypes in Scope:
+;;
+;; a) What is in scope via using statements or local namespaces
+;; b) Lineage of current context. Some names drawn from step 1.
+;;
+;; Step 2: Convert type names into lists of concrete tags
+;;
+;; a) Convert each datatype into the real datatype tag
+;; b) Convert namespaces into the list of contents of the namespace.
+;; c) Merge all existing scopes together into one search list.
+;;
+;; Step 3: Local variables
+;;
+;; a) Local variables are in the master search list.
+;;
+
+(require 'semantic/db)
+(require 'semantic/analyze/fcn)
+(require 'semantic/ctxt)
+
+
+;;; Code:
+
+(defclass semantic-scope-cache (semanticdb-abstract-cache)
+ ((tag :initform nil
+ :documentation
+ "The tag this scope was calculated for.")
+ (scopetypes :initform nil
+ :documentation
+ "The list of types currently in scope.
+For C++, this would contain anonymous namespaces known, and
+anything labled by a `using' statement.")
+ (parents :initform nil
+ :documentation
+ "List of parents in scope w/in the body of this function.
+Presumably, the members of these parent classes are available for access
+based on private:, or public: style statements.")
+ (parentinheritance :initform nil
+ :documentation "Alist of parents by inheritance.
+Each entry is ( PARENT . PROTECTION ), where PARENT is a type, and
+PROTECTION is a symbol representing the level of inheritance, such as 'private, or 'protected.")
+ (scope :initform nil
+ :documentation
+ "Items in scope due to the scopetypes or parents.")
+ (fullscope :initform nil
+ :documentation
+ "All the other stuff on one master list you can search.")
+ (localargs :initform nil
+ :documentation
+ "The arguments to the function tag.")
+ (localvar :initform nil
+ :documentation
+ "The local variables.")
+ (typescope :initform nil
+ :documentation
+ "Slot to save intermediate scope while metatypes are dereferenced.")
+ )
+ "Cache used for storage of the current scope by the Semantic Analyzer.
+Saves scoping information between runs of the analyzer.")
+
+;;; METHODS
+;;
+;; Methods for basic management of the structure in semanticdb.
+;;
+(defmethod semantic-reset ((obj semantic-scope-cache))
+ "Reset OBJ back to it's empty settings."
+ (oset obj tag nil)
+ (oset obj scopetypes nil)
+ (oset obj parents nil)
+ (oset obj parentinheritance nil)
+ (oset obj scope nil)
+ (oset obj fullscope nil)
+ (oset obj localargs nil)
+ (oset obj localvar nil)
+ (oset obj typescope nil)
+ )
+
+(defmethod semanticdb-synchronize ((cache semantic-scope-cache)
+ new-tags)
+ "Synchronize a CACHE with some NEW-TAGS."
+ (semantic-reset cache))
+
+
+(defmethod semanticdb-partial-synchronize ((cache semantic-scope-cache)
+ new-tags)
+ "Synchronize a CACHE with some changed NEW-TAGS."
+ ;; If there are any includes or datatypes changed, then clear.
+ (if (or (semantic-find-tags-by-class 'include new-tags)
+ (semantic-find-tags-by-class 'type new-tags)
+ (semantic-find-tags-by-class 'using new-tags))
+ (semantic-reset cache))
+ )
+
+(defun semantic-scope-reset-cache ()
+ "Get the current cached scope, and reset it."
+ (when semanticdb-current-table
+ (let ((co (semanticdb-cache-get semanticdb-current-table
+ semantic-scope-cache)))
+ (semantic-reset co))))
+
+(defmethod semantic-scope-set-typecache ((cache semantic-scope-cache)
+ types-in-scope)
+ "Set the :typescope property on CACHE to some types.
+TYPES-IN-SCOPE is a list of type tags whos members are
+currently in scope. For each type in TYPES-IN-SCOPE,
+add those members to the types list.
+If nil, then the typescope is reset."
+ (let ((newts nil)) ;; New Type Scope
+ (dolist (onetype types-in-scope)
+ (setq newts (append (semantic-tag-type-members onetype)
+ newts))
+ )
+ (oset cache typescope newts)))
+
+;;; TAG SCOPES
+;;
+;; These fcns should be used by search routines that return a single
+;; tag which, in turn, may have come from a deep scope. The scope
+;; will be attached to the tag. Thus, in future scope based calls, a
+;; tag can be passed in and a scope derived from it.
+
+(defun semantic-scope-tag-clone-with-scope (tag scopetags)
+ "Close TAG, and return it. Add SCOPETAGS as a tag-local scope.
+Stores the SCOPETAGS as a set of tag properties on the cloned tag."
+ (let ((clone (semantic-tag-clone tag))
+ )
+ (semantic--tag-put-property clone 'scope scopetags)
+ ))
+
+(defun semantic-scope-tag-get-scope (tag)
+ "Get from TAG the list of tags comprising the scope from TAG."
+ (semantic--tag-get-property tag 'scope))
+
+;;; SCOPE UTILITIES
+;;
+;; Functions that do the main scope calculations
+
+
+(define-overloadable-function semantic-analyze-scoped-types (position)
+ "Return a list of types currently in scope at POSITION.
+This is based on what tags exist at POSITION, and any associated
+types available.")
+
+(defun semantic-analyze-scoped-types-default (position)
+ "Return a list of types currently in scope at POSITION.
+Use `semantic-ctxt-scoped-types' to find types."
+ (save-excursion
+ (goto-char position)
+ (let ((code-scoped-types nil))
+ ;; Lets ask if any types are currently scoped. Scoped
+ ;; classes and types provide their public methods and types
+ ;; in source code, but are unrelated hierarchically.
+ (let ((sp (semantic-ctxt-scoped-types)))
+ (while sp
+ ;; Get this thing as a tag
+ (let ((tmp (cond
+ ((stringp (car sp))
+ (semanticdb-typecache-find (car sp)))
+ ;(semantic-analyze-find-tag (car sp) 'type))
+ ((semantic-tag-p (car sp))
+ (if (semantic-analyze-tag-prototype-p (car sp))
+ (semanticdb-typecache-find (semantic-tag-name (car sp)))
+ ;;(semantic-analyze-find-tag (semantic-tag-name (car sp)) 'type)
+ (car sp)))
+ (t nil))))
+ (when tmp
+ (setq code-scoped-types
+ (cons tmp code-scoped-types))))
+ (setq sp (cdr sp))))
+ (setq code-scoped-types (nreverse code-scoped-types))
+
+ (when code-scoped-types
+ (semanticdb-typecache-merge-streams code-scoped-types nil))
+
+ )))
+
+;;------------------------------------------------------------
+(define-overloadable-function semantic-analyze-scope-nested-tags (position scopedtypes)
+ "Return a list of types in order of nesting for the context of POSITION.
+If POSITION is in a method with a named parent, find that parent, and
+identify it's scope via overlay instead.
+Optional SCOPETYPES are additional scoped entities in which our parent might
+be found.")
+
+(defun semantic-analyze-scope-nested-tags-default (position scopetypes)
+ "Return a list of types in order of nesting for the context of POSITION.
+If POSITION is in a method with a named parent, find that parent, and
+identify it's scope via overlay instead.
+Optional SCOPETYPES are additional scoped entities in which our parent might
+be found.
+This only finds ONE immediate parent by name. All other parents returned
+are from nesting data types."
+ (save-excursion
+ (if position (goto-char position))
+ (let* ((stack (reverse (semantic-find-tag-by-overlay (point))))
+ (tag (car stack))
+ (pparent (car (cdr stack)))
+ (returnlist nil)
+ )
+ ;; In case of arg lists or some-such, throw out non-types.
+ (while (and stack (not (semantic-tag-of-class-p pparent 'type)))
+ (setq stack (cdr stack)
+ pparent (car (cdr stack))))
+
+ ;; Step 1:
+ ;; Analyze the stack of tags we are nested in as parents.
+ ;;
+
+ ;; If we have a pparent tag, lets go there
+ ;; an analyze that stack of tags.
+ (when (and pparent (semantic-tag-with-position-p pparent))
+ (semantic-go-to-tag pparent)
+ (setq stack (semantic-find-tag-by-overlay (point)))
+ ;; Step one, find the merged version of stack in the typecache.
+ (let* ((stacknames (reverse (mapcar 'semantic-tag-name stack)))
+ (tc nil)
+ )
+ ;; @todo - can we use the typecache ability to
+ ;; put a scope into a tag to do this?
+ (while (and stacknames
+ (setq tc (semanticdb-typecache-find
+ (reverse stacknames))))
+ (setq returnlist (cons tc returnlist)
+ stacknames (cdr stacknames)))
+ (when (not returnlist)
+ ;; When there was nothing from the typecache, then just
+ ;; use what's right here.
+ (setq stack (reverse stack))
+ ;; Add things to STACK until we cease finding tags of class type.
+ (while (and stack (eq (semantic-tag-class (car stack)) 'type))
+ ;; Otherwise, just add this to the returnlist.
+ (setq returnlist (cons (car stack) returnlist))
+ (setq stack (cdr stack)))
+
+ (setq returnlist (nreverse returnlist))
+ ))
+ )
+
+ ;; Only do this level of analysis for functions.
+ (when (eq (semantic-tag-class tag) 'function)
+ ;; Step 2:
+ ;; If the function tag itself has a "parent" by name, then that
+ ;; parent will exist in the scope we just calculated, so look it
+ ;; up now.
+ ;;
+ (let ((p (semantic-tag-function-parent tag)))
+ (when p
+ ;; We have a parent, search for it.
+ (let* ((searchnameraw (cond ((stringp p) p)
+ ((semantic-tag-p p)
+ (semantic-tag-name p))
+ ((and (listp p) (stringp (car p)))
+ (car p))))
+ (searchname (semantic-analyze-split-name searchnameraw))
+ (snlist (if (consp searchname)
+ searchname
+ (list searchname)))
+ (fullsearchname nil)
+
+ (miniscope (semantic-scope-cache "mini"))
+ ptag)
+
+ ;; Find the next entry in the refereneced type for
+ ;; our function, and append to return list till our
+ ;; returnlist is empty.
+ (while snlist
+ (setq fullsearchname
+ (append (mapcar 'semantic-tag-name returnlist)
+ (list (car snlist)))) ;; Next one
+ (setq ptag
+ (semanticdb-typecache-find fullsearchname))
+
+ (when (or (not ptag)
+ (not (semantic-tag-of-class-p ptag 'type)))
+ (let ((rawscope
+ (apply 'append
+ (mapcar 'semantic-tag-type-members
+ (cons (car returnlist) scopetypes)
+ )))
+ )
+ (oset miniscope parents returnlist) ;; Not really accurate, but close
+ (oset miniscope scope rawscope)
+ (oset miniscope fullscope rawscope)
+ (setq ptag
+ (semantic-analyze-find-tag searchnameraw
+ 'type
+ miniscope
+ ))
+ ))
+
+ (when ptag
+ (when (and (not (semantic-tag-p ptag))
+ (semantic-tag-p (car ptag)))
+ (setq ptag (car ptag)))
+ (setq returnlist (append returnlist (list ptag)))
+ )
+
+ (setq snlist (cdr snlist)))
+ (setq returnlist returnlist)
+ )))
+ )
+ returnlist
+ )))
+
+(define-overloadable-function semantic-analyze-scope-lineage-tags (parents scopedtypes)
+ "Return the full lineage of tags from PARENTS.
+The return list is of the form ( TAG . PROTECTION ), where TAG is a tag,
+and PROTECTION is the level of protection offered by the relationship.
+Optional SCOPETYPES are additional scoped entities in which our parent might
+be found.")
+
+(defun semantic-analyze-scope-lineage-tags-default (parents scopetypes)
+ "Return the full lineage of tags from PARENTS.
+The return list is of the form ( TAG . PROTECTION ), where TAG is a tag,
+and PROTECTION is the level of protection offered by the relationship.
+Optional SCOPETYPES are additional scoped entities in which our parent might
+be found."
+ (let ((lineage nil)
+ (miniscope (semantic-scope-cache "mini"))
+ )
+ (oset miniscope parents parents)
+ (oset miniscope scope scopetypes)
+ (oset miniscope fullscope scopetypes)
+
+ (dolist (slp parents)
+ (semantic-analyze-scoped-inherited-tag-map
+ slp (lambda (newparent)
+ (let* ((pname (semantic-tag-name newparent))
+ (prot (semantic-tag-type-superclass-protection slp pname))
+ (effectiveprot (cond ((eq prot 'public)
+ ;; doesn't provide access to private slots?
+ 'protected)
+ (t prot))))
+ (push (cons newparent effectiveprot) lineage)
+ ))
+ miniscope))
+
+ lineage))
+
+
+;;------------------------------------------------------------
+
+(define-overloadable-function semantic-analyze-scoped-tags (typelist parentlist)
+ "Return accessable tags when TYPELIST and PARENTLIST is in scope.
+Tags returned are not in the global name space, but are instead
+scoped inside a class or namespace. Such items can be referenced
+without use of \"object.function()\" style syntax due to an
+implicit \"object\".")
+
+(defun semantic-analyze-scoped-tags-default (typelist halfscope)
+ "Return accessable tags when TYPELIST and HALFSCOPE is in scope.
+HALFSCOPE is the current scope partially initialized.
+Tags returned are not in the global name space, but are instead
+scoped inside a class or namespace. Such items can be referenced
+without use of \"object.function()\" style syntax due to an
+implicit \"object\"."
+ (let ((typelist2 nil)
+ (currentscope nil)
+ (parentlist (oref halfscope parents))
+ (miniscope halfscope)
+ )
+ ;; Loop over typelist, and find and merge all namespaces matching
+ ;; the names in typelist.
+ (while typelist
+ (let ((tt (semantic-tag-type (car typelist))))
+ (when (and (stringp tt) (string= tt "namespace"))
+ ;; By using the typecache, our namespaces are pre-merged.
+ (setq typelist2 (cons (car typelist) typelist2))
+ ))
+ (setq typelist (cdr typelist)))
+
+ ;; Loop over the types (which should be sorted by postion
+ ;; adding to the scopelist as we go, and using the scopelist
+ ;; for additional searching!
+ (while typelist2
+ (oset miniscope scope currentscope)
+ (oset miniscope fullscope currentscope)
+ (setq currentscope (append
+ (semantic-analyze-scoped-type-parts (car typelist2)
+ miniscope)
+ currentscope))
+ (setq typelist2 (cdr typelist2)))
+
+ ;; Collect all the types (class, etc) that are in our heratage.
+ ;; These are types that we can extract members from, not those
+ ;; delclared in using statements, or the like.
+ ;; Get the PARENTS including nesting scope for this location.
+ (while parentlist
+ (oset miniscope scope currentscope)
+ (oset miniscope fullscope currentscope)
+ (setq currentscope (append
+ (semantic-analyze-scoped-type-parts (car parentlist)
+ miniscope)
+ currentscope))
+ (setq parentlist (cdr parentlist)))
+
+ ;; Loop over all the items, and collect any type constants.
+ (let ((constants nil))
+ (dolist (T currentscope)
+ (setq constants (append constants
+ (semantic-analyze-type-constants T)))
+ )
+
+ (setq currentscope (append currentscope constants)))
+
+ currentscope))
+
+;;------------------------------------------------------------
+(define-overloadable-function semantic-analyze-scope-calculate-access (type scope)
+ "Calculate the access class for TYPE as defined by the current SCOPE.
+Access is related to the :parents in SCOPE. If type is a member of SCOPE
+then access would be 'private. If TYPE is inherited by a member of SCOPE,
+the access would be 'protected. Otherwise, access is 'public")
+
+(defun semantic-analyze-scope-calculate-access-default (type scope)
+ "Calculate the access class for TYPE as defined by the current SCOPE."
+ (cond ((semantic-scope-cache-p scope)
+ (let ((parents (oref scope parents))
+ (parentsi (oref scope parentinheritance))
+ )
+ (catch 'moose
+ ;; Investigate the parent, and see how it relates to type.
+ ;; If these tags are basically the same, then we have full access.
+ (dolist (p parents)
+ (when (semantic-tag-similar-p type p)
+ (throw 'moose 'private))
+ )
+ ;; Look to see if type is in our list of inherited parents.
+ (dolist (pi parentsi)
+ ;; pi is a cons cell ( PARENT . protection)
+ (let ((pip (car pi))
+ (piprot (cdr pi)))
+ (when (semantic-tag-similar-p type pip)
+ (throw 'moose
+ ;; protection via inheritance means to pull out different
+ ;; bits based on protection labels in an opposite way.
+ (cdr (assoc piprot
+ '((public . private)
+ (protected . protected)
+ (private . public))))
+ )))
+ )
+ ;; Not in our parentage. Is type a FRIEND?
+ (let ((friends (semantic-find-tags-by-class 'friend (semantic-tag-type-members type))))
+ (dolist (F friends)
+ (dolist (pi parents)
+ (if (string= (semantic-tag-name F) (semantic-tag-name pi))
+ (throw 'moose 'private))
+ )))
+ ;; Found nothing, return public
+ 'public)
+ ))
+ (t 'public)))
+
+(defun semantic-completable-tags-from-type (type)
+ "Return a list of slots that are valid completions from the list of SLOTS.
+If a tag in SLOTS has a named parent, then that implies that the
+tag is not something you can complete from within TYPE."
+ (let ((allslots (semantic-tag-components type))
+ (leftover nil)
+ )
+ (dolist (S allslots)
+ (when (or (not (semantic-tag-of-class-p S 'function))
+ (not (semantic-tag-function-parent S)))
+ (setq leftover (cons S leftover)))
+ )
+ (nreverse leftover)))
+
+(defun semantic-analyze-scoped-type-parts (type &optional scope noinherit protection)
+ "Return all parts of TYPE, a tag representing a TYPE declaration.
+SCOPE is the scope object.
+NOINHERIT turns off searching of inherited tags.
+PROTECTION specifies the type of access requested, such as 'public or 'private."
+ (if (not type)
+ nil
+ (let* ((access (semantic-analyze-scope-calculate-access type scope))
+ ;; SLOTS are the slots directly a part of TYPE.
+ (allslots (semantic-completable-tags-from-type type))
+ (slots (semantic-find-tags-by-scope-protection
+ access
+ type allslots))
+ (fname (semantic-tag-file-name type))
+ ;; EXTMETH are externally defined methods that are still
+ ;; a part of this class.
+
+ ;; @TODO - is this line needed?? Try w/out for a while
+ ;; @note - I think C++ says no. elisp might, but methods
+ ;; look like defuns, so it makes no difference.
+ (extmeth nil) ; (semantic-tag-external-member-children type t))
+
+ ;; INHERITED are tags found in classes that our TYPE tag
+ ;; inherits from. Do not do this if it was not requested.
+ (inherited (when (not noinherit)
+ (semantic-analyze-scoped-inherited-tags type scope
+ access)))
+ )
+ (when (not (semantic-tag-in-buffer-p type))
+ (let ((copyslots nil))
+ (dolist (TAG slots)
+ ;;(semantic--tag-put-property TAG :filename fname)
+ (if (semantic-tag-file-name TAG)
+ ;; If it has a filename, just go with it...
+ (setq copyslots (cons TAG copyslots))
+ ;; Otherwise, copy the tag w/ the guessed filename.
+ (setq copyslots (cons (semantic-tag-copy TAG nil fname)
+ copyslots)))
+ )
+ (setq slots (nreverse copyslots))
+ ))
+ ;; Flatten the database output.
+ (append slots extmeth inherited)
+ )))
+
+(defun semantic-analyze-scoped-inherited-tags (type scope access)
+ "Return all tags that TYPE inherits from.
+Argument SCOPE specify additional tags that are in scope
+whose tags can be searched when needed, OR it may be a scope object.
+ACCESS is the level of access we filter on child supplied tags.
+For langauges with protection on specific methods or slots,
+it should strip out those not accessable by methods of TYPE.
+An ACCESS of 'public means not in a method of a subclass of type.
+A value of 'private means we can access private parts of the originating
+type."
+ (let ((ret nil))
+ (semantic-analyze-scoped-inherited-tag-map
+ type (lambda (p)
+ (let* ((pname (semantic-tag-name p))
+ (protection (semantic-tag-type-superclass-protection
+ type pname))
+ )
+ (if (and (eq access 'public) (not (eq protection 'public)))
+ nil ;; Don't do it.
+
+ ;; We can get some parts of this type.
+ (setq ret (nconc ret
+ ;; Do not pull in inherited parts here. Those
+ ;; will come via the inherited-tag-map fcn
+ (semantic-analyze-scoped-type-parts
+ p scope t protection))
+ ))))
+ scope)
+ ret))
+
+(defun semantic-analyze-scoped-inherited-tag-map (type fcn scope)
+ "Map all parents of TYPE to FCN. Return tags of all the types.
+Argument SCOPE specify additional tags that are in scope
+whose tags can be searched when needed, OR it may be a scope object."
+ (let* (;; PARENTS specifies only the superclasses and not
+ ;; interfaces. Inheriting from an interfaces implies
+ ;; you have a copy of all methods locally. I think.
+ (parents (semantic-tag-type-superclasses type))
+ ps pt
+ (tmpscope scope)
+ )
+ (save-excursion
+
+ ;; Create a SCOPE just for looking up the parent based on where
+ ;; the parent came from.
+ ;;
+ ;; @TODO - Should we cache these mini-scopes around in Emacs
+ ;; for recycling later? Should this become a helpful
+ ;; extra routine?
+ (when (and parents (semantic-tag-with-position-p type))
+ ;; If TYPE has a position, go there and get the scope.
+ (semantic-go-to-tag type)
+
+ ;; We need to make a mini scope, and only include the misc bits
+ ;; that will help in finding the parent. We don't really need
+ ;; to do any of the stuff related to variables and what-not.
+ (setq tmpscope (semantic-scope-cache "mini"))
+ (let* (;; Step 1:
+ (scopetypes (semantic-analyze-scoped-types (point)))
+ (parents (semantic-analyze-scope-nested-tags (point) scopetypes))
+ ;;(parentinherited (semantic-analyze-scope-lineage-tags parents scopetypes))
+ (lscope nil)
+ )
+ (oset tmpscope scopetypes scopetypes)
+ (oset tmpscope parents parents)
+ ;;(oset tmpscope parentinheritance parentinherited)
+
+ (when (or scopetypes parents)
+ (setq lscope (semantic-analyze-scoped-tags scopetypes tmpscope))
+ (oset tmpscope scope lscope))
+ (oset tmpscope fullscope (append scopetypes lscope parents))
+ ))
+ ;; END creating tmpscope
+
+ ;; Look up each parent one at a time.
+ (dolist (p parents)
+ (setq ps (cond ((stringp p) p)
+ ((and (semantic-tag-p p) (semantic-tag-prototype-p p))
+ (semantic-tag-name p))
+ ((and (listp p) (stringp (car p)))
+ p))
+ pt (condition-case nil
+ (or (semantic-analyze-find-tag ps 'type tmpscope)
+ ;; A backup hack.
+ (semantic-analyze-find-tag ps 'type scope))
+ (error nil)))
+
+ (when pt
+ (funcall fcn pt)
+ ;; Note that we pass the original SCOPE in while recursing.
+ ;; so that the correct inheritance model is passed along.
+ (semantic-analyze-scoped-inherited-tag-map pt fcn scope)
+ )))
+ nil))
+
+;;; ANALYZER
+;;
+;; Create the scope structure for use in the Analyzer.
+;;
+(defun semantic-calculate-scope (&optional point)
+ "Calculate the scope at POINT.
+If POINT is not provided, then use the current location of point.
+The class returned from the scope calculation is variable
+`semantic-scope-cache'."
+ (interactive)
+ (if (not (and (featurep 'semanticdb) semanticdb-current-database))
+ nil ;; Don't do anything...
+ (if (not point) (setq point (point)))
+ (when (interactive-p)
+ (semantic-fetch-tags)
+ (semantic-scope-reset-cache)
+ )
+ (save-excursion
+ (goto-char point)
+ (let* ((TAG (semantic-current-tag))
+ (scopecache
+ (semanticdb-cache-get semanticdb-current-table
+ semantic-scope-cache))
+ )
+ (when (not (semantic-equivalent-tag-p TAG (oref scopecache tag)))
+ (semantic-reset scopecache))
+ (if (oref scopecache tag)
+ ;; Even though we can recycle most of the scope, we
+ ;; need to redo the local variables since those change
+ ;; as you move about the tag.
+ (condition-case nil
+ (oset scopecache localvar (semantic-get-all-local-variables))
+ (error nil))
+
+ (let* (;; Step 1:
+ (scopetypes (semantic-analyze-scoped-types point))
+ (parents (semantic-analyze-scope-nested-tags point scopetypes))
+ (parentinherited (semantic-analyze-scope-lineage-tags
+ parents scopetypes))
+ )
+ (oset scopecache tag TAG)
+ (oset scopecache scopetypes scopetypes)
+ (oset scopecache parents parents)
+ (oset scopecache parentinheritance parentinherited)
+
+ (let* (;; Step 2:
+ (scope (when (or scopetypes parents)
+ (semantic-analyze-scoped-tags scopetypes scopecache))
+ )
+ ;; Step 3:
+ (localargs (semantic-get-local-arguments))
+ (localvar (condition-case nil
+ (semantic-get-all-local-variables)
+ (error nil)))
+ )
+
+ ;; Try looking for parents again.
+ (when (not parentinherited)
+ (setq parentinherited (semantic-analyze-scope-lineage-tags
+ parents (append scopetypes scope)))
+ (when parentinherited
+ (oset scopecache parentinheritance parentinherited)
+ ;; Try calculating the scope again with the new inherited parent list.
+ (setq scope (when (or scopetypes parents)
+ (semantic-analyze-scoped-tags scopetypes scopecache))
+ )))
+
+ ;; Fill out the scope.
+ (oset scopecache scope scope)
+ (oset scopecache fullscope (append scopetypes scope parents))
+ (oset scopecache localargs localargs)
+ (oset scopecache localvar localvar)
+ )))
+ ;; Make sure we become dependant on the typecache.
+ (semanticdb-typecache-add-dependant scopecache)
+ ;; Handy debug output.
+ (when (interactive-p)
+ (data-debug-show scopecache)
+ )
+ ;; Return ourselves
+ scopecache))))
+
+(defun semantic-scope-find (name &optional class scope-in)
+ "Find the tag with NAME, and optinal CLASS in the current SCOPE-IN.
+Searches various elements of the scope for NAME. Return ALL the
+hits in order, with the first tag being in the closest scope."
+ (let ((scope (or scope-in (semantic-calculate-scope)))
+ (ans nil))
+ ;; Is the passed in scope really a scope? if so, look through
+ ;; the options in that scope.
+ (if (semantic-scope-cache-p scope)
+ (let* ((la
+ ;; This should be first, but bugs in the
+ ;; C parser will turn function calls into
+ ;; assumed int return function prototypes. Yuck!
+ (semantic-find-tags-by-name name (oref scope localargs)))
+ (lv
+ (semantic-find-tags-by-name name (oref scope localvar)))
+ (fullscoperaw (oref scope fullscope))
+ (sc (semantic-find-tags-by-name name fullscoperaw))
+ (typescoperaw (oref scope typescope))
+ (tsc (semantic-find-tags-by-name name typescoperaw))
+ )
+ (setq ans
+ (if class
+ ;; Scan out things not of the right class.
+ (semantic-find-tags-by-class class (append la lv sc tsc))
+ (append la lv sc tsc))
+ )
+
+ (when (and (not ans) (or typescoperaw fullscoperaw))
+ (let ((namesplit (semantic-analyze-split-name name)))
+ (when (consp namesplit)
+ ;; It may be we need to hack our way through type typescope.
+ (while namesplit
+ (setq ans (append
+ (semantic-find-tags-by-name (car namesplit)
+ typescoperaw)
+ (semantic-find-tags-by-name (car namesplit)
+ fullscoperaw)
+ ))
+ (if (not ans)
+ (setq typescoperaw nil)
+ (when (cdr namesplit)
+ (setq typescoperaw (semantic-tag-type-members
+ (car ans)))))
+
+ (setq namesplit (cdr namesplit)))
+ ;; Once done, store the current typecache lookup
+ (oset scope typescope
+ (append typescoperaw (oref scope typescope)))
+ )))
+ ;; Return it.
+ ans)
+ ;; Not a real scope. Our scope calculation analyze parts of
+ ;; what it finds, and needs to pass lists through to do it's work.
+ ;; Tread that list as a singly entry.
+ (if class
+ (semantic-find-tags-by-class class scope)
+ scope)
+ )))
+
+;;; DUMP
+;;
+(defmethod semantic-analyze-show ((context semantic-scope-cache))
+ "Insert CONTEXT into the current buffer in a nice way."
+ (semantic-analyze-princ-sequence (oref context scopetypes) "-> ScopeTypes: " )
+ (semantic-analyze-princ-sequence (oref context parents) "-> Parents: " )
+ (semantic-analyze-princ-sequence (oref context scope) "-> Scope: " )
+ ;;(semantic-analyze-princ-sequence (oref context fullscope) "Fullscope: " )
+ (semantic-analyze-princ-sequence (oref context localargs) "-> Local Args: " )
+ (semantic-analyze-princ-sequence (oref context localvar) "-> Local Vars: " )
+ )
+
+(provide 'semantic/scope)
+
+;;; semantic/scope.el ends here
HCoop / bpt / emacs.git / commitdiff