--- /dev/null
+;;; 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
+;;; 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
+;;; 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
+;;; 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
+;;; 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
+;;; 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
+;;; 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
projects / emacs.git / commitdiff