From 20bfd70928830b9d41c39fbeb37351d3c6f91823 Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Sun, 30 Aug 2009 14:36:00 +0000 Subject: [PATCH] semantic/cedet/db-global.el, semantic/cedet/ia-sb.el, semantic/cedet/sb.el, semantic/cedet/scope.el: New files. --- lisp/cedet/semantic/db-global.el | 248 ++++++++++ lisp/cedet/semantic/ia-sb.el | 367 ++++++++++++++ lisp/cedet/semantic/sb.el | 419 ++++++++++++++++ lisp/cedet/semantic/scope.el | 796 +++++++++++++++++++++++++++++++ 4 files changed, 1830 insertions(+) create mode 100644 lisp/cedet/semantic/db-global.el create mode 100644 lisp/cedet/semantic/ia-sb.el create mode 100644 lisp/cedet/semantic/sb.el create mode 100644 lisp/cedet/semantic/scope.el diff --git a/lisp/cedet/semantic/db-global.el b/lisp/cedet/semantic/db-global.el new file mode 100644 index 0000000000..1677f574ce --- /dev/null +++ b/lisp/cedet/semantic/db-global.el @@ -0,0 +1,248 @@ +;;; 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 +;; 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 . + +;;; 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 diff --git a/lisp/cedet/semantic/ia-sb.el b/lisp/cedet/semantic/ia-sb.el new file mode 100644 index 0000000000..97f5318825 --- /dev/null +++ b/lisp/cedet/semantic/ia-sb.el @@ -0,0 +1,367 @@ +;;; semantic/ia-sb.el --- Speedbar analysis display interactor + +;;; Copyright (C) 2002, 2003, 2004, 2006, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam +;; 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 . + +;;; 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 ""))) + (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 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 diff --git a/lisp/cedet/semantic/sb.el b/lisp/cedet/semantic/sb.el new file mode 100644 index 0000000000..f1a6beb7be --- /dev/null +++ b/lisp/cedet/semantic/sb.el @@ -0,0 +1,419 @@ +;;; 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 +;; 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 . + +;;; 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 diff --git a/lisp/cedet/semantic/scope.el b/lisp/cedet/semantic/scope.el new file mode 100644 index 0000000000..c89bd79978 --- /dev/null +++ b/lisp/cedet/semantic/scope.el @@ -0,0 +1,796 @@ +;;; semantic/scope.el --- Analyzer Scope Calculations + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; 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 . + +;;; 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 -- 2.20.1