Mercurial > emacs
changeset 104421:b66bb908c129
cedet/semantic/debug.el,
cedet/semantic/doc.el,
cedet/semantic/tag-write.el,
cedet/semantic/analyze/complete.el,
cedet/semantic/analyze/debug.el,
cedet/semantic/analyze/fcn.el,
cedet/semantic/analyze/refs.el: New files.
| author | Chong Yidong <cyd@stupidchicken.com> |
|---|---|
| date | Sat, 29 Aug 2009 19:45:47 +0000 |
| parents | 2e15afd37998 |
| children | 36f56620b2ae |
| files | lisp/cedet/semantic/analyze/complete.el lisp/cedet/semantic/analyze/debug.el lisp/cedet/semantic/analyze/fcn.el lisp/cedet/semantic/analyze/refs.el lisp/cedet/semantic/debug.el lisp/cedet/semantic/doc.el lisp/cedet/semantic/tag-write.el |
| diffstat | 7 files changed, 2406 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/analyze/complete.el Sat Aug 29 19:45:47 2009 +0000 @@ -0,0 +1,273 @@ +;;; semantic/analyze/complete.el --- Smart Completions + +;;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; 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: +;; +;; Caclulate smart completions. +;; +;; Uses the analyzer context routine to determine the best possible +;; list of completions. +;; +;;; History: +;; +;; Code was moved here from semantic-analyze.el + +(require 'semantic/analyze) + +;;; Code: + +;;; Helper Fcns +;; +;; +(define-overloadable-function semantic-analyze-type-constants (type) + "For the tag TYPE, return any constant symbols of TYPE. +Used as options when completing.") + +(defun semantic-analyze-type-constants-default (type) + "Do nothing with TYPE." + nil) + +;; Old impl of the above. I'm not sure what the issue is +; (let ((ans +; (:override-with-args +; ((semantic-analyze-find-tag (semantic-tag-name type))) +; ;; Be default, we don't know. +; nil)) +; (out nil)) +; (dolist (elt ans) +; (cond +; ((stringp elt) +; (push (semantic-tag-new-variable +; elt (semantic-tag-name type) nil) +; out)) +; ((semantic-tag-p elt) +; (push elt out)) +; (t nil))) +; (nreverse out))) + +(defun semantic-analyze-tags-of-class-list (tags classlist) + "Return the tags in TAGS that are of classes in CLASSLIST." + (let ((origc tags)) + ;; Accept only tags that are of the datatype specified by + ;; the desired classes. + (setq tags (apply 'nconc ;; All input lists are permutable. + (mapcar (lambda (class) + (semantic-find-tags-by-class class origc)) + classlist))) + tags)) + +;;; MAIN completion calculator +;; +;; +(define-overloadable-function semantic-analyze-possible-completions (context) + "Return a list of semantic tags which are possible completions. +CONTEXT is either a position (such as point), or a precalculated +context. Passing in a context is useful if the caller also needs +to access parts of the analysis. +Completions run through the following filters: + * Elements currently in scope + * Constants currently in scope + * Elements match the :prefix in the CONTEXT. + * Type of the completion matches the type of the context. +Context type matching can identify the following: + * No specific type + * Assignment into a variable of some type. + * Argument to a function with type constraints. +When called interactively, displays the list of possible completions +in a buffer." + (interactive "d") + ;; In theory, we don't need the below since the context will + ;; do it for us. + ;;(semantic-refresh-tags-safe) + (with-syntax-table semantic-lex-syntax-table + (let* ((context (if (semantic-analyze-context-child-p context) + context + (semantic-analyze-current-context context))) + (ans (if (not context) + (error "Nothing to Complete.") + (:override)))) + ;; If interactive, display them. + (when (interactive-p) + (with-output-to-temp-buffer "*Possible Completions*" + (semantic-analyze-princ-sequence ans "" (current-buffer))) + (shrink-window-if-larger-than-buffer + (get-buffer-window "*Possible Completions*"))) + ans))) + +(defun semantic-analyze-possible-completions-default (context) + "Default method for producing smart completions. +Argument CONTEXT is an object specifying the locally derived context." + (let* ((a context) + (desired-type (semantic-analyze-type-constraint a)) + (desired-class (oref a prefixclass)) + (prefix (oref a prefix)) + (prefixtypes (oref a prefixtypes)) + (completetext nil) + (completetexttype nil) + (scope (oref a scope)) + (localvar (oref scope localvar)) + (c nil)) + + ;; Calculate what our prefix string is so that we can + ;; find all our matching text. + (setq completetext (car (reverse prefix))) + (if (semantic-tag-p completetext) + (setq completetext (semantic-tag-name completetext))) + + (if (and (not completetext) (not desired-type)) + (error "Nothing to complete")) + + (if (not completetext) (setq completetext "")) + + ;; This better be a reasonable type, or we should fry it. + ;; The prefixtypes should always be at least 1 less than + ;; the prefix since the type is never looked up for the last + ;; item when calculating a sequence. + (setq completetexttype (car (reverse prefixtypes))) + (when (or (not completetexttype) + (not (and (semantic-tag-p completetexttype) + (eq (semantic-tag-class completetexttype) 'type)))) + ;; What should I do here? I think this is an error condition. + (setq completetexttype nil) + ;; If we had something that was a completetexttype but it wasn't + ;; valid, then express our dismay! + (when (> (length prefix) 1) + (let* ((errprefix (car (cdr (reverse prefix))))) + (error "Cannot find types for `%s'" + (cond ((semantic-tag-p errprefix) + (semantic-format-tag-prototype errprefix)) + (t + (format "%S" errprefix))))) + )) + + ;; There are many places to get our completion stream for. + ;; Here we go. + (if completetexttype + + (setq c (semantic-find-tags-for-completion + completetext + (semantic-analyze-scoped-type-parts completetexttype scope) + )) + + ;; No type based on the completetext. This is a free-range + ;; var or function. We need to expand our search beyond this + ;; scope into semanticdb, etc. + (setq c (nconc + ;; Argument list and local variables + (semantic-find-tags-for-completion completetext localvar) + ;; The current scope + (semantic-find-tags-for-completion completetext (oref scope fullscope)) + ;; The world + (semantic-analyze-find-tags-by-prefix completetext)) + ) + ) + + (let ((origc c) + (dtname (semantic-tag-name desired-type))) + + ;; Reset c. + (setq c nil) + + ;; Loop over all the found matches, and catagorize them + ;; as being possible features. + (while origc + + (cond + ;; Strip operators + ((semantic-tag-get-attribute (car origc) :operator-flag) + nil + ) + + ;; If we are completing from within some prefix, + ;; then we want to exclude constructors and destructors + ((and completetexttype + (or (semantic-tag-get-attribute (car origc) :constructor-flag) + (semantic-tag-get-attribute (car origc) :destructor-flag))) + nil + ) + + ;; If there is a desired type, we need a pair of restrictions + (desired-type + + (cond + ;; Ok, we now have a completion list based on the text we found + ;; we want to complete on. Now filter that stream against the + ;; type we want to search for. + ((string= dtname (semantic-analyze-type-to-name (semantic-tag-type (car origc)))) + (setq c (cons (car origc) c)) + ) + + ;; Now anything that is a compound type which could contain + ;; additional things which are of the desired type + ((semantic-tag-type (car origc)) + (let ((att (semantic-analyze-tag-type (car origc) scope)) + ) + (if (and att (semantic-tag-type-members att)) + (setq c (cons (car origc) c)))) + ) + + ) ; cond + ); desired type + + ;; No desired type, no other restrictions. Just add. + (t + (setq c (cons (car origc) c))) + + ); cond + + (setq origc (cdr origc))) + + (when desired-type + ;; Some types, like the enum in C, have special constant values that + ;; we could complete with. Thus, if the target is an enum, we can + ;; find possible symbol values to fill in that value. + (let ((constants + (semantic-analyze-type-constants desired-type))) + (if constants + (progn + ;; Filter + (setq constants + (semantic-find-tags-for-completion + completetext constants)) + ;; Add to the list + (setq c (nconc c constants))) + ))) + ) + + (when desired-class + (setq c (semantic-analyze-tags-of-class-list c desired-class))) + + ;; Pull out trash. + ;; NOTE TO SELF: Is this too slow? + ;; OTHER NOTE: Do we not want to strip duplicates by name and + ;; only by position? When are duplicate by name but not by tag + ;; useful? + (setq c (semantic-unique-tag-table-by-name c)) + + ;; All done! + + c)) + + + +(provide 'semantic/analyze/complete) + +;;; semantic/analyze/complete.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/analyze/debug.el Sat Aug 29 19:45:47 2009 +0000 @@ -0,0 +1,613 @@ +;;; semantic/analyze/debug.el --- Debug the analyzer + +;;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; 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: +;; +;; Provide a top-order debugging tool for figuring out what's going on with +;; smart completion and analyzer mode. + +(require 'semantic/analyze) +(require 'semantic/db-typecache) + +;;; Code: + +(defun semantic-analyze-debug-assist () + "Debug semantic analysis at the current point." + (interactive) + (let ((actualfcn (fetch-overload 'semantic-analyze-current-context)) + (ctxt (semantic-analyze-current-context)) + ) + ;; What to show. + (if actualfcn + (message "Mode %s does not use the default analyzer." + major-mode) + ;; Debug our context. + ) + (or (semantic-analyzer-debug-test-local-context) + (and ctxt (semantic-analyzer-debug-found-prefix ctxt)) + ) + + )) + +(defun semantic-analyzer-debug-found-prefix (ctxt) + "Debug the prefix found by the analyzer output CTXT." + (let* ((pf (oref ctxt prefix)) + (pft (oref ctxt prefixtypes)) + (idx 0) + (stop nil) + (comp (condition-case nil + (semantic-analyze-possible-completions ctxt) + (error nil))) + ) + (while (and (nth idx pf) (not stop)) + (let ((pentry (nth idx pf)) + (ptentry (nth idx pft))) + (if (or (stringp pentry) (not ptentry)) + ;; Found someting ok. stop + (setq stop t) + (setq idx (1+ idx))))) + ;; We found the first non-tag entry. What is the situation? + (cond + ((and (eq idx 0) (stringp (car pf))) + ;; First part, we couldn't find it. + (semantic-analyzer-debug-global-symbol ctxt (car pf) comp)) + ((not (nth (1- idx) pft)) ;; idx can't be 0 here. + ;; The previous entry failed to have an identifiable data + ;; type, which is a global search. + (semantic-analyzer-debug-missing-datatype ctxt idx comp)) + ((and (nth (1- idx) pft) (stringp (nth idx pf))) + ;; Non-first search, didn't find string in known data type. + (semantic-analyzer-debug-missing-innertype ctxt idx comp)) + (t + ;; Things are ok? + (message "Things look ok.")) + ))) + +(defun semantic-analyzer-debug-global-symbol (ctxt prefix comp) + "Debug why we can't find the first entry in the CTXT PREFIX. +Argument COMP are possible completions here." + (let ((tab semanticdb-current-table) + (finderr nil) + (origbuf (current-buffer)) + ) + (with-output-to-temp-buffer (help-buffer) + (with-current-buffer standard-output + (princ "Unable to find prefix ") + (princ prefix) + (princ ".\n\n") + + ;; NOTE: This line is copied from semantic-analyze-current-context. + ;; You will need to update both places. + (condition-case err + (save-excursion + (set-buffer origbuf) + (let* ((position (or (cdr-safe (oref ctxt bounds)) (point))) + (prefixtypes nil) ; Used as type return + (scope (semantic-calculate-scope position)) + ) + (semantic-analyze-find-tag-sequence + (list prefix "") scope 'prefixtypes) + ) + ) + (error (setq finderr err))) + + (if finderr + (progn + (princ "The prefix lookup code threw the following error:\n ") + (prin1 finderr) + (princ "\n\nTo debug this error you can do this: + M-x toggle-debug-on-error RET +and then re-run the debug analyzer.\n") + ) + ;; No find error, just not found + (princ "The prefix ") + (princ prefix) + (princ " could not be found in the local scope, +nor in any search tables.\n") + ) + (princ "\n") + + ;; Describe local scope, and why we might not be able to + ;; find it. + (semantic-analyzer-debug-describe-scope ctxt) + + (semantic-analyzer-debug-show-completions comp) + + (princ "When Semantic cannot find a symbol, it could be because the include +path was setup incorrectly.\n") + + (semantic-analyzer-debug-insert-include-summary tab) + + )) + (semantic-analyzer-debug-add-buttons) + )) + +(defun semantic-analyzer-debug-missing-datatype (ctxt idx comp) + "Debug why we can't find a datatype entry for CTXT prefix at IDX. +Argument COMP are possible completions here." + (let* ((prefixitem (nth idx (oref ctxt prefix))) + (dt (nth (1- idx) (oref ctxt prefixtypes))) + (tt (semantic-tag-type prefixitem)) + (tab semanticdb-current-table) + ) + (when dt (error "Missing Datatype debugger is confused")) + (with-output-to-temp-buffer (help-buffer) + (with-current-buffer standard-output + (princ "Unable to find datatype for: \"") + (princ (semantic-format-tag-prototype prefixitem)) + (princ "\". +Declared type is: ") + (when (semantic-tag-p tt) + (semantic-analyzer-debug-insert-tag tt) + (princ "\nRaw data type is: ")) + (princ (format "%S" tt)) + (princ " + +Semantic could not find this data type in any of its global tables. + +Semantic locates datatypes through either the local scope, or the global +typecache. +") + + ;; Describe local scope, and why we might not be able to + ;; find it. + (semantic-analyzer-debug-describe-scope ctxt '(type)) + + ;; Describe the typecache. + (princ "\nSemantic creates and maintains a type cache for each buffer. +If the type is a global type, then it should appear in they typecache. +To examine the typecache, type: + + M-x semanticdb-typecache-dump RET + +Current typecache Statistics:\n") + (princ (format " %4d types global in this file\n %4d types from includes.\n" + (length (semanticdb-typecache-file-tags tab)) + (length (semanticdb-typecache-include-tags tab)))) + + (princ "\nIf the datatype is not in the typecache, then your include +path may be incorrect. ") + + (semantic-analyzer-debug-insert-include-summary tab) + + ;; End with-buffer + )) + (semantic-analyzer-debug-add-buttons) + )) + +(defun semantic-analyzer-debug-missing-innertype (ctxt idx comp) + "Debug why we can't find an entry for CTXT prefix at IDX for known type. +We need to see if we have possible completions against the entry before +being too vocal about it. +Argument COMP are possible completions here." + (let* ((prefixitem (nth idx (oref ctxt prefix))) + (prevprefix (nth (1- idx) (oref ctxt prefix))) + (dt (nth (1- idx) (oref ctxt prefixtypes))) + (desired-type (semantic-analyze-type-constraint ctxt)) + (orig-buffer (current-buffer)) + (ots (semantic-analyze-tag-type prevprefix + (oref ctxt scope) + t ; Don't deref + )) + ) + (when (not dt) (error "Missing Innertype debugger is confused")) + (with-output-to-temp-buffer (help-buffer) + (with-current-buffer standard-output + (princ "Cannot find prefix \"") + (princ prefixitem) + (princ "\" in datatype: + ") + (semantic-analyzer-debug-insert-tag dt) + (princ "\n") + + (cond + ;; Any language with a namespace. + ((string= (semantic-tag-type dt) "namespace") + (princ "Semantic may not have found all possible namespaces with +the name ") + (princ (semantic-tag-name dt)) + (princ ". You can debug the entire typecache, including merged namespaces +with the command: + + M-x semanticdb-typecache-dump RET") + ) + + ;; @todo - external declarations?? + (nil + nil) + + ;; A generic explanation + (t + (princ "\nSemantic has found the datatype ") + (semantic-analyzer-debug-insert-tag dt) + (if (or (not (semantic-equivalent-tag-p ots dt)) + (not (save-excursion + (set-buffer orig-buffer) + (car (semantic-analyze-dereference-metatype + ots (oref ctxt scope)))))) + (let ((lasttype ots) + (nexttype (save-excursion + (set-buffer orig-buffer) + (car (semantic-analyze-dereference-metatype + ots (oref ctxt scope)))))) + (if (eq nexttype lasttype) + (princ "\n [ Debugger error trying to help with metatypes ]") + + (if (eq ots dt) + (princ "\nwhich is a metatype") + (princ "\nwhich is derived from metatype ") + (semantic-analyzer-debug-insert-tag lasttype))) + + (princ ".\nThe Metatype stack is:\n") + (princ " ") + (semantic-analyzer-debug-insert-tag lasttype) + (princ "\n") + (while (and nexttype + (not (eq nexttype lasttype))) + (princ " ") + (semantic-analyzer-debug-insert-tag nexttype) + (princ "\n") + (setq lasttype nexttype + nexttype + (save-excursion + (set-buffer orig-buffer) + (car (semantic-analyze-dereference-metatype + nexttype (oref ctxt scope))))) + ) + (when (not nexttype) + (princ " nil\n\n") + (princ + "Last metatype is nil. This means that semantic cannot derive +the list of members because the type referred to cannot be found.\n") + ) + ) + (princ "\nand its list of members.") + + (if (not comp) + (progn + (princ " Semantic does not know what +possible completions there are for \"") + (princ prefixitem) + (princ "\". Examine the known +members below for more.")) + (princ " Semantic knows of some +possible completions for \"") + (princ prefixitem) + (princ "\"."))) + ) + ;; end cond + ) + + (princ "\n") + (semantic-analyzer-debug-show-completions comp) + + (princ "\nKnown members of ") + (princ (semantic-tag-name dt)) + (princ ":\n") + (dolist (M (semantic-tag-type-members dt)) + (princ " ") + ;;(princ (semantic-format-tag-prototype M)) + (semantic-analyzer-debug-insert-tag M) + (princ "\n")) + + ;; This doesn't refer to in-type completions. + ;;(semantic-analyzer-debug-global-miss-text prefixitem) + + ;; More explanation + (when desired-type + (princ "\nWhen there are known members that would make good completion +candidates that are not in the completion list, then the most likely +cause is a type constraint. Semantic has determined that there is a +type constraint looking for the type ") + (if (semantic-tag-p desired-type) + (semantic-analyzer-debug-insert-tag desired-type) + (princ (format "%S" desired-type))) + (princ ".")) + )) + (semantic-analyzer-debug-add-buttons) + + )) + + +(defun semantic-analyzer-debug-test-local-context () + "Test the local context parsed from the file." + (let* ((prefixandbounds (semantic-ctxt-current-symbol-and-bounds (point))) + (prefix (car prefixandbounds)) + (bounds (nth 2 prefixandbounds)) + ) + (when (and (or (not prefixandbounds) + (not prefix) + (not bounds)) + ) + (with-output-to-temp-buffer (help-buffer) + (with-current-buffer standard-output + (princ "Local Context Parser Failed. + +If this is unexpected, then there is likely a bug in the Semantic +local context parser. + +Consider debugging the function ") + (let ((lcf (fetch-overload 'semantic-ctxt-current-symbol-and-bounds))) + (if lcf + (princ (symbol-name lcf)) + (princ "semantic-ctxt-current-symbol-and-bounds, +or implementing a version specific to ") + (princ (symbol-name major-mode)) + ) + (princ ".\n")) + (semantic-analyzer-debug-add-buttons) + t))) + )) + +;;; General Inserters with help +;; +(defun semantic-analyzer-debug-show-completions (comp) + "Show the completion list COMP." + (if (not comp) + (princ "\nNo known possible completions.\n") + + (princ "\nPossible completions are:\n") + (dolist (C comp) + (princ " ") + (cond ((stringp C) + (princ C) + ) + ((semantic-tag-p C) + (semantic-analyzer-debug-insert-tag C))) + (princ "\n")) + (princ "\n"))) + +(defun semantic-analyzer-debug-insert-include-summary (table) + "Display a summary of includes for the semanticdb TABLE." + (semantic-fetch-tags) + (let ((inc (semantic-find-tags-by-class 'include table)) + ;;(path (semanticdb-find-test-translate-path-no-loading)) + (unk + (save-excursion + (set-buffer (semanticdb-get-buffer table)) + semanticdb-find-lost-includes)) + (ip + (save-excursion + (set-buffer (semanticdb-get-buffer table)) + semantic-dependency-system-include-path)) + (edeobj + (save-excursion + (set-buffer (semanticdb-get-buffer table)) + ede-object)) + (edeproj + (save-excursion + (set-buffer (semanticdb-get-buffer table)) + ede-object-project)) + ) + + (princ "\n\nInclude Path Summary:") + (when edeobj + (princ "\n\nThis file's project include search is handled by the EDE object:\n") + (princ " Buffer Target: ") + (princ (object-print edeobj)) + (princ "\n") + (when (not (eq edeobj edeproj)) + (princ " Buffer Project: ") + (princ (object-print edeproj)) + (princ "\n")) + (when edeproj + (let ((loc (ede-get-locator-object edeproj))) + (princ " Backup Locator: ") + (princ (object-print loc)) + (princ "\n"))) + ) + + (princ "\n\nThe system include path is:\n") + (dolist (dir ip) + (princ " ") + (princ dir) + (princ "\n")) + + (princ "\n\nInclude Summary: ") + (princ (semanticdb-full-filename table)) + (princ "\n\n") + (princ (format "%s contains %d includes.\n" + (file-name-nondirectory + (semanticdb-full-filename table)) + (length inc))) + (let ((ok 0) + (unknown 0) + (unparsed 0) + (all 0)) + (dolist (i inc) + (let* ((fileinner (semantic-dependency-tag-file i)) + (tableinner (when fileinner + (semanticdb-file-table-object fileinner t)))) + (cond ((not fileinner) + (setq unknown (1+ unknown))) + ((number-or-marker-p (oref tableinner pointmax)) + (setq ok (1+ ok))) + (t + (setq unparsed (1+ unparsed)))))) + (setq all (+ ok unknown unparsed)) + (when (not (= 0 all)) + (princ (format " Unknown Includes: %d\n" unknown)) + (princ (format " Unparsed Includes: %d\n" unparsed)) + (princ (format " Parsed Includes: %d\n" ok))) + ) + + ;; Unknowns... + (if unk + (progn + (princ "\nA likely cause of an unfound tag is missing include files.") + (semantic-analyzer-debug-insert-tag-list + "The following includes were not found" unk) + + (princ "\nYou can fix the include path for ") + (princ (symbol-name (oref table major-mode))) + (princ " by using this function: + +M-x semantic-customize-system-include-path RET + +which customizes the mode specific variable for the mode-local +variable `semantic-dependency-system-include-path'.") + ) + + (princ "\n No unknown includes.\n")) + )) + +(defun semantic-analyzer-debug-describe-scope (ctxt &optional classconstraint) + "Describe the scope in CTXT for finding a global symbol. +Optional argument CLASSCONSTRAINT says to output to tags of that class." + (let* ((scope (oref ctxt :scope)) + (parents (oref scope parents)) + (cc (or classconstraint (oref ctxt prefixclass))) + ) + (princ "\nLocal Scope Information:") + (princ "\n * Tag Class Constraint against SCOPE: ") + (princ (format "%S" classconstraint)) + + (if parents + (semantic-analyzer-debug-insert-tag-list + " >> Known parent types with possible in scope symbols" + parents) + (princ "\n * No known parents in current scope.")) + + (let ((si (semantic-analyze-tags-of-class-list + (oref scope scope) cc)) + (lv (semantic-analyze-tags-of-class-list + (oref scope localvar) cc)) + ) + (if si + (semantic-analyzer-debug-insert-tag-list + " >> Known symbols within the current scope" + si) + (princ "\n * No known symbols currently in scope.")) + + (if lv + (semantic-analyzer-debug-insert-tag-list + " >> Known symbols that are declared locally" + lv) + (princ "\n * No known symbols declared locally.")) + ) + ) + ) + +(defun semantic-analyzer-debug-global-miss-text (name-in) + "Use 'princ' to show text describing not finding symbol NAME-IN. +NAME is the name of the unfound symbol." + (let ((name (cond ((stringp name-in) + name-in) + ((semantic-tag-p name-in) + (semantic-format-tag-name name-in)) + (t (format "%S" name-in))))) + (when (not (string= name "")) + (princ "\nIf ") + (princ name) + (princ " is a local variable, argument, or symbol in some +namespace or class exposed via scoping statements, then it should +appear in the scope. + +Debugging the scope can be done with: + M-x semantic-calculate-scope RET + +If the prefix is a global symbol, in an included file, then +your search path may be incomplete. +")))) + +;;; Utils +;; +(defun semantic-analyzer-debug-insert-tag-list (text taglist) + "Prefixing with TEXT, dump TAGLIST in a help buffer." + (princ "\n") (princ text) (princ ":\n") + + (dolist (M taglist) + (princ " ") + ;;(princ (semantic-format-tag-prototype M)) + (semantic-analyzer-debug-insert-tag M) + (princ "\n")) + ) + +(defun semantic-analyzer-debug-insert-tag (tag &optional parent) + "Display a TAG by name, with possible jumpitude. +PARENT is a possible parent (by nesting) tag." + (let ((str (semantic-format-tag-prototype tag parent))) + (if (and (semantic-tag-with-position-p tag) + (semantic-tag-file-name tag)) + (insert-button str + 'mouse-face 'custom-button-pressed-face + 'tag tag + 'action + `(lambda (button) + (let ((buff nil) + (pnt nil)) + (save-excursion + (semantic-go-to-tag + (button-get button 'tag)) + (setq buff (current-buffer)) + (setq pnt (point))) + (if (get-buffer-window buff) + (select-window (get-buffer-window buff)) + (pop-to-buffer buff t)) + (goto-char pnt) + (pulse-line-hook-function))) + ) + (princ "\"") + (princ str) + (princ "\"")) + )) + +(defvar semantic-analyzer-debug-orig nil + "The originating buffer for a help button.") + +(defun semantic-analyzer-debug-add-buttons () + "Add push-buttons to the *Help* buffer. +Look for key expressions, and add push-buttons near them." + (let ((orig-buffer (make-marker))) + (set-marker orig-buffer (point) (current-buffer)) + (save-excursion + ;; Get a buffer ready. + (set-buffer "*Help*") + (toggle-read-only -1) + (goto-char (point-min)) + (set (make-local-variable 'semantic-analyzer-debug-orig) orig-buffer) + ;; First, add do-in buttons to recommendations. + (while (re-search-forward "^\\s-*M-x \\(\\(\\w\\|\\s_\\)+\\) " nil t) + (let ((fcn (match-string 1))) + (when (not (fboundp (intern-soft fcn))) + (error "Help Err: Can't find %s" fcn)) + (end-of-line) + (insert " ") + (insert-button "[ Do It ]" + 'mouse-face 'custom-button-pressed-face + 'do-fcn fcn + 'action `(lambda (arg) + (let ((M semantic-analyzer-debug-orig)) + (set-buffer (marker-buffer M)) + (goto-char M)) + (call-interactively (quote ,(intern-soft fcn)))) + ) + )) + ;; Do something else? + + ;; Clean up the mess + (toggle-read-only 1) + (set-buffer-modified-p nil) + ))) + +(provide 'semantic/analyze/debug) + +;;; semantic/analyze/debug.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/analyze/fcn.el Sat Aug 29 19:45:47 2009 +0000 @@ -0,0 +1,325 @@ +;;; semantic/analyze/fcn.el --- Analyzer support functions. + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; 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: +;; +;; Analyzer support functions. + +;;; Code: + +;;; Small Mode Specific Options +;; +;; These queries allow a major mode to help the analyzer make decisions. +;; +(define-overloadable-function semantic-analyze-tag-prototype-p (tag) + "Non-nil if TAG is a prototype." + ) + +(defun semantic-analyze-tag-prototype-p-default (tag) + "Non-nil if TAG is a prototype." + (let ((p (semantic-tag-get-attribute tag :prototype-flag))) + (cond + ;; Trust the parser author. + (p p) + ;; Empty types might be a prototype. + ((eq (semantic-tag-class tag) 'type) + (not (semantic-tag-type-members tag))) + ;; No other heuristics. + (t nil)) + )) + +;;------------------------------------------------------------ + +(define-overloadable-function semantic-analyze-split-name (name) + "Split a tag NAME into a sequence. +Sometimes NAMES are gathered from the parser that are compounded, +such as in C++ where foo::bar means: + \"The class BAR in the namespace FOO.\" +Return the string NAME for no change, or a list if it needs to be split.") + +(defun semantic-analyze-split-name-default (name) + "Don't split up NAME by default." + name) + +(define-overloadable-function semantic-analyze-unsplit-name (namelist) + "Assemble a NAMELIST into a string representing a compound name. +Return the string representing the compound name.") + +(defun semantic-analyze-unsplit-name-default (namelist) + "Concatenate the names in NAMELIST with a . between." + (mapconcat 'identity namelist ".")) + +;;; SELECTING +;; +;; If you narrow things down to a list of tags that all mean +;; the same thing, how to you pick one? Select or merge. +;; + +(defun semantic-analyze-select-best-tag (sequence &optional tagclass) + "For a SEQUENCE of tags, all with good names, pick the best one. +If SEQUENCE is made up of namespaces, merge the namespaces together. +If SEQUENCE has several prototypes, find the non-prototype. +If SEQUENCE has some items w/ no type information, find the one with a type. +If SEQUENCE is all prototypes, or has no prototypes, get the first one. +Optional TAGCLASS indicates to restrict the return to only +tags of TAGCLASS." + + ;; If there is a srew up and we get just one tag.. massage over it. + (when (semantic-tag-p sequence) + (setq sequence (list sequence))) + + ;; Filter out anything not of TAGCLASS + (when tagclass + (setq sequence (semantic-find-tags-by-class tagclass sequence))) + + (if (< (length sequence) 2) + ;; If the remaining sequence is 1 tag or less, just return it + ;; and skip the rest of this mumbo-jumbo. + (car sequence) + + ;; 1) + ;; This step will eliminate a vast majority of the types, + ;; in addition to merging namespaces together. + ;; + ;; 2) + ;; It will also remove prototypes. + (setq sequence (semanticdb-typecache-merge-streams sequence nil)) + + (if (< (length sequence) 2) + ;; If the remaining sequence after the merge is 1 tag or less, + ;; just return it and skip the rest of this mumbo-jumbo. + (car sequence) + + (let ((best nil) + (notypeinfo nil) + ) + (while (and (not best) sequence) + + ;; 3) select a non-prototype. + (if (not (semantic-tag-type (car sequence))) + (setq notypeinfo (car sequence)) + + (setq best (car sequence)) + ) + + (setq sequence (cdr sequence))) + + ;; Select the best, or at least the prototype. + (or best notypeinfo))))) + +;;; Tag Finding +;; +;; Mechanism for lookup up tags by name. +;; +(defun semantic-analyze-find-tags-by-prefix (prefix) + ;; @todo - only used in semantic-complete. Find something better? + "Attempt to find a tag with PREFIX. +This is a wrapper on top of semanticdb, and semantic search functions. +Almost all searches use the same arguments." + (if (and (fboundp 'semanticdb-minor-mode-p) + (semanticdb-minor-mode-p)) + ;; Search the database & concatenate all matches together. + (semanticdb-strip-find-results + (semanticdb-find-tags-for-completion prefix) + 'name) + ;; Search just this file because there is no DB available. + (semantic-find-tags-for-completion + prefix (current-buffer)))) + +;;; Finding Datatypes +;; +;; Finding a data type by name within a project. +;; +(defun semantic-analyze-type-to-name (type) + "Get the name of TAG's type. +The TYPE field in a tag can be nil (return nil) +or a string, or a non-positional tag." + (cond ((semantic-tag-p type) + (semantic-tag-name type)) + ((stringp type) + type) + ((listp type) + (car type)) + (t nil))) + +(defun semantic-analyze-tag-type (tag &optional scope nometaderef) + "Return the semantic tag for a type within the type of TAG. +TAG can be a variable, function or other type of tag. +The behavior of TAG's type is defined by `semantic-analyze-type'. +Optional SCOPE represents a calculated scope in which the +types might be found. This can be nil. +If NOMETADEREF, then do not dereference metatypes. This is +used by the analyzer debugger." + (semantic-analyze-type (semantic-tag-type tag) scope nometaderef)) + +(defun semantic-analyze-type (type-declaration &optional scope nometaderef) + "Return the semantic tag for TYPE-DECLARATION. +TAG can be a variable, function or other type of tag. +The type of tag (such as a class or struct) is a name. +Lookup this name in database, and return all slots/fields +within that types field. Also handles anonymous types. +Optional SCOPE represents a calculated scope in which the +types might be found. This can be nil. +If NOMETADEREF, then do not dereference metatypes. This is +used by the analyzer debugger." + (let ((name nil) + (typetag nil) + ) + + ;; Is it an anonymous type? + (if (and type-declaration + (semantic-tag-p type-declaration) + (semantic-tag-of-class-p type-declaration 'type) + (not (semantic-analyze-tag-prototype-p type-declaration)) + ) + ;; We have an anonymous type for TAG with children. + ;; Use this type directly. + (if nometaderef + type-declaration + (semantic-analyze-dereference-metatype-stack + type-declaration scope type-declaration)) + + ;; Not an anonymous type. Look up the name of this type + ;; elsewhere, and report back. + (setq name (semantic-analyze-type-to-name type-declaration)) + + (if (and name (not (string= name ""))) + (progn + ;; Find a type of that name in scope. + (setq typetag (and scope (semantic-scope-find name 'type scope))) + ;; If no typetag, try the typecache + (when (not typetag) + (setq typetag (semanticdb-typecache-find name)))) + + ;; No name to look stuff up with. + (error "Semantic tag %S has no type information" + (semantic-tag-name type-declaration))) + + ;; Handle lists of tags. + (when (and (consp typetag) (semantic-tag-p (car typetag))) + (setq typetag (semantic-analyze-select-best-tag typetag 'type)) + ) + + ;; We now have a tag associated with the type. We need to deref it. + ;; + ;; If we were asked not to (ie - debugger) push the typecache anyway. + (if nometaderef + typetag + (unwind-protect + (progn + (semantic-scope-set-typecache + scope (semantic-scope-tag-get-scope typetag)) + (semantic-analyze-dereference-metatype-stack typetag scope type-declaration) + ) + (semantic-scope-set-typecache scope nil) + ))))) + +(defun semantic-analyze-dereference-metatype-stack (type scope &optional type-declaration) + "Dereference metatypes repeatedly until we hit a real TYPE. +Uses `semantic-analyze-dereference-metatype'. +Argument SCOPE is the scope object with additional items in which to search. +Optional argument TYPE-DECLARATION is how TYPE was found referenced." + (let ((lasttype type) + (lasttypedeclaration type-declaration) + (nexttype (semantic-analyze-dereference-metatype type scope type-declaration)) + (idx 0)) + (catch 'metatype-recursion + (while (and nexttype (not (eq (car nexttype) lasttype))) + (setq lasttype (car nexttype) + lasttypedeclaration (cadr nexttype)) + (setq nexttype (semantic-analyze-dereference-metatype lasttype scope lasttypedeclaration)) + (setq idx (1+ idx)) + (when (> idx 20) (message "Possible metatype recursion for %S" + (semantic-tag-name lasttype)) + (throw 'metatype-recursion nil)) + )) + lasttype)) + +(define-overloadable-function semantic-analyze-dereference-metatype (type scope &optional type-declaration) + ;; todo - move into typecahe!! + "Return a concrete type tag based on input TYPE tag. +A concrete type is an actual declaration of a memory description, +such as a structure, or class. A meta type is an alias, +or a typedef in C or C++. If TYPE is concrete, it +is returned. If it is a meta type, it will return the concrete +type defined by TYPE. +The default behavior always returns TYPE. +Override functions need not return a real semantic tag. +Just a name, or short tag will be ok. It will be expanded here. +SCOPE is the scope object with additional items in which to search for names." + (catch 'default-behavior + (let* ((ans-tuple (:override + ;; Nothing fancy, just return type by default. + (throw 'default-behavior (list type type-declaration)))) + (ans-type (car ans-tuple)) + (ans-type-declaration (cadr ans-tuple))) + (list (semantic-analyze-dereference-metatype-1 ans-type scope) ans-type-declaration)))) + +;; @ TODO - the typecache can also return a stack of scope names. + +(defun semantic-analyze-dereference-metatype-1 (ans scope) + "Do extra work after dereferencing a metatype. +ANS is the answer from the the language specific query. +SCOPE is the current scope." + ;; If ANS is a string, or if ANS is a short tag, we + ;; need to do some more work to look it up. + (if (stringp ans) + ;; The metatype is just a string... look it up. + (or (and scope (car-safe + ;; @todo - should this be `find the best one'? + (semantic-scope-find ans 'type scope))) + (let ((tcsans nil)) + (prog1 + (setq tcsans + (semanticdb-typecache-find ans)) + ;; While going through the metatype, if we have + ;; a scope, push our new cache in. + (when scope + (semantic-scope-set-typecache + scope (semantic-scope-tag-get-scope tcsans)) + )) + )) + (when (and (semantic-tag-p ans) + (eq (semantic-tag-class ans) 'type)) + ;; We have a tag. + (if (semantic-analyze-tag-prototype-p ans) + ;; It is a prototype.. find the real one. + (or (and scope + (car-safe + (semantic-scope-find (semantic-tag-name ans) + 'type scope))) + (let ((tcsans nil)) + (prog1 + (setq tcsans + (semanticdb-typecache-find (semantic-tag-name ans))) + ;; While going through the metatype, if we have + ;; a scope, push our new cache in. + (when scope + (semantic-scope-set-typecache + scope (semantic-scope-tag-get-scope tcsans)) + )))) + ;; We have a tag, and it is not a prototype. + ans)) + )) + +(provide 'semantic/analyze/fcn) + +;;; semantic/analyze/fcn.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/analyze/refs.el Sat Aug 29 19:45:47 2009 +0000 @@ -0,0 +1,315 @@ +;;; semantic/analyze/refs.el --- Analysis of the references between tags. + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; 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: +;; +;; Analyze the references between tags. +;; +;; The original purpose of these analysis is to provide a way to jump +;; between a prototype and implementation. +;; +;; Finding all prototype/impl matches is hard because you have to search +;; through the entire set of allowed databases to capture all possible +;; refs. The core analysis class stores basic starting point, and then +;; entire raw search data, which is expensive to calculate. +;; +;; Once the raw data is available, queries for impl, prototype, or +;; perhaps other things become cheap. + +;;; Code: +(defclass semantic-analyze-references () + ((tag :initarg :tag + :type semantic-tag + :documentation + "The starting TAG we are providing references analysis for.") + (tagdb :initarg :tagdb + :documentation + "The database that tag can be found in.") + (scope :initarg :scope + :documentation "A Scope object.") + (rawsearchdata :initarg :rawsearchdata + :documentation + "The raw search data for TAG's name across all databases.") + ;; Note: Should I cache queried data here? I expect that searching + ;; through rawsearchdata will be super-fast, so why bother? + ) + "Class containing data from a semantic analysis.") + +(define-overloadable-function semantic-analyze-tag-references (tag &optional db) + "Analyze the references for TAG. +Returns a class with information about TAG. + +Optional argument DB is a database. It will be used to help +locate TAG. + +Use `semantic-analyze-current-tag' to debug this fcn.") + +(defun semantic-analyze-tag-references-default (tag &optional db) + "Analyze the references for TAG. +Returns a class with information about TAG. + +Optional argument DB is a database. It will be used to help +locate TAG. + +Use `semantic-analyze-current-tag' to debug this fcn." + (when (not (semantic-tag-p tag)) (signal 'wrong-type-argument (list 'semantic-tag-p tag))) + (let ((allhits nil) + (scope nil) + ) + (save-excursion + (semantic-go-to-tag tag db) + (setq scope (semantic-calculate-scope)) + + (setq allhits (semantic--analyze-refs-full-lookup tag scope)) + + (semantic-analyze-references (semantic-tag-name tag) + :tag tag + :tagdb db + :scope scope + :rawsearchdata allhits) + ))) + +;;; METHODS +;; +;; These accessor methods will calculate the useful bits from the context, and cache values +;; into the context. +(defmethod semantic-analyze-refs-impl ((refs semantic-analyze-references) &optional in-buffer) + "Return the implementations derived in the reference analyzer REFS. +Optional argument IN-BUFFER indicates that the returned tag should be in an active buffer." + (let ((allhits (oref refs rawsearchdata)) + (impl nil) + ) + (semanticdb-find-result-mapc + (lambda (T DB) + "Examine T in the database DB, and sont it." + (let* ((ans (semanticdb-normalize-one-tag DB T)) + (aT (cdr ans)) + (aDB (car ans)) + ) + (when (not (semantic-tag-prototype-p aT)) + (when in-buffer (save-excursion (semantic-go-to-tag aT aDB))) + (push aT impl)))) + allhits) + impl)) + +(defmethod semantic-analyze-refs-proto ((refs semantic-analyze-references) &optional in-buffer) + "Return the prototypes derived in the reference analyzer REFS. +Optional argument IN-BUFFER indicates that the returned tag should be in an active buffer." + (let ((allhits (oref refs rawsearchdata)) + (proto nil)) + (semanticdb-find-result-mapc + (lambda (T DB) + "Examine T in the database DB, and sort it." + (let* ((ans (semanticdb-normalize-one-tag DB T)) + (aT (cdr ans)) + (aDB (car ans)) + ) + (when (semantic-tag-prototype-p aT) + (when in-buffer (save-excursion (semantic-go-to-tag aT aDB))) + (push aT proto)))) + allhits) + proto)) + +;;; LOOKUP +;; +(defun semantic--analyze-refs-full-lookup (tag scope) + "Perform a full lookup for all occurances of TAG in the current project. +TAG should be the tag currently under point. +PARENT is the list of tags that are parents to TAG by +containment, as opposed to reference." + (if (not (oref scope parents)) + ;; If this tag has some named parent, but is not + (semantic--analyze-refs-full-lookup-simple tag) + + ;; We have some sort of lineage we need to consider when we do + ;; our side lookup of tags. + (semantic--analyze-refs-full-lookup-with-parents tag scope) + )) + +(defun semantic--analyze-refs-find-child-in-find-results (find-results name class) + "Find in FIND-RESULT a tag NAME which is a child of a tag in FIND-RESULTS. +CLASS is the class of the tag that ought to be returned." + (let ((ans nil) + (subans nil)) + ;; Loop over each segment of the find results. + (dolist (FDB find-results) + (setq subans nil) + ;; Loop over each tag in the find results. + (dolist (T (cdr FDB)) + ;; For each tag, get the children. + (let* ((chil (semantic-tag-type-members T)) + (match (semantic-find-tags-by-name name chil))) + ;; Go over the matches, looking for matching tag class. + (dolist (M match) + (when (semantic-tag-of-class-p M class) + (push M subans))))) + ;; Store current matches into a new find results. + (when subans + (push (cons (car FDB) subans) ans)) + ) + ans)) + +(defun semantic--analyze-refs-find-tags-with-parent (find-results parents) + "Find in FIND-RESULTS all tags with PARNTS. +NAME is the name of the tag needing finding. +PARENTS is a list of names." + (let ((ans nil)) + (semanticdb-find-result-mapc + (lambda (tag db) + (let* ((p (semantic-tag-named-parent tag)) + (ps (when (stringp p) + (semantic-analyze-split-name p)))) + (when (stringp ps) (setq ps (list ps))) + (when (and ps (equal ps parents)) + ;; We could optimize this, but it seems unlikely. + (push (list db tag) ans)) + )) + find-results) + ans)) + +(defun semantic--analyze-refs-full-lookup-with-parents (tag scope) + "Perform a lookup for all occurances of TAG based on TAG's SCOPE. +TAG should be the tag currently under point." + (let* ((classmatch (semantic-tag-class tag)) + (plist (mapcar (lambda (T) (semantic-tag-name T)) (oref scope parents))) + ;; The first item in the parent list + (name (car plist)) + ;; Stuff from the simple list. + (simple (semantic--analyze-refs-full-lookup-simple tag t)) + ;; Find all hits for the first parent name. + (brute (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-find-tags-by-name-method table name tags) + ) + nil nil t)) + ;; Prime the answer. + (answer (semantic--analyze-refs-find-tags-with-parent simple plist)) + ) + ;; First parent is already search to initialize "brute". + (setq plist (cdr plist)) + ;; Go through the list of parents, and try to find matches. + ;; As we cycle through plist, for each level look for NAME, + ;; and compare the named-parent, and also dive into the next item of + ;; plist. + (while (and plist brute) + + ;; Find direct matches + (let* ((direct (semantic--analyze-refs-find-child-in-find-results + brute (semantic-tag-name tag) classmatch)) + (pdirect (semantic--analyze-refs-find-tags-with-parent + direct plist))) + (setq answer (append pdirect answer))) + + ;; The next set of search items. + (setq brute (semantic--analyze-refs-find-child-in-find-results + brute (car plist) 'type)) + + (setq plist (cdr plist))) + + ;; Brute now has the children from the very last match. + (let* ((direct (semantic--analyze-refs-find-child-in-find-results + brute (semantic-tag-name tag) classmatch)) + ) + (setq answer (append direct answer))) + + answer)) + +(defun semantic--analyze-refs-full-lookup-simple (tag &optional noerror) + "Perform a simple lookup for occurances of TAG in the current project. +TAG should be the tag currently under point. +Optional NOERROR means don't throw errors on failure to find something. +This only compares the tag name, and does not infer any matches in namespaces, +or parts of some other data structure. +Only works for tags in the global namespace." + (let* ((name (semantic-tag-name tag)) + (brute (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-find-tags-by-name-method table name tags) + ) + nil nil t)) + ) + + (when (and (not brute) (not noerror)) + ;; An error, because tag under point ought to be found. + (error "Cannot find any references to %s in wide search" name)) + + (let* ((classmatch (semantic-tag-class tag)) + (RES + (semanticdb-find-tags-collector + (lambda (table tags) + (semantic-find-tags-by-class classmatch tags) + ;; @todo - Add parent check also. + ) + brute nil))) + + (when (and (not RES) (not noerror)) + (error "Cannot find any definitions for %s in wide search" + (semantic-tag-name tag))) + + ;; Return the matching tags and databases. + RES))) + + +;;; USER COMMANDS +;; +(defun semantic-analyze-current-tag () + "Analyze the tag under point." + (interactive) + (let* ((tag (semantic-current-tag)) + (start (current-time)) + (sac (semantic-analyze-tag-references tag)) + (end (current-time)) + ) + (message "Analysis took %.2f seconds." (semantic-elapsed-time start end)) + (if sac + (progn + (data-debug-new-buffer "*Analyzer Reference ADEBUG*") + (data-debug-insert-object-slots sac "]")) + (message "No Context to analyze here.")))) + +(defun semantic-analyze-proto-impl-toggle () + "Toggle between the implementation, and a prototype of tag under point." + (interactive) + (semantic-fetch-tags) + (let* ((tag (semantic-current-tag)) + (sar (if tag + (semantic-analyze-tag-references tag) + (error "Point must be in a declaration"))) + (target (if (semantic-tag-prototype-p tag) + (car (semantic-analyze-refs-impl sar t)) + (car (semantic-analyze-refs-proto sar t)))) + ) + + (when (not target) + (error "Could not find suitable %s" + (if (semantic-tag-prototype-p tag) "implementation" "prototype"))) + + (push-mark) + (semantic-go-to-tag target) + (switch-to-buffer (current-buffer)) + (semantic-momentary-highlight-tag target)) + ) + + + +(provide 'semantic/analyze/refs) + +;;; semantic/analyze/refs.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/debug.el Sat Aug 29 19:45:47 2009 +0000 @@ -0,0 +1,566 @@ +;;; debug.el --- Language Debugger framework + +;;; Copyright (C) 2003, 2004, 2005, 2008 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; 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: +;; +;; To provide better support for debugging parsers, this framework +;; provides the interface for debugging. The work of parsing and +;; controlling and stepping through the parsing work must be implemented +;; by the parser. +;; +;; Fortunatly, the nature of language support files means that the parser +;; may not need to be instrumented first. +;; +;; The debugger uses EIEIO objects. One object controls the user +;; interface, including stepping, data-view, queries. A second +;; object implemented here represents the parser itself. A third represents +;; a parser independent frame which knows how to highlight the parser buffer. +;; Each parser must implement the interface and override any methods as needed. +;; + +(require 'semantic) +(require 'eieio) +;; (require 'inversion) +;; (inversion-require 'eieio "0.18beta1") + +;;; Code: +(defvar semantic-debug-parser-source nil + "For any buffer, the file name (no path) of the parser. +This would be a parser for a specific language, not the source +to one of the parser generators.") +(make-variable-buffer-local 'semantic-debug-parser-source) + +(defvar semantic-debug-parser-class nil + "Class to create when building a debug parser object.") +(make-variable-buffer-local 'semantic-debug-parser-class) + +(defvar semantic-debug-enabled nil + "Non-nil when debugging a parser.") + +;;; Variables used during a debug session. +(defvar semantic-debug-current-interface nil + "The debugger interface currently active for this buffer.") + +(defvar semantic-debug-current-parser nil + "The parser current active for this buffer.") + +;;; User Interface Portion +;; +(defclass semantic-debug-interface () + ((parser-buffer :initarg :parser-buffer + :type buffer + :documentation + "The buffer containing the parser we are debugging.") + (parser-local-map :initarg :parser-local-map + :type keymap + :documentation + "The local keymap originally in the PARSER buffer.") + (parser-location :type marker + :documentation + "A marker representing where we are in the parser buffer.") + (source-buffer :initarg :source-buffer + :type buffer + :documentation + "The buffer containing the source we are parsing. +The :parser-buffer defines a parser that can parse the text in the +:source-buffer.") + (source-local-map :initarg :source-local-map + :type keymap + :documentation + "The local keymap originally in the SOURCE buffer.") + (source-location :type marker + :documentation + "A marker representing where we are in the parser buffer.") + (data-buffer :initarg :data-buffer + :type buffer + :documentation + "Buffer being used to display some useful data. +These buffers are brought into view when layout occurs.") + (current-frame :type semantic-debug-frame + :documentation + "The currently displayed frame.") + (overlays :type list + :initarg nil + :documentation + "Any active overlays being used to show the debug position.") + ) + "Controls action when in `semantic-debug-mode'") + +;; Methods +(defmethod semantic-debug-set-frame ((iface semantic-debug-interface) frame) + "Set the current frame on IFACE to FRAME." + (if frame + (oset iface current-frame frame) + (slot-makeunbound iface 'current-frame))) + +(defmethod semantic-debug-set-parser-location ((iface semantic-debug-interface) point) + "Set the parser location in IFACE to POINT." + (save-excursion + (set-buffer (oref iface parser-buffer)) + (if (not (slot-boundp iface 'parser-location)) + (oset iface parser-location (make-marker))) + (move-marker (oref iface parser-location) point)) + ) + +(defmethod semantic-debug-set-source-location ((iface semantic-debug-interface) point) + "Set the source location in IFACE to POINT." + (save-excursion + (set-buffer (oref iface source-buffer)) + (if (not (slot-boundp iface 'source-location)) + (oset iface source-location (make-marker))) + (move-marker (oref iface source-location) point)) + ) + +(defmethod semantic-debug-interface-layout ((iface semantic-debug-interface)) + "Layout windows in the current frame to facilitate debugging." + (delete-other-windows) + ;; Deal with the data buffer + (when (slot-boundp iface 'data-buffer) + (let ((lines (/ (frame-height (selected-frame)) 3)) + (cnt (save-excursion + (set-buffer (oref iface data-buffer)) + (count-lines (point-min) (point-max)))) + ) + ;; Set the number of lines to 1/3, or the size of the data buffer. + (if (< cnt lines) (setq cnt lines)) + + (split-window-vertically cnt) + (switch-to-buffer (oref iface data-buffer)) + ) + (other-window 1)) + ;; Parser + (switch-to-buffer (oref iface parser-buffer)) + (when (slot-boundp iface 'parser-location) + (goto-char (oref iface parser-location))) + (split-window-vertically) + (other-window 1) + ;; Source + (switch-to-buffer (oref iface source-buffer)) + (when (slot-boundp iface 'source-location) + (goto-char (oref iface source-location))) + ) + +(defmethod semantic-debug-highlight-lexical-token ((iface semantic-debug-interface) token) + "For IFACE, highlight TOKEN in the source buffer . +TOKEN is a lexical token." + (set-buffer (oref iface :source-buffer)) + + (object-add-to-list iface 'overlays + (semantic-lex-highlight-token token)) + + (semantic-debug-set-source-location iface (semantic-lex-token-start token)) + ) + +(defmethod semantic-debug-highlight-rule ((iface semantic-debug-interface) nonterm &optional rule match) + "For IFACE, highlight NONTERM in the parser buffer. +NONTERM is the name of the rule currently being processed that shows up +as a nonterminal (or tag) in the source buffer. +If RULE and MATCH indicies are specified, highlight those also." + (set-buffer (oref iface :parser-buffer)) + + (let* ((rules (semantic-find-tags-by-class 'nonterminal (current-buffer))) + (nt (semantic-find-first-tag-by-name nonterm rules)) + (o nil) + ) + (when nt + ;; I know it is the first symbol appearing in the body of this token. + (goto-char (semantic-tag-start nt)) + + (setq o (semantic-make-overlay (point) (progn (forward-sexp 1) (point)))) + (semantic-overlay-put o 'face 'highlight) + + (object-add-to-list iface 'overlays o) + + (semantic-debug-set-parser-location iface (semantic-overlay-start o)) + + (when (and rule match) + + ;; Rule, an int, is the rule inside the nonterminal we are following. + (re-search-forward ":\\s-*") + (while (/= 0 rule) + (re-search-forward "^\\s-*|\\s-*") + (setq rule (1- rule))) + + ;; Now find the match inside the rule + (while (/= 0 match) + (forward-sexp 1) + (skip-chars-forward " \t") + (setq match (1- match))) + + ;; Now highlight the thingy we find there. + (setq o (semantic-make-overlay (point) (progn (forward-sexp 1) (point)))) + (semantic-overlay-put o 'face 'highlight) + + (object-add-to-list iface 'overlays o) + + ;; If we have a match for a sub-rule, have the parser position + ;; move so we can see it in the output window for very long rules. + (semantic-debug-set-parser-location iface (semantic-overlay-start o)) + + )))) + +(defmethod semantic-debug-unhighlight ((iface semantic-debug-interface)) + "Remove all debugging overlays." + (mapc 'semantic-overlay-delete (oref iface overlays)) + (oset iface overlays nil)) + +;; Call from the parser at a breakpoint +(defvar semantic-debug-user-command nil + "The command the user is requesting.") + +(defun semantic-debug-break (frame) + "Stop parsing now at FRAME. +FRAME is an object that represents the parser's view of the +current state of the world. +This function enters a recursive edit. It returns +on an `exit-recursive-edit', or if someone uses one +of the `semantic-debug-mode' commands. +It returns the command specified. Parsers need to take action +on different types of return values." + (save-window-excursion + ;; Set up displaying information + (semantic-debug-mode t) + (unwind-protect + (progn + (semantic-debug-frame-highlight frame) + (semantic-debug-interface-layout semantic-debug-current-interface) + (condition-case nil + ;; Enter recursive edit... wait for user command. + (recursive-edit) + (error nil))) + (semantic-debug-unhighlight semantic-debug-current-interface) + (semantic-debug-mode nil)) + ;; Find the requested user state. Do something. + (let ((returnstate semantic-debug-user-command)) + (setq semantic-debug-user-command nil) + returnstate) + )) + +;;; Frame +;; +;; A frame can represent the state at a break point. +(defclass semantic-debug-frame () + ( + ) + "One frame representation.") + +(defmethod semantic-debug-frame-highlight ((frame semantic-debug-frame)) + "Highlight one parser frame." + + ) + +(defmethod semantic-debug-frame-info ((frame semantic-debug-frame)) + "Display info about this one parser frame." + + ) + +;;; Major Mode +;; +(defvar semantic-debug-mode-map + (let ((km (make-sparse-keymap))) + (define-key km "n" 'semantic-debug-next) + (define-key km " " 'semantic-debug-next) + (define-key km "s" 'semantic-debug-step) + (define-key km "u" 'semantic-debug-up) + (define-key km "d" 'semantic-debug-down) + (define-key km "f" 'semantic-debug-fail-match) + (define-key km "h" 'semantic-debug-print-state) + (define-key km "s" 'semantic-debug-jump-to-source) + (define-key km "p" 'semantic-debug-jump-to-parser) + (define-key km "q" 'semantic-debug-quit) + (define-key km "a" 'semantic-debug-abort) + (define-key km "g" 'semantic-debug-go) + (define-key km "b" 'semantic-debug-set-breakpoint) + ;; Some boring bindings. + (define-key km "e" 'eval-expression) + + km) + "Keymap used when in semantic-debug-node.") + +(defun semantic-debug-mode (onoff) + "Turn `semantic-debug-mode' on and off. +Argument ONOFF is non-nil when we are entering debug mode. +\\{semantic-debug-mode-map}" + (let ((iface semantic-debug-current-interface)) + (if onoff + ;; Turn it on + (save-excursion + (set-buffer (oref iface parser-buffer)) + ;; Install our map onto this buffer + (use-local-map semantic-debug-mode-map) + ;; Make the buffer read only + (toggle-read-only 1) + + (set-buffer (oref iface source-buffer)) + ;; Use our map in the source buffer also + (use-local-map semantic-debug-mode-map) + ;; Make the buffer read only + (toggle-read-only 1) + ;; Hooks + (run-hooks 'semantic-debug-mode-hooks) + ) + ;; Restore old mode information + (save-excursion + (set-buffer + (oref semantic-debug-current-interface parser-buffer)) + (use-local-map + (oref semantic-debug-current-interface parser-local-map)) + ) + (save-excursion + (set-buffer + (oref semantic-debug-current-interface source-buffer)) + (use-local-map + (oref semantic-debug-current-interface source-local-map)) + ) + (run-hooks 'semantic-debug-exit-hooks) + ))) + +(defun semantic-debug () + "Parse the current buffer and run in debug mode." + (interactive) + (if semantic-debug-current-interface + (error "You are already in a debug session")) + (if (not semantic-debug-parser-class) + (error "This major mode does not support parser debugging")) + ;; Clear the cache to force a full reparse. + (semantic-clear-toplevel-cache) + ;; Do the parse + (let ((semantic-debug-enabled t) + ;; Create an interface + (semantic-debug-current-interface + (let ((parserb (semantic-debug-find-parser-source))) + (semantic-debug-interface + "Debug Interface" + :parser-buffer parserb + :parser-local-map (save-excursion + (set-buffer parserb) + (current-local-map)) + :source-buffer (current-buffer) + :source-local-map (current-local-map) + ))) + ;; Create a parser debug interface + (semantic-debug-current-parser + (funcall semantic-debug-parser-class "parser")) + ) + ;; We could recurse into a parser while debugging. + ;; Is that a problem? + (semantic-fetch-tags) + ;; We should turn the auto-parser back on, but don't do it for + ;; now until the debugger is working well. + )) + +(defun semantic-debug-find-parser-source () + "Return a buffer containing the parser source file for the current buffer. +The parser needs to be on the load path, or this routine returns nil." + (if (not semantic-debug-parser-source) + (error "No parser is associated with this buffer")) + (let ((parser (locate-library semantic-debug-parser-source t))) + (if parser + (find-file-noselect parser) + (error "Cannot find parser source. It should be on the load-path")))) + +;;; Debugger commands +;; +(defun semantic-debug-next () + "Perform one parser operation. +In the recursive parser, this steps past one match rule. +In other parsers, this may be just like `semantic-debug-step'." + (interactive) + (let ((parser semantic-debug-current-parser)) + (semantic-debug-parser-next parser) + (exit-recursive-edit) + ) + ) + +(defun semantic-debug-step () + "Perform one parser operation." + (interactive) + (let ((parser semantic-debug-current-parser)) + (semantic-debug-parser-step parser) + (exit-recursive-edit) + ) + ) + +(defun semantic-debug-up () + "Move highlighting representation up one level." + (interactive) + (message "Not implemented yet.") + ) + +(defun semantic-debug-down () + "Move highlighting representation down one level." + (interactive) + (message "Not implemented yet.") + ) + +(defun semantic-debug-fail-match () + "Artificially fail the current match." + (interactive) + (let ((parser semantic-debug-current-parser)) + (semantic-debug-parser-fail parser) + (exit-recursive-edit) + ) + ) + +(defun semantic-debug-print-state () + "Show interesting parser state." + (interactive) + (let ((parser semantic-debug-current-parser)) + (semantic-debug-parser-print-state parser) + ) + ) + +(defun semantic-debug-jump-to-source () + "Move cursor to the source code being parsed at the current lexical token." + (interactive) + (let* ((interface semantic-debug-current-interface) + (buf (oref interface source-buffer))) + (if (get-buffer-window buf) + (progn + (select-frame (window-frame (get-buffer-window buf))) + (select-window (get-buffer-window buf))) + ;; Technically, this should do a window layout operation + (switch-to-buffer buf)) + ) + ) + +(defun semantic-debug-jump-to-parser () + "Move cursor to the parser being debugged." + (interactive) + (let* ((interface semantic-debug-current-interface) + (buf (oref interface parser-buffer))) + (if (get-buffer-window buf) + (progn + (select-frame (window-frame (get-buffer-window buf))) + (select-window (get-buffer-window buf))) + ;; Technically, this should do a window layout operation + (switch-to-buffer buf)) + ) + ) + +(defun semantic-debug-quit () + "Exit debug mode, blowing all stack, and leaving the parse incomplete. +Do not update any tokens already parsed." + (interactive) + (let ((parser semantic-debug-current-parser)) + (semantic-debug-parser-quit parser) + (exit-recursive-edit) + ) + ) + +(defun semantic-debug-abort () + "Abort one level of debug mode, blowing all stack." + (interactive) + (let ((parser semantic-debug-current-parser)) + (semantic-debug-parser-abort parser) + (exit-recursive-edit) + ) + ) + +(defun semantic-debug-go () + "Continue parsing till finish or breakpoint." + (interactive) + (let ((parser semantic-debug-current-parser)) + (semantic-debug-parser-go parser) + (exit-recursive-edit) + ) + ) + +(defun semantic-debug-set-breakpoint () + "Set a breakpoint at the current rule location." + (interactive) + (let ((parser semantic-debug-current-parser) + ;; Get the location as semantic tokens. + (location (semantic-current-tag)) + ) + (if location + (semantic-debug-parser-break parser location) + (error "Not on a rule")) + ) + ) + + +;;; Debugger superclass +;; +(defclass semantic-debug-parser () + ( + ) + "Represents a parser and its state. +When implementing the debug parser you can add extra functionality +by overriding one of the command methods. Be sure to use +`call-next-method' so that the debug command is saved, and passed +down to your parser later." + :abstract t) + +(defmethod semantic-debug-parser-next ((parser semantic-debug-parser)) + "Execute next for this PARSER." + (setq semantic-debug-user-command 'next) + ) + +(defmethod semantic-debug-parser-step ((parser semantic-debug-parser)) + "Execute a step for this PARSER." + (setq semantic-debug-user-command 'step) + ) + +(defmethod semantic-debug-parser-go ((parser semantic-debug-parser)) + "Continue executiong in this PARSER until the next breakpoint." + (setq semantic-debug-user-command 'go) + ) + +(defmethod semantic-debug-parser-fail ((parser semantic-debug-parser)) + "Continue executiong in this PARSER until the next breakpoint." + (setq semantic-debug-user-command 'fail) + ) + +(defmethod semantic-debug-parser-quit ((parser semantic-debug-parser)) + "Continue executiong in this PARSER until the next breakpoint." + (setq semantic-debug-user-command 'quit) + ) + +(defmethod semantic-debug-parser-abort ((parser semantic-debug-parser)) + "Continue executiong in this PARSER until the next breakpoint." + (setq semantic-debug-user-command 'abort) + ) + +(defmethod semantic-debug-parser-print-state ((parser semantic-debug-parser)) + "Print state for this PARSER at the current breakpoint." + (with-slots (current-frame) semantic-debug-current-interface + (when current-frame + (semantic-debug-frame-info current-frame) + ))) + +(defmethod semantic-debug-parser-break ((parser semantic-debug-parser)) + "Set a breakpoint for this PARSER." + ) + +;; Stack stuff +(defmethod semantic-debug-parser-frames ((parser semantic-debug-parser)) + "Return a list of frames for the current parser. +A frame is of the form: + ( .. .what ? .. ) +" + (error "Parser has not implemented frame values") + ) + + +(provide 'semantic/debug) + +;;; semantic-debug.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/doc.el Sat Aug 29 19:45:47 2009 +0000 @@ -0,0 +1,128 @@ +;;; doc.el --- Routines for documentation strings + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2005, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; It is good practice to write documenation for your functions and +;; variables. These core routines deal with these documentation +;; comments or strings. They can exist either as a tag property +;; (:documentation) or as a comment just before the symbol, or after +;; the symbol on the same line. + +(require 'semantic/tag) + +;;; Code: + +(define-overloadable-function semantic-documentation-for-tag (&optional tag nosnarf) + "Find documentation from TAG and return it as a clean string. +TAG might have DOCUMENTATION set in it already. If not, there may be +some documentation in a comment preceding TAG's definition which we +can look for. When appropriate, this can be overridden by a language specific +enhancement. +Optional argument NOSNARF means to only return the lexical analyzer token for it. +If nosnarf if 'lex, then only return the lex token." + (if (not tag) (setq tag (semantic-current-tag))) + (save-excursion + (when (semantic-tag-with-position-p tag) + (set-buffer (semantic-tag-buffer tag))) + (:override + ;; No override. Try something simple to find documentation nearby + (save-excursion + (semantic-go-to-tag tag) + (let ((doctmp (semantic-tag-docstring tag (current-buffer)))) + (or + ;; Is there doc in the tag??? + doctmp + ;; Check just before the definition. + (when (semantic-tag-with-position-p tag) + (semantic-documentation-comment-preceeding-tag tag nosnarf)) + ;; Lets look for comments either after the definition, but before code: + ;; Not sure yet. Fill in something clever later.... + nil)))))) + +(defun semantic-documentation-comment-preceeding-tag (&optional tag nosnarf) + "Find a comment preceeding TAG. +If TAG is nil. use the tag under point. +Searches the space between TAG and the preceeding tag for a comment, +and converts the comment into clean documentation. +Optional argument NOSNARF with a value of 'lex means to return +just the lexical token and not the string." + (if (not tag) (setq tag (semantic-current-tag))) + (save-excursion + ;; Find this tag. + (semantic-go-to-tag tag) + (let* ((starttag (semantic-find-tag-by-overlay-prev + (semantic-tag-start tag))) + (start (if starttag + (semantic-tag-end starttag) + (point-min)))) + (when (re-search-backward comment-start-skip start t) + ;; We found a comment that doesn't belong to the body + ;; of a function. + (semantic-doc-snarf-comment-for-tag nosnarf))) + )) + +(make-obsolete-overload 'semantic-find-documentation + 'semantic-documentation-for-tag) + +(defun semantic-doc-snarf-comment-for-tag (nosnarf) + "Snarf up the comment at POINT for `semantic-documentation-for-tag'. +Attempt to strip out comment syntactic sugar. +Argument NOSNARF means don't modify the found text. +If NOSNARF is 'lex, then return the lex token." + (let* ((semantic-ignore-comments nil) + (semantic-lex-analyzer #'semantic-comment-lexer)) + (if (memq nosnarf '(lex flex)) ;; keep `flex' for compatibility + (car (semantic-lex (point) (1+ (point)))) + (let ((ct (semantic-lex-token-text + (car (semantic-lex (point) (1+ (point))))))) + (if nosnarf + nil + ;; ok, try to clean the text up. + ;; Comment start thingy + (while (string-match (concat "^\\s-*" comment-start-skip) ct) + (setq ct (concat (substring ct 0 (match-beginning 0)) + (substring ct (match-end 0))))) + ;; Arbitrary punctuation at the beginning of each line. + (while (string-match "^\\s-*\\s.+\\s-*" ct) + (setq ct (concat (substring ct 0 (match-beginning 0)) + (substring ct (match-end 0))))) + ;; End of a block comment. + (if (and (boundp 'block-comment-end) + block-comment-end + (string-match block-comment-end ct)) + (setq ct (concat (substring ct 0 (match-beginning 0)) + (substring ct (match-end 0))))) + ;; In case it's a real string, STRIPIT. + (while (string-match "\\s-*\\s\"+\\s-*" ct) + (setq ct (concat (substring ct 0 (match-beginning 0)) + (substring ct (match-end 0)))))) + ;; Now return the text. + ct)))) + +(semantic-alias-obsolete 'semantic-find-documentation + 'semantic-documentation-for-tag) + +(provide 'semantic/doc) + +;;; semantic-doc.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/tag-write.el Sat Aug 29 19:45:47 2009 +0000 @@ -0,0 +1,186 @@ +;;; tag-write.el --- Write tags to a text stream + +;; Copyright (C) 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: +;; +;; Routine for writing out a list of tags to a text stream. +;; +;; These routines will be used by semanticdb to output a tag list into +;; a text stream to be saved to a file. Ideally, you could use tag streams +;; to share tags between processes as well. +;; +;; As a bonus, these routines will also validate the tag structure, and make sure +;; that they conform to good semantic tag hygene. +;; + +(require 'semantic/tag) + +;;; Code: +(defun semantic-tag-write-one-tag (tag &optional indent) + "Write a single tag TAG to standard out. +INDENT is the amount of indentation to use for this tag." + (when (not (semantic-tag-p tag)) + (signal 'wrong-type-argument (list tag 'semantic-tag-p))) + (when (not indent) (setq indent 0)) + ;(princ (make-string indent ? )) + (princ "(\"") + ;; Base parts + (let ((name (semantic-tag-name tag)) + (class (semantic-tag-class tag))) + (princ name) + (princ "\" ") + (princ (symbol-name class)) + ) + (let ((attr (semantic-tag-attributes tag)) + ) + ;; Attributes + (cond ((not attr) + (princ " nil")) + + ((= (length attr) 2) ;; One item + (princ " (") + (semantic-tag-write-one-attribute attr indent) + (princ ")") + ) + (t + ;; More than one tag. + (princ "\n") + (princ (make-string (+ indent 3) ? )) + (princ "(") + (while attr + (semantic-tag-write-one-attribute attr (+ indent 4)) + (setq attr (cdr (cdr attr))) + (when attr + (princ "\n") + (princ (make-string (+ indent 4) ? ))) + ) + (princ ")\n") + (princ (make-string (+ indent 3) ? )) + )) + ;; Properties - for now, always nil. + (let ((rs (semantic--tag-get-property tag 'reparse-symbol))) + (if (not rs) + (princ " nil") + ;; Else, put in the property list. + (princ " (reparse-symbol ") + (princ (symbol-name rs)) + (princ ")")) + )) + ;; Overlay + (if (semantic-tag-with-position-p tag) + (let ((bounds (semantic-tag-bounds tag))) + (princ " ") + (prin1 (apply 'vector bounds)) + ) + (princ " nil")) + ;; End it. + (princ ")") + ) + +(defun semantic-tag-write-tag-list (tlist &optional indent dontaddnewline) + "Write the tag list TLIST to the current stream. +INDENT indicates the current indentation level. +If optional DONTADDNEWLINE is non-nil, then don't add a newline." + (if (not indent) + (setq indent 0) + (unless dontaddnewline + ;; Assume cursor at end of current line. Add a CR, and make the list. + (princ "\n") + (princ (make-string indent ? )))) + (princ "( ") + (while tlist + (if (semantic-tag-p (car tlist)) + (semantic-tag-write-one-tag (car tlist) (+ indent 2)) + ;; If we don't have a tag in the tag list, use the below hack, and hope + ;; it doesn't contain anything bad. If we find something bad, go back here + ;; and start extending what's expected here. + (princ (format "%S" (car tlist)))) + (setq tlist (cdr tlist)) + (when tlist + (princ "\n") + (princ (make-string (+ indent 2) ? ))) + ) + (princ ")") + (princ (make-string indent ? )) + ) + + +;; Writing out random stuff. +(defun semantic-tag-write-one-attribute (attrs indent) + "Write out one attribute from the head of the list of attributes ATTRS. +INDENT is the current amount of indentation." + (when (not attrs) (signal 'wrong-type-argument (list 'listp attrs))) + (when (not (symbolp (car attrs))) (error "Bad Attribute List in tag")) + + (princ (symbol-name (car attrs))) + (princ " ") + (semantic-tag-write-one-value (car (cdr attrs)) indent) + ) + +(defun semantic-tag-write-one-value (value indent) + "Write out a VALUE for something in a tag. +INDENT is the current tag indentation. +Items that are long lists of tags may need their own line." + (cond + ;; Another tag. + ((semantic-tag-p value) + (semantic-tag-write-one-tag value (+ indent 2))) + ;; A list of more tags + ((and (listp value) (semantic-tag-p (car value))) + (semantic-tag-write-tag-list value (+ indent 2)) + ) + ;; Some arbitrary data. + (t + (let ((str (format "%S" value))) + ;; Protect against odd data types in tags. + (if (= (aref str 0) ?#) + (progn + (princ "nil") + (message "Warning: Value %s not writable in tag." str)) + (princ str))))) + ) +;;; EIEIO USAGE +(defun semantic-tag-write-list-slot-value (value) + "Write out the VALUE of a slot for EIEIO. +The VALUE is a list of tags." + (if (not value) + (princ "nil") + (princ "\n '") + (semantic-tag-write-tag-list value 10 t) + )) + +;;; TESTING. + +(defun semantic-tag-write-test () + "Test the semantic tag writer against the tag under point." + (interactive) + (with-output-to-temp-buffer "*Tag Write Test*" + (semantic-tag-write-one-tag (semantic-current-tag)))) + +(defun semantic-tag-write-list-test () + "Test the semantic tag writer against the tag under point." + (interactive) + (with-output-to-temp-buffer "*Tag Write Test*" + (semantic-tag-write-tag-list (semantic-fetch-tags)))) + + +(provide 'semantic/tag-write) +;;; semantic-tag-write.el ends here