mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-12-14 09:39:42 +00:00
Code Issues Releases Activity

cedet/semantic/analyze.el, cedet/semantic/complete.el,

Browse Source 
cedet/semantic/edit.el, cedet/semantic/html.el,
cedet/semantic/idle.el, cedet/semantic/texi.el: New files.
cedet/semantic/lex.el: Move defsubsts to front of file to avoid
compiler error.
This commit is contained in:
Chong Yidong 2009-08-29 19:00:35 +00:00
parent a175a831d3
commit 9573e58b23
7 changed files with 5794 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

769
lisp/cedet/semantic/analyze.el Normal file
View File

@ -0,0 +1,769 @@
;;; analyze.el --- Analyze semantic tags against local context
;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 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:
;;
;; Semantic, as a tool, provides a nice list of searchable tags.
;; That information can provide some very accurate answers if the current
;; context of a position is known.
;;
;; Semantic-ctxt provides ways of analyzing, and manipulating the
;; semantic context of a language in code.
;;
;; This library provides routines for finding intelligent answers to
;; tough problems, such as if an argument to a function has the correct
;; return type, or all possible tags that fit in a given local context.
;;
;;; Vocabulary:
;;
;; Here are some words used to describe different things in the analyzer:
;;
;; tag - A single entity
;; prefix - The beginning of a symbol, usually used to look up something
;; incomplete.
;; type - The name of a datatype in the langauge.
;; metatype - If a type is named in a declaration like:
;; struct moose somevariable;
;; that name "moose" can be turned into a concrete type.
;; tag sequence - In C code, a list of dereferences, such as:
;; this.that.theother();
;; parent - For a datatype in an OO language, another datatype
;; inherited from. This excludes interfaces.
;; scope - A list of tags that can be dereferenced that cannot
;; be found from the global namespace.
;; scopetypes - A list of tags which are datatype that contain
;; the scope. The scopetypes need to have the scope extracted
;; in a way that honors the type of inheritance.
;; nest/nested - When one tag is contained entirely in another.
;;
;; context - A semantic datatype representing a point in a buffer.
;;
;; constriant - If a context specifies a specific datatype is needed,
;; that is a constraint.
;; constants - Some datatypes define elements of themselves as a
;; constant. These need to be returned as there would be no
;; other possible completions.
;;
(require 'eieio)
;; (require 'inversion)
;; (eval-and-compile
;; (inversion-require 'eieio "1.0"))
(require 'semantic)
(require 'semantic/format)
(require 'semantic/ctxt)
(require 'semantic/sort)
(eval-when-compile (require 'semantic/db)
(require 'semantic/db-find))
(require 'semantic/scope)
(require 'semantic/analyze/fcn)
;;; Code:
(defvar semantic-analyze-error-stack nil
"Collection of any errors thrown during analysis.")
(defun semantic-analyze-push-error (err)
"Push the error in ERR-DATA onto the error stack.
Argument ERR"
(push err semantic-analyze-error-stack))
;;; Analysis Classes
;;
;; These classes represent what a context is. Different types
;; of contexts provide differing amounts of information to help
;; provide completions.
;;
(defclass semantic-analyze-context ()
((bounds :initarg :bounds
:type list
:documentation "The bounds of this context.
Usually bound to the dimension of a single symbol or command.")
(prefix :initarg :prefix
:type list
:documentation "List of tags defining local text.
This can be nil, or a list where the last element can be a string
representing text that may be incomplete. Preceeding elements
must be semantic tags representing variables or functions
called in a dereference sequence.")
(prefixclass :initarg :prefixclass
:type list
:documentation "Tag classes expected at this context.
These are clases for tags, such as 'function, or 'variable.")
(prefixtypes :initarg :prefixtypes
:type list
:documentation "List of tags defining types for :prefix.
This list is one shorter than :prefix. Each element is a semantic
tag representing a type matching the semantic tag in the same
position in PREFIX.")
(scope :initarg :scope
:type (or null semantic-scope-cache)
:documentation "List of tags available in scopetype.
See `semantic-analyze-scoped-tags' for details.")
(buffer :initarg :buffer
:type buffer
:documentation "The buffer this context is derived from.")
(errors :initarg :errors
:documentation "Any errors thrown an caught during analysis.")
)
"Base analysis data for a any context.")
(defclass semantic-analyze-context-assignment (semantic-analyze-context)
((assignee :initarg :assignee
:type list
:documentation "A sequence of tags for an assignee.
This is a variable into which some value is being placed. The last
item in the list is the variable accepting the value. Earlier
tags represent the variables being derefernece to get to the
assignee."))
"Analysis class for a value in an assignment.")
(defclass semantic-analyze-context-functionarg (semantic-analyze-context)
((function :initarg :function
:type list
:documentation "A sequence of tags for a function.
This is a function being called. The cursor will be in the position
of an argument.
The last tag in :function is the function being called. Earlier
tags represent the variables being dereferenced to get to the
function.")
(index :initarg :index
:type integer
:documentation "The index of the argument for this context.
If a function takes 4 arguments, this value should be bound to
the values 1 through 4.")
(argument :initarg :argument
:type list
:documentation "A sequence of tags for the :index argument.
The argument can accept a value of some type, and this contains the
tag for that definition. It should be a tag, but might
be just a string in some circumstances.")
)
"Analysis class for a value as a function argument.")
(defclass semantic-analyze-context-return (semantic-analyze-context)
() ; No extra data.
"Analysis class for return data.
Return data methods identify the requred type by the return value
of the parent function.")
;;; METHODS
;;
;; Simple methods against the context classes.
;;
(defmethod semantic-analyze-type-constraint
((context semantic-analyze-context) &optional desired-type)
"Return a type constraint for completing :prefix in CONTEXT.
Optional argument DESIRED-TYPE may be a non-type tag to analyze."
(when (semantic-tag-p desired-type)
;; Convert the desired type if needed.
(if (not (eq (semantic-tag-class desired-type) 'type))
(setq desired-type (semantic-tag-type desired-type)))
;; Protect against plain strings
(cond ((stringp desired-type)
(setq desired-type (list desired-type 'type)))
((and (stringp (car desired-type))
(not (semantic-tag-p desired-type)))
(setq desired-type (list (car desired-type) 'type)))
((semantic-tag-p desired-type)
;; We have a tag of some sort. Yay!
nil)
(t (setq desired-type nil))
)
desired-type))
(defmethod semantic-analyze-type-constraint
((context semantic-analyze-context-functionarg))
"Return a type constraint for completing :prefix in CONTEXT."
(call-next-method context (car (oref context argument))))
(defmethod semantic-analyze-type-constraint
((context semantic-analyze-context-assignment))
"Return a type constraint for completing :prefix in CONTEXT."
(call-next-method context (car (reverse (oref context assignee)))))
(defmethod semantic-analyze-interesting-tag
((context semantic-analyze-context))
"Return a tag from CONTEXT that would be most interesting to a user."
(let ((prefix (reverse (oref context :prefix))))
;; Go back through the prefix until we find a tag we can return.
(while (and prefix (not (semantic-tag-p (car prefix))))
(setq prefix (cdr prefix)))
;; Return the found tag, or nil.
(car prefix)))
(defmethod semantic-analyze-interesting-tag
((context semantic-analyze-context-functionarg))
"Try the base, and if that fails, return what we are assigning into."
(or (call-next-method) (car-safe (oref context :function))))
(defmethod semantic-analyze-interesting-tag
((context semantic-analyze-context-assignment))
"Try the base, and if that fails, return what we are assigning into."
(or (call-next-method) (car-safe (oref context :assignee))))
;;; ANALYSIS
;;
;; Start out with routines that will calculate useful parts of
;; the general analyzer function. These could be used directly
;; by an application that doesn't need to calculate the full
;; context.
(define-overloadable-function semantic-analyze-find-tag-sequence (sequence &optional
scope typereturn throwsym)
"Attempt to find all tags in SEQUENCE.
Optional argument LOCALVAR is the list of local variables to use when
finding the details on the first element of SEQUENCE in case
it is not found in the global set of tables.
Optional argument SCOPE are additional terminals to search which are currently
scoped. These are not local variables, but symbols available in a structure
which doesn't need to be dereferneced.
Optional argument TYPERETURN is a symbol in which the types of all found
will be stored. If nil, that data is thrown away.
Optional argument THROWSYM specifies a symbol the throw on non-recoverable error.")
(defun semantic-analyze-find-tag-sequence-default (sequence &optional
scope typereturn
throwsym)
"Attempt to find all tags in SEQUENCE.
SCOPE are extra tags which are in scope.
TYPERETURN is a symbol in which to place a list of tag classes that
are found in SEQUENCE.
Optional argument THROWSYM specifies a symbol the throw on non-recoverable error."
(let ((s sequence) ; copy of the sequence
(tmp nil) ; tmp find variable
(tag nil) ; tag return list
(tagtype nil) ; tag types return list
(fname nil)
(miniscope (clone scope))
)
;; First order check. Is this wholely contained in the typecache?
(setq tmp (semanticdb-typecache-find sequence))
(if tmp
(progn
;; We are effectively done...
(setq s nil)
(setq tag (list tmp)))
;; For the first entry, it better be a variable, but it might
;; be in the local context too.
;; NOTE: Don't forget c++ namespace foo::bar.
(setq tmp (or
;; Is this tag within our scope. Scopes can sometimes
;; shadow other things, so it goes first.
(and scope (semantic-scope-find (car s) nil scope))
;; Find the tag out there... somewhere, but not in scope
(semantic-analyze-find-tag (car s))
))
(if (and (listp tmp) (semantic-tag-p (car tmp)))
(setq tmp (semantic-analyze-select-best-tag tmp)))
(if (not (semantic-tag-p tmp))
(if throwsym
(throw throwsym "Cannot find definition")
(error "Cannot find definition for \"%s\"" (car s))))
(setq s (cdr s))
(setq tag (cons tmp tag)) ; tag is nil here...
(setq fname (semantic-tag-file-name tmp))
)
;; For the middle entries
(while s
;; Using the tag found in TMP, lets find the tag
;; representing the full typeographic information of its
;; type, and use that to determine the search context for
;; (car s)
(let* ((tmptype
;; In some cases the found TMP is a type,
;; and we can use it directly.
(cond ((semantic-tag-of-class-p tmp 'type)
;; update the miniscope when we need to analyze types directly.
(let ((rawscope
(apply 'append
(mapcar 'semantic-tag-type-members
tagtype))))
(oset miniscope fullscope rawscope))
;; Now analayze the type to remove metatypes.
(or (semantic-analyze-type tmp miniscope)
tmp))
(t
(semantic-analyze-tag-type tmp scope))))
(typefile
(when tmptype
(semantic-tag-file-name tmptype)))
(slots nil))
;; Get the children
(setq slots (semantic-analyze-scoped-type-parts tmptype scope))
;; find (car s) in the list o slots
(setq tmp (semantic-find-tags-by-name (car s) slots))
;; If we have lots
(if (and (listp tmp) (semantic-tag-p (car tmp)))
(setq tmp (semantic-analyze-select-best-tag tmp)))
;; Make sure we have a tag.
(if (not (semantic-tag-p tmp))
(if (cdr s)
;; In the middle, we need to keep seeking our types out.
(error "Cannot find definition for \"%s\"" (car s))
;; Else, it's ok to end with a non-tag
(setq tmp (car s))))
(setq fname (or typefile fname))
(when (and fname (semantic-tag-p tmp)
(not (semantic-tag-in-buffer-p tmp)))
(semantic--tag-put-property tmp :filename fname))
(setq tag (cons tmp tag))
(setq tagtype (cons tmptype tagtype))
)
(setq s (cdr s)))
(if typereturn (set typereturn (nreverse tagtype)))
;; Return the mess
(nreverse tag)))
(defun semantic-analyze-find-tag (name &optional tagclass scope)
"Return the first tag found with NAME or nil if not found.
Optional argument TAGCLASS specifies the class of tag to return, such
as 'function or 'variable.
Optional argument SCOPE specifies a scope object which has
additional tags which are in SCOPE and do not need prefixing to
find.
This is a wrapper on top of semanticdb, semanticdb-typecache,
semantic-scope, and semantic search functions. Almost all
searches use the same arguments."
(let ((namelst (if (consp name) name ;; test if pre-split.
(semantic-analyze-split-name name))))
(cond
;; If the splitter gives us a list, use the sequence finder
;; to get the list. Since this routine is expected to return
;; only one tag, return the LAST tag found from the sequence
;; which is supposedly the nested reference.
;;
;; Of note, the SEQUENCE function below calls this function
;; (recursively now) so the names that we get from the above
;; fcn better not, in turn, be splittable.
((listp namelst)
;; If we had a split, then this is likely a c++ style namespace::name sequence,
;; so take a short-cut through the typecache.
(or (semanticdb-typecache-find namelst)
;; Ok, not there, try the usual...
(let ((seq (semantic-analyze-find-tag-sequence
namelst scope nil)))
(semantic-analyze-select-best-tag seq tagclass)
)))
;; If NAME is solo, then do our searches for it here.
((stringp namelst)
(let ((retlist (and scope (semantic-scope-find name tagclass scope))))
(if retlist
(semantic-analyze-select-best-tag
retlist tagclass)
(if (eq tagclass 'type)
(semanticdb-typecache-find name)
;; Search in the typecache. First entries in a sequence are
;; often there.
(setq retlist (semanticdb-typecache-find name))
(if retlist
retlist
(semantic-analyze-select-best-tag
(semanticdb-strip-find-results
(semanticdb-find-tags-by-name name)
'name)
tagclass)
)))))
)))
;;; SHORT ANALYSIS
;;
;; Create a mini-analysis of just the symbol under point.
;;
(define-overloadable-function semantic-analyze-current-symbol
(analyzehookfcn &optional position)
"Call ANALYZEHOOKFCN after analyzing the symbol under POSITION.
The ANALYZEHOOKFCN is called with the current symbol bounds, and the
analyzed prefix. It should take the arguments (START END PREFIX).
The ANALYZEHOOKFCN is only called if some sort of prefix with bounds was
found under POSITION.
The results of ANALYZEHOOKFCN is returned, or nil if there was nothing to
call it with.
For regular analysis, you should call `semantic-analyze-current-context'
to calculate the context information. The purpose for this function is
to provide a large number of non-cached analysis for filtering symbols."
;; Only do this in a Semantic enabled buffer.
(when (not (semantic-active-p))
(error "Cannot analyze buffers not supported by Semantic."))
;; Always refresh out tags in a safe way before doing the
;; context.
(semantic-refresh-tags-safe)
;; Do the rest of the analysis.
(save-match-data
(save-excursion
(:override)))
)
(defun semantic-analyze-current-symbol-default (analyzehookfcn position)
"Call ANALYZEHOOKFCN on the analyzed symbol at POSITION."
(let* ((semantic-analyze-error-stack nil)
(LLstart (current-time))
(prefixandbounds (semantic-ctxt-current-symbol-and-bounds (or position (point))))
(prefix (car prefixandbounds))
(bounds (nth 2 prefixandbounds))
(scope (semantic-calculate-scope position))
(end nil)
)
;; Only do work if we have bounds (meaning a prefix to complete)
(when bounds
(if debug-on-error
(catch 'unfindable
;; If debug on error is on, allow debugging in this fcn.
(setq prefix (semantic-analyze-find-tag-sequence
prefix scope 'prefixtypes 'unfindable)))
;; Debug on error is off. Capture errors and move on
(condition-case err
;; NOTE: This line is duplicated in
;; semantic-analyzer-debug-global-symbol
;; You will need to update both places.
(setq prefix (semantic-analyze-find-tag-sequence
prefix scope 'prefixtypes))
(error (semantic-analyze-push-error err))))
(setq end (current-time))
;;(message "Analysis took %.2f sec" (semantic-elapsed-time LLstart end))
)
(when prefix
(prog1
(funcall analyzehookfcn (car bounds) (cdr bounds) prefix)
;;(setq end (current-time))
;;(message "hookfcn took %.5f sec" (semantic-elapsed-time LLstart end))
)
)))
;;; MAIN ANALYSIS
;;
;; Create a full-up context analysis.
;;
(define-overloadable-function semantic-analyze-current-context (&optional position)
"Analyze the current context at optional POSITION.
If called interactively, display interesting information about POSITION
in a separate buffer.
Returns an object based on symbol `semantic-analyze-context'.
This function can be overriden with the symbol `analyze-context'.
When overriding this function, your override will be called while
cursor is at POSITION. In addition, your function will not be called
if a cached copy of the return object is found."
(interactive "d")
;; Only do this in a Semantic enabled buffer.
(when (not (semantic-active-p))
(error "Cannot analyze buffers not supported by Semantic."))
;; Always refresh out tags in a safe way before doing the
;; context.
(semantic-refresh-tags-safe)
;; Do the rest of the analysis.
(if (not position) (setq position (point)))
(save-excursion
(goto-char position)
(let* ((answer (semantic-get-cache-data 'current-context)))
(with-syntax-table semantic-lex-syntax-table
(when (not answer)
(setq answer (:override))
(when (and answer (oref answer bounds))
(with-slots (bounds) answer
(semantic-cache-data-to-buffer (current-buffer)
(car bounds)
(cdr bounds)
answer
'current-context
'exit-cache-zone)))
;; Check for interactivity
(when (interactive-p)
(if answer
(semantic-analyze-pop-to-context answer)
(message "No Context."))
))
answer))))
(defun semantic-analyze-current-context-default (position)
"Analyze the current context at POSITION.
Returns an object based on symbol `semantic-analyze-context'."
(let* ((semantic-analyze-error-stack nil)
(context-return nil)
(prefixandbounds (semantic-ctxt-current-symbol-and-bounds (or position (point))))
(prefix (car prefixandbounds))
(bounds (nth 2 prefixandbounds))
;; @todo - vv too early to really know this answer! vv
(prefixclass (semantic-ctxt-current-class-list))
(prefixtypes nil)
(scope (semantic-calculate-scope position))
(function nil)
(fntag nil)
arg fntagend argtag
assign asstag
)
;; Pattern for Analysis:
;;
;; Step 1: Calculate DataTypes in Scope:
;;
;; a) Calculate the scope (above)
;;
;; Step 2: Parse context
;;
;; a) Identify function being called, or variable assignment,
;; and find source tags for those references
;; b) Identify the prefix (text cursor is on) and find the source
;; tags for those references.
;;
;; Step 3: Assemble an object
;;
;; Step 2 a:
(setq function (semantic-ctxt-current-function))
(when function
;; Calculate the argument for the function if there is one.
(setq arg (semantic-ctxt-current-argument))
;; Find a tag related to the function name.
(condition-case err
(setq fntag
(semantic-analyze-find-tag-sequence function scope))
(error (semantic-analyze-push-error err)))
;; fntag can have the last entry as just a string, meaning we
;; could not find the core datatype. In this case, the searches
;; below will not work.
(when (stringp (car (last fntag)))
;; Take a wild guess!
(setcar (last fntag) (semantic-tag (car (last fntag)) 'function))
)
(when fntag
(let ((fcn (semantic-find-tags-by-class 'function fntag)))
(when (not fcn)
(let ((ty (semantic-find-tags-by-class 'type fntag)))
(when ty
;; We might have a constructor with the same name as
;; the found datatype.
(setq fcn (semantic-find-tags-by-name
(semantic-tag-name (car ty))
(semantic-tag-type-members (car ty))))
(if fcn
(let ((lp fcn))
(while lp
(when (semantic-tag-get-attribute (car lp)
:constructor)
(setq fcn (cons (car lp) fcn)))
(setq lp (cdr lp))))
;; Give up, go old school
(setq fcn fntag))
)))
(setq fntagend (car (reverse fcn))
argtag
(when (semantic-tag-p fntagend)
(nth (1- arg) (semantic-tag-function-arguments fntagend)))
fntag fcn))))
;; Step 2 b:
;; Only do work if we have bounds (meaning a prefix to complete)
(when bounds
(if debug-on-error
(catch 'unfindable
;; If debug on error is on, allow debugging in this fcn.
(setq prefix (semantic-analyze-find-tag-sequence
prefix scope 'prefixtypes 'unfindable)))
;; Debug on error is off. Capture errors and move on
(condition-case err
;; NOTE: This line is duplicated in
;; semantic-analyzer-debug-global-symbol
;; You will need to update both places.
(setq prefix (semantic-analyze-find-tag-sequence
prefix scope 'prefixtypes))
(error (semantic-analyze-push-error err))))
)
;; Step 3:
(cond
(fntag
;; If we found a tag for our function, we can go into
;; functional context analysis mode, meaning we have a type
;; for the argument.
(setq context-return
(semantic-analyze-context-functionarg
"functionargument"
:buffer (current-buffer)
:function fntag
:index arg
:argument (list argtag)
:scope scope
:prefix prefix
:prefixclass prefixclass
:bounds bounds
:prefixtypes prefixtypes
:errors semantic-analyze-error-stack)))
;; No function, try assignment
((and (setq assign (semantic-ctxt-current-assignment))
;; We have some sort of an assignment
(condition-case err
(setq asstag (semantic-analyze-find-tag-sequence
assign scope))
(error (semantic-analyze-push-error err)
nil)))
(setq context-return
(semantic-analyze-context-assignment
"assignment"
:buffer (current-buffer)
:assignee asstag
:scope scope
:bounds bounds
:prefix prefix
:prefixclass prefixclass
:prefixtypes prefixtypes
:errors semantic-analyze-error-stack)))
;; TODO: Identify return value condition.
;;((setq return .... what to do?)
;; ...)
(bounds
;; Nothing in particular
(setq context-return
(semantic-analyze-context
"context"
:buffer (current-buffer)
:scope scope
:bounds bounds
:prefix prefix
:prefixclass prefixclass
:prefixtypes prefixtypes
:errors semantic-analyze-error-stack)))
(t (setq context-return nil))
)
;; Return our context.
context-return))
;;; DEBUG OUTPUT
;;
;; Friendly output of a context analysis.
;;
(defmethod semantic-analyze-pulse ((context semantic-analyze-context))
"Pulse the region that CONTEXT affects."
(save-excursion
(set-buffer (oref context :buffer))
(let ((bounds (oref context :bounds)))
(when bounds
(pulse-momentary-highlight-region (car bounds) (cdr bounds))))))
(defcustom semantic-analyze-summary-function 'semantic-format-tag-prototype
"*Function to use when creating items in Imenu.
Some useful functions are found in `semantic-format-tag-functions'."
:group 'semantic
:type semantic-format-tag-custom-list)
(defun semantic-analyze-princ-sequence (sequence &optional prefix buff)
"Send the tag SEQUENCE to standard out.
Use PREFIX as a label.
Use BUFF as a source of override methods."
(while sequence
(princ prefix)
(cond
((semantic-tag-p (car sequence))
(princ (funcall semantic-analyze-summary-function
(car sequence))))
((stringp (car sequence))
(princ "\"")
(princ (semantic--format-colorize-text (car sequence) 'variable))
(princ "\""))
(t
(princ (format "'%S" (car sequence)))))
(princ "\n")
(setq sequence (cdr sequence))
(setq prefix (make-string (length prefix) ? ))
))
(defmethod semantic-analyze-show ((context semantic-analyze-context))
"Insert CONTEXT into the current buffer in a nice way."
(semantic-analyze-princ-sequence (oref context prefix) "Prefix: " )
(semantic-analyze-princ-sequence (oref context prefixclass) "Prefix Classes: ")
(semantic-analyze-princ-sequence (oref context prefixtypes) "Prefix Types: ")
(semantic-analyze-princ-sequence (oref context errors) "Encountered Errors: ")
(princ "--------\n")
;(semantic-analyze-princ-sequence (oref context scopetypes) "Scope Types: ")
;(semantic-analyze-princ-sequence (oref context scope) "Scope: ")
;(semantic-analyze-princ-sequence (oref context localvariables) "LocalVars: ")
(when (oref context scope)
(semantic-analyze-show (oref context scope)))
)
(defmethod semantic-analyze-show ((context semantic-analyze-context-assignment))
"Insert CONTEXT into the current buffer in a nice way."
(semantic-analyze-princ-sequence (oref context assignee) "Assignee: ")
(call-next-method))
(defmethod semantic-analyze-show ((context semantic-analyze-context-functionarg))
"Insert CONTEXT into the current buffer in a nice way."
(semantic-analyze-princ-sequence (oref context function) "Function: ")
(princ "Argument Index: ")
(princ (oref context index))
(princ "\n")
(semantic-analyze-princ-sequence (oref context argument) "Argument: ")
(call-next-method))
(defun semantic-analyze-pop-to-context (context)
"Display CONTEXT in a temporary buffer.
CONTEXT's content is described in `semantic-analyze-current-context'."
(semantic-analyze-pulse context)
(with-output-to-temp-buffer "*Semantic Context Analysis*"
(princ "Context Type: ")
(princ (object-name context))
(princ "\n")
(princ "Bounds: ")
(princ (oref context bounds))
(princ "\n")
(semantic-analyze-show context)
)
(shrink-window-if-larger-than-buffer
(get-buffer-window "*Semantic Context Analysis*"))
)
(provide 'semantic/analyze)
;;; semantic-analyze.el ends here

2128
lisp/cedet/semantic/complete.el Normal file
View File

File diff suppressed because it is too large Load Diff

965
lisp/cedet/semantic/edit.el Normal file
View File

@ -0,0 +1,965 @@
;;; semantic-edit.el --- Edit Management for Semantic
;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
;;; 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:
;;
;; In Semantic 1.x, changes were handled in a simplistic manner, where
;; tags that changed were reparsed one at a time. Any other form of
;; edit were managed through a full reparse.
;;
;; This code attempts to minimize the number of times a full reparse
;; needs to occur. While overlays and tags will continue to be
;; recycled in the simple case, new cases where tags are inserted
;; or old tags removed from the original list are handled.
;;
;;; NOTES FOR IMPROVEMENT
;;
;; Work done by the incremental parser could be improved by the
;; following:
;;
;; 1. Tags created could have as a property an overlay marking a region
;; of themselves that can be edited w/out affecting the definition of
;; that tag.
;;
;; 2. Tags w/ positioned children could have a property of an
;; overlay marking the region in themselves that contain the
;; children. This could be used to better improve splicing near
;; the beginning and end of the child lists.
;;
;;; BUGS IN INCREMENTAL PARSER
;;
;; 1. Changes in the whitespace between tags could extend a
;; following tag. These will be marked as merely unmatched
;; syntax instead.
;;
;; 2. Incremental parsing while a new function is being typed in
;; somtimes gets a chance only when lists are incomplete,
;; preventing correct context identification.
;;
(require 'semantic)
;; (require 'working)
;;; Code:
(defvar semantic-after-partial-cache-change-hook nil
"Hooks run after the buffer cache has been updated.
This hook will run when the cache has been partially reparsed.
Partial reparses are incurred when a user edits a buffer, and only the
modified sections are rescanned.
Hook functions must take one argument, which is the list of tags
updated in the current buffer.
For language specific hooks, make sure you define this as a local hook.")
(defvar semantic-change-hooks nil
"Hooks run when semantic detects a change in a buffer.
Each hook function must take three arguments, identical to the
common hook `after-change-functions'.")
(defvar semantic-reparse-needed-change-hook nil
"Hooks run when a user edit is detected as needing a reparse.
For language specific hooks, make sure you define this as a local
hook.
Not used yet; part of the next generation reparse mechanism")
(defvar semantic-no-reparse-needed-change-hook nil
"Hooks run when a user edit is detected as not needing a reparse.
If the hook returns non-nil, then declare that a reparse is needed.
For language specific hooks, make sure you define this as a local
hook.
Not used yet; part of the next generation reparse mechanism.")
(defvar semantic-edits-new-change-hooks nil
"Hooks run when a new change is found.
Functions must take one argument representing an overlay on that change.")
(defvar semantic-edits-delete-change-hooks nil
"Hooks run before a change overlay is deleted.
Deleted changes occur when multiple changes are merged.
Functions must take one argument representing an overlay being deleted.")
(defvar semantic-edits-move-change-hooks nil
"Hooks run after a change overlay is moved.
Changes move when a new change overlaps an old change. The old change
will be moved.
Functions must take one argument representing an overlay being moved.")
(defvar semantic-edits-reparse-change-hooks nil
"Hooks run after a change results in a reparse.
Functions are called before the overlay is deleted, and after the
incremental reparse.")
(defvar semantic-edits-incremental-reparse-failed-hooks nil
"Hooks run after the incremental parser fails.
When this happens, the buffer is marked as needing a full reprase.")
(defcustom semantic-edits-verbose-flag nil
"Non-nil means the incremental perser is verbose.
If nil, errors are still displayed, but informative messages are not."
:group 'semantic
:type 'boolean)
;;; Change State management
;;
;; Manage a series of overlays that define changes recently
;; made to the current buffer.
(defun semantic-change-function (start end length)
"Provide a mechanism for semantic tag management.
Argument START, END, and LENGTH specify the bounds of the change."
(setq semantic-unmatched-syntax-cache-check t)
(let ((inhibit-point-motion-hooks t)
)
(run-hook-with-args 'semantic-change-hooks start end length)
))
(defun semantic-changes-in-region (start end &optional buffer)
"Find change overlays which exist in whole or in part between START and END.
Optional argument BUFFER is the buffer to search for changes in."
(save-excursion
(if buffer (set-buffer buffer))
(let ((ol (semantic-overlays-in (max start (point-min))
(min end (point-max))))
(ret nil))
(while ol
(when (semantic-overlay-get (car ol) 'semantic-change)
(setq ret (cons (car ol) ret)))
(setq ol (cdr ol)))
(sort ret #'(lambda (a b) (< (semantic-overlay-start a)
(semantic-overlay-start b)))))))
(defun semantic-edits-change-function-handle-changes (start end length)
"Run whenever a buffer controlled by `semantic-mode' change.
Tracks when and how the buffer is re-parsed.
Argument START, END, and LENGTH specify the bounds of the change."
;; We move start/end by one so that we can merge changes that occur
;; just before, or just after. This lets simple typing capture everything
;; into one overlay.
(let ((changes-in-change (semantic-changes-in-region (1- start) (1+ end)))
)
(semantic-parse-tree-set-needs-update)
(if (not changes-in-change)
(let ((o (semantic-make-overlay start end)))
(semantic-overlay-put o 'semantic-change t)
;; Run the hooks safely. When hooks blow it, our dirty
;; function will be removed from the list of active change
;; functions.
(condition-case nil
(run-hook-with-args 'semantic-edits-new-change-hooks o)
(error nil)))
(let ((tmp changes-in-change))
;; Find greatest bounds of all changes
(while tmp
(when (< (semantic-overlay-start (car tmp)) start)
(setq start (semantic-overlay-start (car tmp))))
(when (> (semantic-overlay-end (car tmp)) end)
(setq end (semantic-overlay-end (car tmp))))
(setq tmp (cdr tmp)))
;; Move the first found overlay, recycling that overlay.
(semantic-overlay-move (car changes-in-change) start end)
(condition-case nil
(run-hook-with-args 'semantic-edits-move-change-hooks
(car changes-in-change))
(error nil))
(setq changes-in-change (cdr changes-in-change))
;; Delete other changes. They are now all bound here.
(while changes-in-change
(condition-case nil
(run-hook-with-args 'semantic-edits-delete-change-hooks
(car changes-in-change))
(error nil))
(semantic-overlay-delete (car changes-in-change))
(setq changes-in-change (cdr changes-in-change))))
)))
(defsubst semantic-edits-flush-change (change)
"Flush the CHANGE overlay."
(condition-case nil
(run-hook-with-args 'semantic-edits-delete-change-hooks
change)
(error nil))
(semantic-overlay-delete change))
(defun semantic-edits-flush-changes ()
"Flush the changes in the current buffer."
(let ((changes (semantic-changes-in-region (point-min) (point-max))))
(while changes
(semantic-edits-flush-change (car changes))
(setq changes (cdr changes))))
)
(defun semantic-edits-change-in-one-tag-p (change hits)
"Return non-nil of the overlay CHANGE exists solely in one leaf tag.
HITS is the list of tags that CHANGE is in. It can have more than
one tag in it if the leaf tag is within a parent tag."
(and (< (semantic-tag-start (car hits))
(semantic-overlay-start change))
(> (semantic-tag-end (car hits))
(semantic-overlay-end change))
;; Recurse on the rest. If this change is inside all
;; of these tags, then they are all leaves or parents
;; of the smallest tag.
(or (not (cdr hits))
(semantic-edits-change-in-one-tag-p change (cdr hits))))
)
;;; Change/Tag Query functions
;;
;; A change (region of space) can effect tags in different ways.
;; These functions perform queries on a buffer to determine different
;; ways that a change effects a buffer.
;;
;; NOTE: After debugging these, replace below to no longer look
;; at point and mark (via comments I assume.)
(defsubst semantic-edits-os (change)
"For testing: Start of CHANGE, or smaller of (point) and (mark)."
(if change (semantic-overlay-start change)
(if (< (point) (mark)) (point) (mark))))
(defsubst semantic-edits-oe (change)
"For testing: End of CHANGE, or larger of (point) and (mark)."
(if change (semantic-overlay-end change)
(if (> (point) (mark)) (point) (mark))))
(defun semantic-edits-change-leaf-tag (change)
"A leaf tag which completely encompasses CHANGE.
If change overlaps a tag, but is not encompassed in it, return nil.
Use `semantic-edits-change-overlap-leaf-tag'.
If CHANGE is completely encompassed in a tag, but overlaps sub-tags,
return nil."
(let* ((start (semantic-edits-os change))
(end (semantic-edits-oe change))
(tags (nreverse
(semantic-find-tag-by-overlay-in-region
start end))))
;; A leaf is always first in this list
(if (and tags
(<= (semantic-tag-start (car tags)) start)
(> (semantic-tag-end (car tags)) end))
;; Ok, we have a match. If this tag has children,
;; we have to do more tests.
(let ((chil (semantic-tag-components (car tags))))
(if (not chil)
;; Simple leaf.
(car tags)
;; For this type, we say that we encompass it if the
;; change occurs outside the range of the children.
(if (or (not (semantic-tag-with-position-p (car chil)))
(> start (semantic-tag-end (nth (1- (length chil)) chil)))
(< end (semantic-tag-start (car chil))))
;; We have modifications to the definition of this parent
;; so we have to reparse the whole thing.
(car tags)
;; We actually modified an area between some children.
;; This means we should return nil, as that case is
;; calculated by someone else.
nil)))
nil)))
(defun semantic-edits-change-between-tags (change)
"Return a cache list of tags surrounding CHANGE.
The returned list is the CONS cell in the master list pointing to
a tag just before CHANGE. The CDR will have the tag just after CHANGE.
CHANGE cannot encompass or overlap a leaf tag.
If CHANGE is fully encompassed in a tag that has children, and
this change occurs between those children, this returns non-nil.
See `semantic-edits-change-leaf-tag' for details on parents."
(let* ((start (semantic-edits-os change))
(end (semantic-edits-oe change))
(tags (nreverse
(semantic-find-tag-by-overlay-in-region
start end)))
(list-to-search nil)
(found nil))
(if (not tags)
(setq list-to-search semantic--buffer-cache)
;; A leaf is always first in this list
(if (and (< (semantic-tag-start (car tags)) start)
(> (semantic-tag-end (car tags)) end))
;; We are completely encompassed in a tag.
(if (setq list-to-search
(semantic-tag-components (car tags)))
;; Ok, we are completely encompassed within the first tag
;; entry, AND that tag has children. This means that change
;; occured outside of all children, but inside some tag
;; with children.
(if (or (not (semantic-tag-with-position-p (car list-to-search)))
(> start (semantic-tag-end
(nth (1- (length list-to-search))
list-to-search)))
(< end (semantic-tag-start (car list-to-search))))
;; We have modifications to the definition of this parent
;; and not between it's children. Clear the search list.
(setq list-to-search nil)))
;; Search list is nil.
))
;; If we have a search list, lets go. Otherwise nothing.
(while (and list-to-search (not found))
(if (cdr list-to-search)
;; We end when the start of the CDR is after the end of our
;; asked change.
(if (< (semantic-tag-start (cadr list-to-search)) end)
(setq list-to-search (cdr list-to-search))
(setq found t))
(setq list-to-search nil)))
;; Return it. If it is nil, there is a logic bug, and we need
;; to avoid this bit of logic anyway.
list-to-search
))
(defun semantic-edits-change-over-tags (change)
"Return a cache list of tags surrounding a CHANGE encompassing tags.
CHANGE must not only include all overlapped tags (excepting possible
parent tags) in their entirety. In this case, the change may be deleting
or moving whole tags.
The return value is a vector.
Cell 0 is a list of all tags completely encompassed in change.
Cell 1 is the cons cell into a master parser cache starting with
the cell which occurs BEFORE the first position of CHANGE.
Cell 2 is the parent of cell 1, or nil for the buffer cache.
This function returns nil if any tag covered by change is not
completely encompassed.
See `semantic-edits-change-leaf-tag' for details on parents."
(let* ((start (semantic-edits-os change))
(end (semantic-edits-oe change))
(tags (nreverse
(semantic-find-tag-by-overlay-in-region
start end)))
(parent nil)
(overlapped-tags nil)
inner-start inner-end
(list-to-search nil))
;; By the time this is already called, we know that it is
;; not a leaf change, nor a between tag change. That leaves
;; an overlap, and this condition.
;; A leaf is always first in this list.
;; Is the leaf encompassed in this change?
(if (and tags
(>= (semantic-tag-start (car tags)) start)
(<= (semantic-tag-end (car tags)) end))
(progn
;; We encompass one whole change.
(setq overlapped-tags (list (car tags))
inner-start (semantic-tag-start (car tags))
inner-end (semantic-tag-end (car tags))
tags (cdr tags))
;; Keep looping while tags are inside the change.
(while (and tags
(>= (semantic-tag-start (car tags)) start)
(<= (semantic-tag-end (car tags)) end))
;; Check if this new all-encompassing tag is a parent
;; of that which went before. Only check end because
;; we know that start is less than inner-start since
;; tags was sorted on that.
(if (> (semantic-tag-end (car tags)) inner-end)
;; This is a parent. Drop the children found
;; so far.
(setq overlapped-tags (list (car tags))
inner-start (semantic-tag-start (car tags))
inner-end (semantic-tag-end (car tags))
)
;; It is not a parent encompassing tag
(setq overlapped-tags (cons (car tags)
overlapped-tags)
inner-start (semantic-tag-start (car tags))))
(setq tags (cdr tags)))
(if (not tags)
;; There are no tags left, and all tags originally
;; found are encompassed by the change. Setup our list
;; from the cache
(setq list-to-search semantic--buffer-cache);; We have a tag ouside the list. Check for
;; We know we have a parent because it would
;; completely cover the change. A tag can only
;; do that if it is a parent after we get here.
(when (and tags
(< (semantic-tag-start (car tags)) start)
(> (semantic-tag-end (car tags)) end))
;; We have a parent. Stuff in the search list.
(setq parent (car tags)
list-to-search (semantic-tag-components parent))
;; If the first of TAGS is a parent (see above)
;; then clear out the list. All other tags in
;; here must therefore be parents of the car.
(setq tags nil)
;; One last check, If start is before the first
;; tag or after the last, we may have overlap into
;; the characters that make up the definition of
;; the tag we are parsing.
(when (or (semantic-tag-with-position-p (car list-to-search))
(< start (semantic-tag-start
(car list-to-search)))
(> end (semantic-tag-end
(nth (1- (length list-to-search))
list-to-search))))
;; We have a problem
(setq list-to-search nil
parent nil))))
(when list-to-search
;; Ok, return the vector only if all TAGS are
;; confirmed as the lineage of `overlapped-tags'
;; which must have a value by now.
;; Loop over the search list to find the preceeding CDR.
;; Fortunatly, (car overlapped-tags) happens to be
;; the first tag positionally.
(let ((tokstart (semantic-tag-start (car overlapped-tags))))
(while (and list-to-search
;; Assume always (car (cdr list-to-search)).
;; A thrown error will be captured nicely, but
;; that case shouldn't happen.
;; We end when the start of the CDR is after the
;; end of our asked change.
(cdr list-to-search)
(< (semantic-tag-start (car (cdr list-to-search)))
tokstart)
(setq list-to-search (cdr list-to-search)))))
;; Create the return vector
(vector overlapped-tags
list-to-search
parent)
))
nil)))
;;; Default Incremental Parser
;;
;; Logic about how to group changes for effective reparsing and splicing.
(defun semantic-parse-changes-failed (&rest args)
"Signal that Semantic failed to parse changes.
That is, display a message by passing all ARGS to `format', then throw
a 'semantic-parse-changes-failed exception with value t."
(when semantic-edits-verbose-flag
(message "Semantic parse changes failed: %S"
(apply 'format args)))
(throw 'semantic-parse-changes-failed t))
(defsubst semantic-edits-incremental-fail ()
"When the incremental parser fails, we mark that we need a full reparse."
;;(debug)
(semantic-parse-tree-set-needs-rebuild)
(when semantic-edits-verbose-flag
(message "Force full reparse (%s)"
(buffer-name (current-buffer))))
(run-hooks 'semantic-edits-incremental-reparse-failed-hooks))
(defun semantic-edits-incremental-parser ()
"Incrementally reparse the current buffer.
Incremental parser allows semantic to only reparse those sections of
the buffer that have changed. This function depends on
`semantic-edits-change-function-handle-changes' setting up change
overlays in the current buffer. Those overlays are analyzed against
the semantic cache to see what needs to be changed."
(let ((changed-tags
;; Don't use `semantic-safe' here to explicitly catch errors
;; and reset the parse tree.
(catch 'semantic-parse-changes-failed
(if debug-on-error
(semantic-edits-incremental-parser-1)
(condition-case err
(semantic-edits-incremental-parser-1)
(error
(message "incremental parser error: %S"
(error-message-string err))
t))))))
(when (eq changed-tags t)
;; Force a full reparse.
(semantic-edits-incremental-fail)
(setq changed-tags nil))
changed-tags))
(defmacro semantic-edits-assert-valid-region ()
"Asert that parse-start and parse-end are sorted correctly."
;;; (if (> parse-start parse-end)
;;; (error "Bug is %s !> %d! Buff min/max = [ %d %d ]"
;;; parse-start parse-end
;;; (point-min) (point-max)))
)
(defun semantic-edits-incremental-parser-1 ()
"Incrementally reparse the current buffer.
Return the list of tags that changed.
If the incremental parse fails, throw a 'semantic-parse-changes-failed
exception with value t, that can be caught to schedule a full reparse.
This function is for internal use by `semantic-edits-incremental-parser'."
(let* ((changed-tags nil)
(debug-on-quit t) ; try to find this annoying bug!
(changes (semantic-changes-in-region
(point-min) (point-max)))
(tags nil) ;tags found at changes
(newf-tags nil) ;newfound tags in change
(parse-start nil) ;location to start parsing
(parse-end nil) ;location to end parsing
(parent-tag nil) ;parent of the cache list.
(cache-list nil) ;list of children within which
;we incrementally reparse.
(reparse-symbol nil) ;The ruled we start at for reparse.
(change-group nil) ;changes grouped in this reparse
(last-cond nil) ;track the last case used.
;query this when debugging to find
;source of bugs.
)
(or changes
;; If we were called, and there are no changes, then we
;; don't know what to do. Force a full reparse.
(semantic-parse-changes-failed "Don't know what to do"))
;; Else, we have some changes. Loop over them attempting to
;; patch things up.
(while changes
;; Calculate the reparse boundary.
;; We want to take some set of changes, and group them
;; together into a small change group. One change forces
;; a reparse of a larger region (the size of some set of
;; tags it encompases.) It may contain several tags.
;; That region may have other changes in it (several small
;; changes in one function, for example.)
;; Optimize for the simple cases here, but try to handle
;; complex ones too.
(while (and changes ; we still have changes
(or (not parse-start)
;; Below, if the change we are looking at
;; is not the first change for this
;; iteration, and it starts before the end
;; of current parse region, then it is
;; encompased within the bounds of tags
;; modified by the previous iteration's
;; change.
(< (semantic-overlay-start (car changes))
parse-end)))
;; REMOVE LATER
(if (eq (car changes) (car change-group))
(semantic-parse-changes-failed
"Possible infinite loop detected"))
;; Store this change in this change group.
(setq change-group (cons (car changes) change-group))
(cond
;; Is this is a new parse group?
((not parse-start)
(setq last-cond "new group")
(let (tmp)
(cond
;;;; Are we encompassed all in one tag?
((setq tmp (semantic-edits-change-leaf-tag (car changes)))
(setq last-cond "Encompassed in tag")
(setq tags (list tmp)
parse-start (semantic-tag-start tmp)
parse-end (semantic-tag-end tmp)
)
(semantic-edits-assert-valid-region))
;;;; Did the change occur between some tags?
((setq cache-list (semantic-edits-change-between-tags
(car changes)))
(setq last-cond "Between and not overlapping tags")
;; The CAR of cache-list is the tag just before
;; our change, but wasn't modified. Hmmm.
;; Bound our reparse between these two tags
(setq tags nil
parent-tag
(car (semantic-find-tag-by-overlay
parse-start)))
(cond
;; A change at the beginning of the buffer.
;; Feb 06 -
;; IDed when the first cache-list tag is after
;; our change, meaning there is nothing before
;; the chnge.
((> (semantic-tag-start (car cache-list))
(semantic-overlay-end (car changes)))
(setq last-cond "Beginning of buffer")
(setq parse-start
;; Don't worry about parents since
;; there there would be an exact
;; match in the tag list otherwise
;; and the routine would fail.
(point-min)
parse-end
(semantic-tag-start (car cache-list)))
(semantic-edits-assert-valid-region)
)
;; A change stuck on the first surrounding tag.
((= (semantic-tag-end (car cache-list))
(semantic-overlay-start (car changes)))
(setq last-cond "Beginning of Tag")
;; Reparse that first tag.
(setq parse-start
(semantic-tag-start (car cache-list))
parse-end
(semantic-overlay-end (car changes))
tags
(list (car cache-list)))
(semantic-edits-assert-valid-region)
)
;; A change at the end of the buffer.
((not (car (cdr cache-list)))
(setq last-cond "End of buffer")
(setq parse-start (semantic-tag-end
(car cache-list))
parse-end (point-max))
(semantic-edits-assert-valid-region)
)
(t
(setq last-cond "Default")
(setq parse-start
(semantic-tag-end (car cache-list))
parse-end
(semantic-tag-start (car (cdr cache-list)))
)
(semantic-edits-assert-valid-region))))
;;;; Did the change completely overlap some number of tags?
((setq tmp (semantic-edits-change-over-tags
(car changes)))
(setq last-cond "Overlap multiple tags")
;; Extract the information
(setq tags (aref tmp 0)
cache-list (aref tmp 1)
parent-tag (aref tmp 2))
;; We can calculate parse begin/end by checking
;; out what is in TAGS. The one near start is
;; always first. Make sure the reprase includes
;; the `whitespace' around the snarfed tags.
;; Since cache-list is positioned properly, use it
;; to find that boundary.
(if (eq (car tags) (car cache-list))
;; Beginning of the buffer!
(let ((end-marker (nth (length tags)
cache-list)))
(setq parse-start (point-min))
(if end-marker
(setq parse-end
(semantic-tag-start end-marker))
(setq parse-end (semantic-overlay-end
(car changes))))
(semantic-edits-assert-valid-region)
)
;; Middle of the buffer.
(setq parse-start
(semantic-tag-end (car cache-list)))
;; For the end, we need to scoot down some
;; number of tags. We 1+ the length of tags
;; because we want to skip the first tag
;; (remove 1-) then want the tag after the end
;; of the list (1+)
(let ((end-marker (nth (1+ (length tags)) cache-list)))
(if end-marker
(setq parse-end (semantic-tag-start end-marker))
;; No marker. It is the last tag in our
;; list of tags. Only possible if END
;; already matches the end of that tag.
(setq parse-end
(semantic-overlay-end (car changes)))))
(semantic-edits-assert-valid-region)
))
;;;; Unhandled case.
;; Throw error, and force full reparse.
((semantic-parse-changes-failed "Unhandled change group")))
))
;; Is this change inside the previous parse group?
;; We already checked start.
((< (semantic-overlay-end (car changes)) parse-end)
(setq last-cond "in bounds")
nil)
;; This change extends the current parse group.
;; Find any new tags, and see how to append them.
((semantic-parse-changes-failed
(setq last-cond "overlap boundary")
"Unhandled secondary change overlapping boundary"))
)
;; Prepare for the next iteration.
(setq changes (cdr changes)))
;; By the time we get here, all TAGS are children of
;; some parent. They should all have the same start symbol
;; since that is how the multi-tag parser works. Grab
;; the reparse symbol from the first of the returned tags.
;;
;; Feb '06 - If repase-symbol is nil, then they are top level
;; tags. (I'm guessing.) Is this right?
(setq reparse-symbol
(semantic--tag-get-property (car (or tags cache-list))
'reparse-symbol))
;; Find a parent if not provided.
(and (not parent-tag) tags
(setq parent-tag
(semantic-find-tag-parent-by-overlay
(car tags))))
;; We can do the same trick for our parent and resulting
;; cache list.
(unless cache-list
(if parent-tag
(setq cache-list
;; We need to get all children in case we happen
;; to have a mix of positioned and non-positioned
;; children.
(semantic-tag-components parent-tag))
;; Else, all the tags since there is no parent.
;; It sucks to have to use the full buffer cache in
;; this case because it can be big. Failure to provide
;; however results in a crash.
(setq cache-list semantic--buffer-cache)
))
;; Use the boundary to calculate the new tags found.
(setq newf-tags (semantic-parse-region
parse-start parse-end reparse-symbol))
;; Make sure all these tags are given overlays.
;; They have already been cooked by the parser and just
;; need the overlays.
(let ((tmp newf-tags))
(while tmp
(semantic--tag-link-to-buffer (car tmp))
(setq tmp (cdr tmp))))
;; See how this change lays out.
(cond
;;;; Whitespace change
((and (not tags) (not newf-tags))
;; A change that occured outside of any existing tags
;; and there are no new tags to replace it.
(when semantic-edits-verbose-flag
(message "White space changes"))
nil
)
;;;; New tags in old whitespace area.
((and (not tags) newf-tags)
;; A change occured outside existing tags which added
;; a new tag. We need to splice these tags back
;; into the cache at the right place.
(semantic-edits-splice-insert newf-tags parent-tag cache-list)
(setq changed-tags
(append newf-tags changed-tags))
(when semantic-edits-verbose-flag
(message "Inserted tags: (%s)"
(semantic-format-tag-name (car newf-tags))))
)
;;;; Old tags removed
((and tags (not newf-tags))
;; A change occured where pre-existing tags were
;; deleted! Remove the tag from the cache.
(semantic-edits-splice-remove tags parent-tag cache-list)
(setq changed-tags
(append tags changed-tags))
(when semantic-edits-verbose-flag
(message "Deleted tags: (%s)"
(semantic-format-tag-name (car tags))))
)
;;;; One tag was updated.
((and (= (length tags) 1) (= (length newf-tags) 1))
;; One old tag was modified, and it is replaced by
;; One newfound tag. Splice the new tag into the
;; position of the old tag.
;; Do the splice.
(semantic-edits-splice-replace (car tags) (car newf-tags))
;; Add this tag to our list of changed toksns
(setq changed-tags (cons (car tags) changed-tags))
;; Debug
(when semantic-edits-verbose-flag
(message "Update Tag Table: %s"
(semantic-format-tag-name (car tags) nil t)))
;; Flush change regardless of above if statement.
)
;;;; Some unhandled case.
((semantic-parse-changes-failed "Don't know what to do")))
;; We got this far, and we didn't flag a full reparse.
;; Clear out this change group.
(while change-group
(semantic-edits-flush-change (car change-group))
(setq change-group (cdr change-group)))
;; Don't increment change here because an earlier loop
;; created change-groups.
(setq parse-start nil)
)
;; Mark that we are done with this glop
(semantic-parse-tree-set-up-to-date)
;; Return the list of tags that changed. The caller will
;; use this information to call hooks which can fix themselves.
changed-tags))
;; Make it the default changes parser
(defalias 'semantic-parse-changes-default
'semantic-edits-incremental-parser)
;;; Cache Splicing
;;
;; The incremental parser depends on the ability to parse up sections
;; of the file, and splice the results back into the cache. There are
;; three types of splices. A REPLACE, an ADD, and a REMOVE. REPLACE
;; is one of the simpler cases, as the starting cons cell representing
;; the old tag can be used to auto-splice in. ADD and REMOVE
;; require scanning the cache to find the correct location so that the
;; list can be fiddled.
(defun semantic-edits-splice-remove (oldtags parent cachelist)
"Remove OLDTAGS from PARENT's CACHELIST.
OLDTAGS are tags in the currenet buffer, preferably linked
together also in CACHELIST.
PARENT is the parent tag containing OLDTAGS.
CACHELIST should be the children from PARENT, but may be
pre-positioned to a convenient location."
(let* ((first (car oldtags))
(last (nth (1- (length oldtags)) oldtags))
(chil (if parent
(semantic-tag-components parent)
semantic--buffer-cache))
(cachestart cachelist)
(cacheend nil)
)
;; First in child list?
(if (eq first (car chil))
;; First tags in the cache are being deleted.
(progn
(when semantic-edits-verbose-flag
(message "To Remove First Tag: (%s)"
(semantic-format-tag-name first)))
;; Find the last tag
(setq cacheend chil)
(while (and cacheend (not (eq last (car cacheend))))
(setq cacheend (cdr cacheend)))
;; The splicable part is after cacheend.. so move cacheend
;; one more tag.
(setq cacheend (cdr cacheend))
;; Splice the found end tag into the cons cell
;; owned by the current top child.
(setcar chil (car cacheend))
(setcdr chil (cdr cacheend))
(when (not cacheend)
;; No cacheend.. then the whole system is empty.
;; The best way to deal with that is to do a full
;; reparse
(semantic-parse-changes-failed "Splice-remove failed. Empty buffer?")
))
(message "To Remove Middle Tag: (%s)"
(semantic-format-tag-name first)))
;; Find in the cache the preceeding tag
(while (and cachestart (not (eq first (car (cdr cachestart)))))
(setq cachestart (cdr cachestart)))
;; Find the last tag
(setq cacheend cachestart)
(while (and cacheend (not (eq last (car cacheend))))
(setq cacheend (cdr cacheend)))
;; Splice the end position into the start position.
;; If there is no start, then this whole section is probably
;; gone.
(if cachestart
(setcdr cachestart (cdr cacheend))
(semantic-parse-changes-failed "Splice-remove failed."))
;; Remove old overlays of these deleted tags
(while oldtags
(semantic--tag-unlink-from-buffer (car oldtags))
(setq oldtags (cdr oldtags)))
))
(defun semantic-edits-splice-insert (newtags parent cachelist)
"Insert NEWTAGS into PARENT using CACHELIST.
PARENT could be nil, in which case CACHLIST is the buffer cache
which must be updated.
CACHELIST must be searched to find where NEWTAGS are to be inserted.
The positions of NEWTAGS must be synchronized with those in
CACHELIST for this to work. Some routines pre-position CACHLIST at a
convenient location, so use that."
(let* ((start (semantic-tag-start (car newtags)))
(newtagendcell (nthcdr (1- (length newtags)) newtags))
(end (semantic-tag-end (car newtagendcell)))
)
(if (> (semantic-tag-start (car cachelist)) start)
;; We are at the beginning.
(let* ((pc (if parent
(semantic-tag-components parent)
semantic--buffer-cache))
(nc (cons (car pc) (cdr pc))) ; new cons cell.
)
;; Splice the new cache cons cell onto the end of our list.
(setcdr newtagendcell nc)
;; Set our list into parent.
(setcar pc (car newtags))
(setcdr pc (cdr newtags)))
;; We are at the end, or in the middle. Find our match first.
(while (and (cdr cachelist)
(> end (semantic-tag-start (car (cdr cachelist)))))
(setq cachelist (cdr cachelist)))
;; Now splice into the list!
(setcdr newtagendcell (cdr cachelist))
(setcdr cachelist newtags))))
(defun semantic-edits-splice-replace (oldtag newtag)
"Replace OLDTAG with NEWTAG in the current cache.
Do this by recycling OLDTAG's first CONS cell. This effectivly
causes the new tag to completely replace the old one.
Make sure that all information in the overlay is transferred.
It is presumed that OLDTAG and NEWTAG are both cooked.
When this routine returns, OLDTAG is raw, and the data will be
lost if not transferred into NEWTAG."
(let* ((oo (semantic-tag-overlay oldtag))
(o (semantic-tag-overlay newtag))
(oo-props (semantic-overlay-properties oo)))
(while oo-props
(semantic-overlay-put o (car oo-props) (car (cdr oo-props)))
(setq oo-props (cdr (cdr oo-props)))
)
;; Free the old overlay(s)
(semantic--tag-unlink-from-buffer oldtag)
;; Recover properties
(semantic--tag-copy-properties oldtag newtag)
;; Splice into the main list.
(setcdr oldtag (cdr newtag))
(setcar oldtag (car newtag))
;; This important bit is because the CONS cell representing
;; OLDTAG is now pointing to NEWTAG, but the NEWTAG
;; cell is about to be abandoned. Here we update our overlay
;; to point at the updated state of the world.
(semantic-overlay-put o 'semantic oldtag)
))
;;; Setup incremental parser
;;
(add-hook 'semantic-change-hooks
#'semantic-edits-change-function-handle-changes)
(add-hook 'semantic-before-toplevel-cache-flush-hook
#'semantic-edits-flush-changes)
(provide 'semantic/edit)
;;; semantic-edit.el ends here

262
lisp/cedet/semantic/html.el Normal file
View File

@ -0,0 +1,262 @@
;;; html.el --- Semantic details for html files
;;; Copyright (C) 2004, 2005, 2007, 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:
;;
;; Parse HTML files and organize them in a nice way.
;; Pay attention to anchors, including them in the tag list.
;;
;; Copied from the original semantic-texi.el.
;;
;; ToDo: Find <script> tags, and parse the contents in other
;; parsers, such as javascript, php, shtml, or others.
(require 'semantic)
(require 'semantic/format)
(condition-case nil
;; This is not installed in all versions of Emacs.
(require 'sgml-mode) ;; html-mode is in here.
(error
(require 'psgml-mode) ;; XEmacs uses psgml, and html-mode is in here.
))
;;; Code:
(eval-when-compile
(require 'semantic/ctxt)
(require 'semantic/imenu)
(require 'senator))
(defvar semantic-html-super-regex
"<\\(h[1-9]\\|title\\|script\\|body\\|a +href\\)\\>"
"Regular expression used to find special sections in an HTML file.")
(defvar semantic-html-section-list
'(("title" 1)
("script" 1)
("body" 1)
("a" 11)
("h1" 2)
("h2" 3)
("h3" 4)
("h4" 5)
("h5" 6)
("h6" 7)
("h7" 8)
("h8" 9)
("h9" 10)
)
"Alist of sectioning commands and their relative level.")
(define-mode-local-override semantic-parse-region
html-mode (&rest ignore)
"Parse the current html buffer for semantic tags.
INGNORE any arguments. Always parse the whole buffer.
Each tag returned is of the form:
(\"NAME\" section (:members CHILDREN))
or
(\"NAME\" anchor)"
(mapcar 'semantic-html-expand-tag
(semantic-html-parse-headings)))
(define-mode-local-override semantic-parse-changes
html-mode ()
"We can't parse changes for HTML mode right now."
(semantic-parse-tree-set-needs-rebuild))
(defun semantic-html-expand-tag (tag)
"Expand the HTML tag TAG."
(let ((chil (semantic-html-components tag)))
(if chil
(semantic-tag-put-attribute
tag :members (mapcar 'semantic-html-expand-tag chil)))
(car (semantic--tag-expand tag))))
(defun semantic-html-components (tag)
"Return components belonging to TAG."
(semantic-tag-get-attribute tag :members))
(defun semantic-html-parse-headings ()
"Parse the current html buffer for all semantic tags."
(let ((pass1 nil))
;; First search and snarf.
(save-excursion
(goto-char (point-min))
(let ((semantic--progress-reporter
(make-progress-reporter
(format "Parsing %s..."
(file-name-nondirectory buffer-file-name))
(point-min) (point-max))))
(while (re-search-forward semantic-html-super-regex nil t)
(setq pass1 (cons (match-beginning 0) pass1))
(progress-reporter-update semantic--progress-reporter (point)))
(progress-reporter-done semantic--progress-reporter)))
(setq pass1 (nreverse pass1))
;; Now, make some tags while creating a set of children.
(car (semantic-html-recursive-combobulate-list pass1 0))
))
(defun semantic-html-set-endpoint (metataglist pnt)
"Set the end point of the first section tag in METATAGLIST to PNT.
METATAGLIST is a list of tags in the intermediate tag format used by the
html parser. PNT is the new point to set."
(let ((metatag nil))
(while (and metataglist
(not (eq (semantic-tag-class (car metataglist)) 'section)))
(setq metataglist (cdr metataglist)))
(setq metatag (car metataglist))
(when metatag
(setcar (nthcdr (1- (length metatag)) metatag) pnt)
metatag)))
(defsubst semantic-html-new-section-tag (name members level start end)
"Create a semantic tag of class section.
NAME is the name of this section.
MEMBERS is a list of semantic tags representing the elements that make
up this section.
LEVEL is the levelling level.
START and END define the location of data described by the tag."
(let ((anchorp (eq level 11)))
(append (semantic-tag name
(cond (anchorp 'anchor)
(t 'section))
:members members)
(list start (if anchorp (point) end)) )))
(defun semantic-html-extract-section-name ()
"Extract a section name from the current buffer and point.
Assume the cursor is in the tag representing the section we
need the name from."
(save-excursion
; Skip over the HTML tag.
(forward-sexp -1)
(forward-char -1)
(forward-sexp 1)
(skip-chars-forward "\n\t ")
(while (looking-at "<")
(forward-sexp 1)
(skip-chars-forward "\n\t ")
)
(let ((start (point))
(end nil))
(if (re-search-forward "</" nil t)
(progn
(goto-char (match-beginning 0))
(skip-chars-backward " \n\t")
(setq end (point))
(buffer-substring-no-properties start end))
""))
))
(defun semantic-html-recursive-combobulate-list (sectionlist level)
"Rearrange SECTIONLIST to be a hierarchical tag list starting at LEVEL.
Return the rearranged new list, with all remaining tags from
SECTIONLIST starting at ELT 2. Sections not are not dealt with as soon as a
tag with greater section value than LEVEL is found."
(let ((newl nil)
(oldl sectionlist)
(case-fold-search t)
tag
)
(save-excursion
(catch 'level-jump
(while oldl
(goto-char (car oldl))
(if (looking-at "<\\(\\w+\\)")
(let* ((word (match-string 1))
(levelmatch (assoc-ignore-case
word semantic-html-section-list))
text begin tmp
)
(when (not levelmatch)
(error "Tag %s matched in regexp but is not in list"
word))
;; Set begin to the right location
(setq begin (point))
;; Get out of here if there if we made it that far.
(if (and levelmatch (<= (car (cdr levelmatch)) level))
(progn
(when newl
(semantic-html-set-endpoint newl begin))
(throw 'level-jump t)))
;; When there is a match, the descriptive text
;; consists of the rest of the line.
(goto-char (match-end 1))
(skip-chars-forward " \t")
(setq text (semantic-html-extract-section-name))
;; Next, recurse into the body to find the end.
(setq tmp (semantic-html-recursive-combobulate-list
(cdr oldl) (car (cdr levelmatch))))
;; Build a tag
(setq tag (semantic-html-new-section-tag
text (car tmp) (car (cdr levelmatch)) begin (point-max)))
;; Before appending the newtag, update the previous tag
;; if it is a section tag.
(when newl
(semantic-html-set-endpoint newl begin))
;; Append new tag to our master list.
(setq newl (cons tag newl))
;; continue
(setq oldl (cdr tmp))
)
(error "Problem finding section in semantic/html parser"))
;; (setq oldl (cdr oldl))
)))
;; Return the list
(cons (nreverse newl) oldl)))
(define-mode-local-override semantic-sb-tag-children-to-expand
html-mode (tag)
"The children TAG expands to."
(semantic-html-components tag))
(defun semantic-default-html-setup ()
"Set up a buffer for parsing of HTML files."
;; This will use our parser.
(setq semantic-parser-name "HTML"
semantic--parse-table t
imenu-create-index-function 'semantic-create-imenu-index
semantic-command-separation-character ">"
semantic-type-relation-separator-character '(":")
semantic-symbol->name-assoc-list '((section . "Section")
)
semantic-imenu-expandable-tag-classes '(section)
semantic-imenu-bucketize-file nil
semantic-imenu-bucketize-type-members nil
senator-step-at-start-end-tag-classes '(section)
semantic-stickyfunc-sticky-classes '(section)
)
(semantic-install-function-overrides
'((tag-components . semantic-html-components)
)
t)
)
(add-hook 'html-mode-hook 'semantic-default-html-setup)
(define-child-mode html-helper-mode html-mode
"`html-helper-mode' needs the same semantic support as `html-mode'.")
(provide 'semantic/html)
;;; semantic-html.el ends here

957
lisp/cedet/semantic/idle.el Normal file
View File

@ -0,0 +1,957 @@
;;; idle.el --- Schedule parsing tasks in idle time
;;; Copyright (C) 2003, 2004, 2005, 2006, 2008, 2009
;;; Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: syntax
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; Originally, `semantic-auto-parse-mode' handled refreshing the
;; tags in a buffer in idle time. Other activities can be scheduled
;; in idle time, all of which require up-to-date tag tables.
;; Having a specialized idle time scheduler that first refreshes
;; the tags buffer, and then enables other idle time tasks reduces
;; the amount of work needed. Any specialized idle tasks need not
;; ask for a fresh tags list.
;;
;; NOTE ON SEMANTIC_ANALYZE
;;
;; Some of the idle modes use the semantic analyzer. The analyzer
;; automatically caches the created context, so it is shared amongst
;; all idle modes that will need it.
(require 'semantic/util-modes)
(require 'timer)
;;; Code:
;;; TIMER RELATED FUNCTIONS
;;
(defvar semantic-idle-scheduler-timer nil
"Timer used to schedule tasks in idle time.")
(defvar semantic-idle-scheduler-work-timer nil
"Timer used to schedule tasks in idle time that may take a while.")
(defcustom semantic-idle-scheduler-verbose-flag nil
"*Non-nil means that the idle scheduler should provide debug messages.
Use this setting to debug idle activities."
:group 'semantic
:type 'boolean)
(defcustom semantic-idle-scheduler-idle-time 2
"*Time in seconds of idle before scheduling events.
This time should be short enough to ensure that idle-scheduler will be
run as soon as Emacs is idle."
:group 'semantic
:type 'number
:set (lambda (sym val)
(set-default sym val)
(when (timerp semantic-idle-scheduler-timer)
(cancel-timer semantic-idle-scheduler-timer)
(setq semantic-idle-scheduler-timer nil)
(semantic-idle-scheduler-setup-timers))))
(defcustom semantic-idle-scheduler-work-idle-time 60
"*Time in seconds of idle before scheduling big work.
This time should be long enough that once any big work is started, it is
unlikely the user would be ready to type again right away."
:group 'semantic
:type 'number
:set (lambda (sym val)
(set-default sym val)
(when (timerp semantic-idle-scheduler-timer)
(cancel-timer semantic-idle-scheduler-timer)
(setq semantic-idle-scheduler-timer nil)
(semantic-idle-scheduler-setup-timers))))
(defun semantic-idle-scheduler-setup-timers ()
"Lazy initialization of the auto parse idle timer."
;; REFRESH THIS FUNCTION for XEMACS FOIBLES
(or (timerp semantic-idle-scheduler-timer)
(setq semantic-idle-scheduler-timer
(run-with-idle-timer
semantic-idle-scheduler-idle-time t
#'semantic-idle-scheduler-function)))
(or (timerp semantic-idle-scheduler-work-timer)
(setq semantic-idle-scheduler-work-timer
(run-with-idle-timer
semantic-idle-scheduler-work-idle-time t
#'semantic-idle-scheduler-work-function)))
)
(defun semantic-idle-scheduler-kill-timer ()
"Kill the auto parse idle timer."
(if (timerp semantic-idle-scheduler-timer)
(cancel-timer semantic-idle-scheduler-timer))
(setq semantic-idle-scheduler-timer nil))
;;; MINOR MODE
;;
;; The minor mode portion of this code just sets up the minor mode
;; which does the initial scheduling of the idle timers.
;;
(defcustom global-semantic-idle-scheduler-mode nil
"*If non-nil, enable global use of idle-scheduler mode."
:group 'semantic
:group 'semantic-modes
:type 'boolean
:require 'semantic/idle
:initialize 'custom-initialize-default
:set (lambda (sym val)
(global-semantic-idle-scheduler-mode (if val 1 -1))))
;;;###autoload
(defun global-semantic-idle-scheduler-mode (&optional arg)
"Toggle global use of option `semantic-idle-scheduler-mode'.
The idle scheduler with automatically reparse buffers in idle time,
and then schedule other jobs setup with `semantic-idle-scheduler-add'.
If ARG is positive, enable, if it is negative, disable.
If ARG is nil, then toggle."
(interactive "P")
(setq global-semantic-idle-scheduler-mode
(semantic-toggle-minor-mode-globally
'semantic-idle-scheduler-mode arg)))
(defcustom semantic-idle-scheduler-mode-hook nil
"*Hook run at the end of function `semantic-idle-scheduler-mode'."
:group 'semantic
:type 'hook)
;;;###autoload
(defvar semantic-idle-scheduler-mode nil
"Non-nil if idle-scheduler minor mode is enabled.
Use the command `semantic-idle-scheduler-mode' to change this variable.")
(make-variable-buffer-local 'semantic-idle-scheduler-mode)
(defcustom semantic-idle-scheduler-max-buffer-size 0
"*Maximum size in bytes of buffers where idle-scheduler is enabled.
If this value is less than or equal to 0, idle-scheduler is enabled in
all buffers regardless of their size."
:group 'semantic
:type 'number)
(defsubst semantic-idle-scheduler-enabled-p ()
"Return non-nil if idle-scheduler is enabled for this buffer.
idle-scheduler is disabled when debugging or if the buffer size
exceeds the `semantic-idle-scheduler-max-buffer-size' threshold."
(and semantic-idle-scheduler-mode
(not semantic-debug-enabled)
(not semantic-lex-debug)
(or (<= semantic-idle-scheduler-max-buffer-size 0)
(< (buffer-size) semantic-idle-scheduler-max-buffer-size))))
(defun semantic-idle-scheduler-mode-setup ()
"Setup option `semantic-idle-scheduler-mode'.
The minor mode can be turned on only if semantic feature is available
and the current buffer was set up for parsing. When minor mode is
enabled parse the current buffer if needed. Return non-nil if the
minor mode is enabled."
(if semantic-idle-scheduler-mode
(if (not (and (featurep 'semantic) (semantic-active-p)))
(progn
;; Disable minor mode if semantic stuff not available
(setq semantic-idle-scheduler-mode nil)
(error "Buffer %s was not set up idle time scheduling"
(buffer-name)))
(semantic-idle-scheduler-setup-timers)))
semantic-idle-scheduler-mode)
;;;###autoload
(defun semantic-idle-scheduler-mode (&optional arg)
"Minor mode to auto parse buffer following a change.
When this mode is off, a buffer is only rescanned for tokens when
some command requests the list of available tokens. When idle-scheduler
is enabled, Emacs periodically checks to see if the buffer is out of
date, and reparses while the user is idle (not typing.)
With prefix argument ARG, turn on if positive, otherwise off. The
minor mode can be turned on only if semantic feature is available and
the current buffer was set up for parsing. Return non-nil if the
minor mode is enabled."
(interactive
(list (or current-prefix-arg
(if semantic-idle-scheduler-mode 0 1))))
(setq semantic-idle-scheduler-mode
(if arg
(>
(prefix-numeric-value arg)
0)
(not semantic-idle-scheduler-mode)))
(semantic-idle-scheduler-mode-setup)
(run-hooks 'semantic-idle-scheduler-mode-hook)
(if (interactive-p)
(message "idle-scheduler minor mode %sabled"
(if semantic-idle-scheduler-mode "en" "dis")))
(semantic-mode-line-update)
semantic-idle-scheduler-mode)
(semantic-add-minor-mode 'semantic-idle-scheduler-mode
"ARP"
nil)
(semantic-alias-obsolete 'semantic-auto-parse-mode
'semantic-idle-scheduler-mode)
(semantic-alias-obsolete 'global-semantic-auto-parse-mode
'global-semantic-idle-scheduler-mode)
;;; SERVICES services
;;
;; These are services for managing idle services.
;;
(defvar semantic-idle-scheduler-queue nil
"List of functions to execute during idle time.
These functions will be called in the current buffer after that
buffer has had its tags made up to date. These functions
will not be called if there are errors parsing the
current buffer.")
;;;###autoload
(defun semantic-idle-scheduler-add (function)
"Schedule FUNCTION to occur during idle time."
(add-to-list 'semantic-idle-scheduler-queue function))
;;;###autoload
(defun semantic-idle-scheduler-remove (function)
"Unschedule FUNCTION to occur during idle time."
(setq semantic-idle-scheduler-queue
(delete function semantic-idle-scheduler-queue)))
;;; IDLE Function
;;
(defun semantic-idle-core-handler ()
"Core idle function that handles reparsing.
And also manages services that depend on tag values."
(when semantic-idle-scheduler-verbose-flag
(message "IDLE: Core handler..."))
(semantic-exit-on-input 'idle-timer
(let* ((inhibit-quit nil)
(buffers (delq (current-buffer)
(delq nil
(mapcar #'(lambda (b)
(and (buffer-file-name b)
b))
(buffer-list)))))
safe ;; This safe is not used, but could be.
others
mode)
(when (semantic-idle-scheduler-enabled-p)
(save-excursion
;; First, reparse the current buffer.
(setq mode major-mode
safe (semantic-safe "Idle Parse Error: %S"
;(error "Goofy error 1")
(semantic-idle-scheduler-refresh-tags)
)
)
;; Now loop over other buffers with same major mode, trying to
;; update them as well. Stop on keypress.
(dolist (b buffers)
(semantic-throw-on-input 'parsing-mode-buffers)
(with-current-buffer b
(if (eq major-mode mode)
(and (semantic-idle-scheduler-enabled-p)
(semantic-safe "Idle Parse Error: %S"
;(error "Goofy error")
(semantic-idle-scheduler-refresh-tags)))
(push (current-buffer) others))))
(setq buffers others))
;; If re-parse of current buffer completed, evaluate all other
;; services. Stop on keypress.
;; NOTE ON COMMENTED SAFE HERE
;; We used to not execute the services if the buffer wsa
;; unparseable. We now assume that they are lexically
;; safe to do, because we have marked the buffer unparseable
;; if there was a problem.
;;(when safe
(dolist (service semantic-idle-scheduler-queue)
(save-excursion
(semantic-throw-on-input 'idle-queue)
(when semantic-idle-scheduler-verbose-flag
(message "IDLE: execture service %s..." service))
(semantic-safe (format "Idle Service Error %s: %%S" service)
(funcall service))
(when semantic-idle-scheduler-verbose-flag
(message "IDLE: execture service %s...done" service))
)))
;;)
;; Finally loop over remaining buffers, trying to update them as
;; well. Stop on keypress.
(save-excursion
(dolist (b buffers)
(semantic-throw-on-input 'parsing-other-buffers)
(with-current-buffer b
(and (semantic-idle-scheduler-enabled-p)
(semantic-idle-scheduler-refresh-tags)))))
))
(when semantic-idle-scheduler-verbose-flag
(message "IDLE: Core handler...done")))
(defun semantic-debug-idle-function ()
"Run the Semantic idle function with debugging turned on."
(interactive)
(let ((debug-on-error t))
(semantic-idle-core-handler)
))
(defun semantic-idle-scheduler-function ()
"Function run when after `semantic-idle-scheduler-idle-time'.
This function will reparse the current buffer, and if successful,
call additional functions registered with the timer calls."
(when (zerop (recursion-depth))
(let ((debug-on-error nil))
(save-match-data (semantic-idle-core-handler))
)))
;;; WORK FUNCTION
;;
;; Unlike the shorter timer, the WORK timer will kick of tasks that
;; may take a long time to complete.
(defcustom semantic-idle-work-parse-neighboring-files-flag t
"*Non-nil means to parse files in the same dir as the current buffer.
Disable to prevent lots of excessive parsing in idle time."
:group 'semantic
:type 'boolean)
(defun semantic-idle-work-for-one-buffer (buffer)
"Do long-processing work for for BUFFER.
Uses `semantic-safe' and returns the output.
Returns t of all processing succeeded."
(save-excursion
(set-buffer buffer)
(not (and
;; Just in case
(semantic-safe "Idle Work Parse Error: %S"
(semantic-idle-scheduler-refresh-tags)
t)
;; Force all our include files to get read in so we
;; are ready to provide good smart completion and idle
;; summary information
(semantic-safe "Idle Work Including Error: %S"
;; Get the include related path.
(when (and (featurep 'semantic/db)
(semanticdb-minor-mode-p))
(require 'semantic/db-find)
(semanticdb-find-translate-path buffer nil)
)
t)
;; Pre-build the typecaches as needed.
(semantic-safe "Idle Work Typecaching Error: %S"
(when (featurep 'semantic/db-typecache)
(semanticdb-typecache-refresh-for-buffer buffer))
t)
))
))
(defun semantic-idle-work-core-handler ()
"Core handler for idle work processing of long running tasks.
Visits semantic controlled buffers, and makes sure all needed
include files have been parsed, and that the typecache is up to date.
Uses `semantic-idle-work-for-on-buffer' to do the work."
(let ((errbuf nil)
(interrupted
(semantic-exit-on-input 'idle-work-timer
(let* ((inhibit-quit nil)
(cb (current-buffer))
(buffers (delq (current-buffer)
(delq nil
(mapcar #'(lambda (b)
(and (buffer-file-name b)
b))
(buffer-list)))))
safe errbuf)
;; First, handle long tasks in the current buffer.
(when (semantic-idle-scheduler-enabled-p)
(save-excursion
(setq safe (semantic-idle-work-for-one-buffer (current-buffer))
)))
(when (not safe) (push (current-buffer) errbuf))
;; Now loop over other buffers with same major mode, trying to
;; update them as well. Stop on keypress.
(dolist (b buffers)
(semantic-throw-on-input 'parsing-mode-buffers)
(with-current-buffer b
(when (semantic-idle-scheduler-enabled-p)
(and (semantic-idle-scheduler-enabled-p)
(unless (semantic-idle-work-for-one-buffer (current-buffer))
(push (current-buffer) errbuf)))
))
)
;; Save everything.
(semanticdb-save-all-db-idle)
;; Parse up files near our active buffer
(when semantic-idle-work-parse-neighboring-files-flag
(semantic-safe "Idle Work Parse Neighboring Files: %S"
(when (and (featurep 'semantic/db)
(semanticdb-minor-mode-p))
(set-buffer cb)
(semantic-idle-scheduler-work-parse-neighboring-files))
t)
)
;; Save everything... again
(semanticdb-save-all-db-idle)
;; Done w/ processing
nil))))
;; Done
(if interrupted
"Interrupted"
(cond ((not errbuf)
"done")
((not (cdr errbuf))
(format "done with 1 error in %s" (car errbuf)))
(t
(format "done with errors in %d buffers."
(length errbuf)))))))
(defun semantic-debug-idle-work-function ()
"Run the Semantic idle work function with debugging turned on."
(interactive)
(let ((debug-on-error t))
(semantic-idle-work-core-handler)
))
(defun semantic-idle-scheduler-work-function ()
"Function run when after `semantic-idle-scheduler-work-idle-time'.
This routine handles difficult tasks that require a lot of parsing, such as
parsing all the header files used by our active sources, or building up complex
datasets."
(when semantic-idle-scheduler-verbose-flag
(message "Long Work Idle Timer..."))
(let ((exit-type (save-match-data
(semantic-idle-work-core-handler))))
(when semantic-idle-scheduler-verbose-flag
(message "Long Work Idle Timer...%s" exit-type)))
)
(defun semantic-idle-scheduler-work-parse-neighboring-files ()
"Parse all the files in similar directories to buffers being edited."
;; Lets check to see if EDE matters.
(let ((ede-auto-add-method 'never))
(dolist (a auto-mode-alist)
(when (eq (cdr a) major-mode)
(dolist (file (directory-files default-directory t (car a) t))
(semantic-throw-on-input 'parsing-mode-buffers)
(save-excursion
(semanticdb-file-table-object file)
))))
))
(defun semantic-idle-pnf-test ()
"Test `semantic-idle-scheduler-work-parse-neighboring-files' and time it."
(interactive)
(let ((start (current-time))
(junk (semantic-idle-scheduler-work-parse-neighboring-files))
(end (current-time)))
(message "Work took %.2f seconds." (semantic-elapsed-time start end)))
)
;;; REPARSING
;;
;; Reparsing is installed as semantic idle service.
;; This part ALWAYS happens, and other services occur
;; afterwards.
;; (defcustom semantic-idle-scheduler-no-working-message t
;; "*If non-nil, disable display of working messages during parse."
;; :group 'semantic
;; :type 'boolean)
;; (defcustom semantic-idle-scheduler-working-in-modeline-flag nil
;; "*Non-nil means show working messages in the mode line.
;; Typically, parsing will show messages in the minibuffer.
;; This will move the parse message into the modeline."
;; :group 'semantic
;; :type 'boolean)
(defvar semantic-before-idle-scheduler-reparse-hooks nil
"Hooks run before option `semantic-idle-scheduler' begins parsing.
If any hook throws an error, this variable is reset to nil.
This hook is not protected from lexical errors.")
(defvar semantic-after-idle-scheduler-reparse-hooks nil
"Hooks run after option `semantic-idle-scheduler' has parsed.
If any hook throws an error, this variable is reset to nil.
This hook is not protected from lexical errors.")
(defun semantic-idle-scheduler-refresh-tags ()
"Refreshes the current buffer's tags.
This is called by `semantic-idle-scheduler-function' to update the
tags in the current buffer.
Return non-nil if the refresh was successful.
Return nil if there is some sort of syntax error preventing a full
reparse.
Does nothing if the current buffer doesn't need reparsing."
(prog1
;; These checks actually occur in `semantic-fetch-tags', but if we
;; do them here, then all the bovination hooks are not run, and
;; we save lots of time.
(cond
;; If the buffer was previously marked unparseable,
;; then don't waste our time.
((semantic-parse-tree-unparseable-p)
nil)
;; The parse tree is already ok.
((semantic-parse-tree-up-to-date-p)
t)
(t
;; If the buffer might need a reparse and it is safe to do so,
;; give it a try.
(let* (;(semantic-working-type nil)
(inhibit-quit nil)
;; (working-use-echo-area-p
;; (not semantic-idle-scheduler-working-in-modeline-flag))
;; (working-status-dynamic-type
;; (if semantic-idle-scheduler-no-working-message
;; nil
;; working-status-dynamic-type))
;; (working-status-percentage-type
;; (if semantic-idle-scheduler-no-working-message
;; nil
;; working-status-percentage-type))
(lexically-safe t)
)
;; Let people hook into this, but don't let them hose
;; us over!
(condition-case nil
(run-hooks 'semantic-before-idle-scheduler-reparse-hooks)
(error (setq semantic-before-idle-scheduler-reparse-hooks nil)))
(unwind-protect
;; Perform the parsing.
(progn
(when semantic-idle-scheduler-verbose-flag
(message "IDLE: reparse %s..." (buffer-name)))
(when (semantic-lex-catch-errors idle-scheduler
(save-excursion (semantic-fetch-tags))
nil)
;; If we are here, it is because the lexical step failed,
;; proably due to unterminated lists or something like that.
;; We do nothing, and just wait for the next idle timer
;; to go off. In the meantime, remember this, and make sure
;; no other idle services can get executed.
(setq lexically-safe nil))
(when semantic-idle-scheduler-verbose-flag
(message "IDLE: reparse %s...done" (buffer-name))))
;; Let people hook into this, but don't let them hose
;; us over!
(condition-case nil
(run-hooks 'semantic-after-idle-scheduler-reparse-hooks)
(error (setq semantic-after-idle-scheduler-reparse-hooks nil))))
;; Return if we are lexically safe (from prog1)
lexically-safe)))
;; After updating the tags, handle any pending decorations for this
;; buffer.
(semantic-decorate-flush-pending-decorations (current-buffer))
))
;;; IDLE SERVICES
;;
;; Idle Services are minor modes which enable or disable a services in
;; the idle scheduler. Creating a new services only requires calling
;; `semantic-create-idle-services' which does all the setup
;; needed to create the minor mode that will enable or disable
;; a services. The services must provide a single function.
(defmacro define-semantic-idle-service (name doc &rest forms)
"Create a new idle services with NAME.
DOC will be a documentation string describing FORMS.
FORMS will be called during idle time after the current buffer's
semantic tag information has been updated.
This routines creates the following functions and variables:"
(let ((global (intern (concat "global-" (symbol-name name) "-mode")))
(mode (intern (concat (symbol-name name) "-mode")))
(hook (intern (concat (symbol-name name) "-mode-hook")))
(map (intern (concat (symbol-name name) "-mode-map")))
(setup (intern (concat (symbol-name name) "-mode-setup")))
(func (intern (concat (symbol-name name) "-idle-function")))
)
`(eval-and-compile
(defun ,global (&optional arg)
,(concat "Toggle global use of option `" (symbol-name mode) "'.
If ARG is positive, enable, if it is negative, disable.
If ARG is nil, then toggle.")
(interactive "P")
(setq ,global
(semantic-toggle-minor-mode-globally
',mode arg)))
(defcustom ,global nil
(concat "*If non-nil, enable global use of `" (symbol-name ',mode) "'.
" ,doc)
:group 'semantic
:group 'semantic-modes
:type 'boolean
:require 'semantic/idle
:initialize 'custom-initialize-default
:set (lambda (sym val)
(,global (if val 1 -1))))
(defcustom ,hook nil
(concat "*Hook run at the end of function `" (symbol-name ',mode) "'.")
:group 'semantic
:type 'hook)
(defvar ,map
(let ((km (make-sparse-keymap)))
km)
(concat "Keymap for `" (symbol-name ',mode) "'."))
(defvar ,mode nil
(concat "Non-nil if summary minor mode is enabled.
Use the command `" (symbol-name ',mode) "' to change this variable."))
(make-variable-buffer-local ',mode)
(defun ,setup ()
,(concat "Setup option `" (symbol-name mode) "'.
The minor mode can be turned on only if semantic feature is available
and the idle scheduler is active.
Return non-nil if the minor mode is enabled.")
(if ,mode
(if (not (and (featurep 'semantic) (semantic-active-p)))
(progn
;; Disable minor mode if semantic stuff not available
(setq ,mode nil)
(error "Buffer %s was not set up for parsing"
(buffer-name)))
;; Enable the mode mode
(semantic-idle-scheduler-add #',func)
)
;; Disable the mode mode
(semantic-idle-scheduler-remove #',func)
)
,mode)
;;;###autoload
(defun ,mode (&optional arg)
,(concat doc "
This is a minor mode which performs actions during idle time.
With prefix argument ARG, turn on if positive, otherwise off. The
minor mode can be turned on only if semantic feature is available and
the current buffer was set up for parsing. Return non-nil if the
minor mode is enabled.")
(interactive
(list (or current-prefix-arg
(if ,mode 0 1))))
(setq ,mode
(if arg
(>
(prefix-numeric-value arg)
0)
(not ,mode)))
(,setup)
(run-hooks ,hook)
(if (interactive-p)
(message "%s %sabled"
(symbol-name ',mode)
(if ,mode "en" "dis")))
(semantic-mode-line-update)
,mode)
(semantic-add-minor-mode ',mode
"" ; idle schedulers are quiet?
,map)
(defun ,func ()
,doc
,@forms)
)))
(put 'define-semantic-idle-service 'lisp-indent-function 1)
;;; SUMMARY MODE
;;
;; A mode similar to eldoc using semantic
(require 'semantic/ctxt)
(defcustom semantic-idle-summary-function
'semantic-format-tag-summarize-with-file
"*Function to use when displaying tag information during idle time.
Some useful functions are found in `semantic-format-tag-functions'."
:group 'semantic
:type semantic-format-tag-custom-list)
(defsubst semantic-idle-summary-find-current-symbol-tag (sym)
"Search for a semantic tag with name SYM in database tables.
Return the tag found or nil if not found.
If semanticdb is not in use, use the current buffer only."
(car (if (and (featurep 'semantic/db) semanticdb-current-database)
(cdar (semanticdb-deep-find-tags-by-name sym))
(semantic-deep-find-tags-by-name sym (current-buffer)))))
(defun semantic-idle-summary-current-symbol-info-brutish ()
"Return a string message describing the current context.
Gets a symbol with `semantic-ctxt-current-thing' and then
trys to find it with a deep targetted search."
;; Try the current "thing".
(let ((sym (car (semantic-ctxt-current-thing))))
(when sym
(semantic-idle-summary-find-current-symbol-tag sym))))
(defun semantic-idle-summary-current-symbol-keyword ()
"Return a string message describing the current symbol.
Returns a value only if it is a keyword."
;; Try the current "thing".
(let ((sym (car (semantic-ctxt-current-thing))))
(if (and sym (semantic-lex-keyword-p sym))
(semantic-lex-keyword-get sym 'summary))))
(defun semantic-idle-summary-current-symbol-info-context ()
"Return a string message describing the current context.
Use the semantic analyzer to find the symbol information."
(let ((analysis (condition-case nil
(semantic-analyze-current-context (point))
(error nil))))
(when analysis
(semantic-analyze-interesting-tag analysis))))
(defun semantic-idle-summary-current-symbol-info-default ()
"Return a string message describing the current context.
This functin will disable loading of previously unloaded files
by semanticdb as a time-saving measure."
(let (
(semanticdb-find-default-throttle
(if (featurep 'semantic/db-find)
(remq 'unloaded semanticdb-find-default-throttle)
nil))
)
(save-excursion
;; use whicever has success first.
(or
(semantic-idle-summary-current-symbol-keyword)
(semantic-idle-summary-current-symbol-info-context)
(semantic-idle-summary-current-symbol-info-brutish)
))))
(defvar semantic-idle-summary-out-of-context-faces
'(
font-lock-comment-face
font-lock-string-face
font-lock-doc-string-face ; XEmacs.
font-lock-doc-face ; Emacs 21 and later.
)
"List of font-lock faces that indicate a useless summary context.
Those are generally faces used to highlight comments.
It might be useful to override this variable to add comment faces
specific to a major mode. For example, in jde mode:
\(defvar-mode-local jde-mode semantic-idle-summary-out-of-context-faces
(append (default-value 'semantic-idle-summary-out-of-context-faces)
'(jde-java-font-lock-doc-tag-face
jde-java-font-lock-link-face
jde-java-font-lock-bold-face
jde-java-font-lock-underline-face
jde-java-font-lock-pre-face
jde-java-font-lock-code-face)))")
(defun semantic-idle-summary-useful-context-p ()
"Non-nil of we should show a summary based on context."
(if (and (boundp 'font-lock-mode)
font-lock-mode
(memq (get-text-property (point) 'face)
semantic-idle-summary-out-of-context-faces))
;; The best I can think of at the moment is to disable
;; in comments by detecting with font-lock.
nil
t))
(define-overloadable-function semantic-idle-summary-current-symbol-info ()
"Return a string message describing the current context.")
(make-obsolete-overload 'semantic-eldoc-current-symbol-info
'semantic-idle-summary-current-symbol-info)
(define-semantic-idle-service semantic-idle-summary
"Display a tag summary of the lexical token under the cursor.
Call `semantic-idle-summary-current-symbol-info' for getting the
current tag to display information."
(or (eq major-mode 'emacs-lisp-mode)
(not (semantic-idle-summary-useful-context-p))
(let* ((found (semantic-idle-summary-current-symbol-info))
(str (cond ((stringp found) found)
((semantic-tag-p found)
(funcall semantic-idle-summary-function
found nil t))))
)
;; Show the message with eldoc functions
(require 'eldoc)
(unless (and str (boundp 'eldoc-echo-area-use-multiline-p)
eldoc-echo-area-use-multiline-p)
(let ((w (1- (window-width (minibuffer-window)))))
(if (> (length str) w)
(setq str (substring str 0 w)))))
(eldoc-message str))))
(semantic-alias-obsolete 'semantic-summary-mode
'semantic-idle-summary-mode)
(semantic-alias-obsolete 'global-semantic-summary-mode
'global-semantic-idle-summary-mode)
;;; Current symbol highlight
;;
;; This mode will use context analysis to perform highlighting
;; of all uses of the symbol that is under the cursor.
;;
;; This is to mimic the Eclipse tool of a similar nature.
(defvar semantic-idle-summary-highlight-face 'region
"Face used for the summary highlight.")
(defun semantic-idle-summary-maybe-highlight (tag)
"Perhaps add highlighting onto TAG.
TAG was found as the thing under point. If it happens to be
visible, then highlight it."
(let* ((region (when (and (semantic-tag-p tag)
(semantic-tag-with-position-p tag))
(semantic-tag-overlay tag)))
(file (when (and (semantic-tag-p tag)
(semantic-tag-with-position-p tag))
(semantic-tag-file-name tag)))
(buffer (when file (get-file-buffer file)))
;; We use pulse, but we don't want the flashy version,
;; just the stable version.
(pulse-flag nil)
)
(cond ((semantic-overlay-p region)
(save-excursion
(set-buffer (semantic-overlay-buffer region))
(goto-char (semantic-overlay-start region))
(when (pos-visible-in-window-p
(point) (get-buffer-window (current-buffer) 'visible))
(if (< (semantic-overlay-end region) (point-at-eol))
(pulse-momentary-highlight-overlay
region semantic-idle-summary-highlight-face)
;; Not the same
(pulse-momentary-highlight-region
(semantic-overlay-start region)
(point-at-eol)
semantic-idle-summary-highlight-face)))
))
((vectorp region)
(let ((start (aref region 0))
(end (aref region 1)))
(save-excursion
(when buffer (set-buffer buffer))
;; As a vector, we have no filename. Perhaps it is a
;; local variable?
(when (and (<= end (point-max))
(pos-visible-in-window-p
start (get-buffer-window (current-buffer) 'visible)))
(goto-char start)
(when (re-search-forward
(regexp-quote (semantic-tag-name tag))
end t)
;; This is likely it, give it a try.
(pulse-momentary-highlight-region
start (if (<= end (point-at-eol)) end
(point-at-eol))
semantic-idle-summary-highlight-face)))
))))
nil))
(define-semantic-idle-service semantic-idle-tag-highlight
"Highlight the tag, and references of the symbol under point.
Call `semantic-analyze-current-context' to find the reference tag.
Call `semantic-symref-hits-in-region' to identify local references."
(when (semantic-idle-summary-useful-context-p)
(let* ((ctxt (semantic-analyze-current-context))
(Hbounds (when ctxt (oref ctxt bounds)))
(target (when ctxt (car (reverse (oref ctxt prefix)))))
(tag (semantic-current-tag))
;; We use pulse, but we don't want the flashy version,
;; just the stable version.
(pulse-flag nil))
(when ctxt
;; Highlight the original tag? Protect against problems.
(condition-case nil
(semantic-idle-summary-maybe-highlight target)
(error nil))
;; Identify all hits in this current tag.
(when (semantic-tag-p target)
(semantic-symref-hits-in-region
target (lambda (start end prefix)
(when (/= start (car Hbounds))
(pulse-momentary-highlight-region
start end))
(semantic-throw-on-input 'symref-highlight)
)
(semantic-tag-start tag)
(semantic-tag-end tag)))
))))
;;; Completion Popup Mode
;;
;; This mode uses tooltips to display a (hopefully) short list of possible
;; completions available for the text under point. It provides
;; NO provision for actually filling in the values from those completions.
(defun semantic-idle-completion-list-default ()
"Calculate and display a list of completions."
(when (semantic-idle-summary-useful-context-p)
;; This mode can be fragile. Ignore problems.
;; If something doesn't do what you expect, run
;; the below command by hand instead.
(condition-case nil
(let (
;; Don't go loading in oodles of header libraries in
;; IDLE time.
(semanticdb-find-default-throttle
(if (featurep 'semantic/db-find)
(remq 'unloaded semanticdb-find-default-throttle)
nil))
)
;; Use idle version.
(semantic-complete-analyze-inline-idle)
)
(error nil))
))
(define-semantic-idle-service semantic-idle-completions
"Display a list of possible completions in a tooltip."
;; Add the ability to override sometime.
(semantic-idle-completion-list-default))
(provide 'semantic/idle)
;;; semantic-idle.el ends here

66
lisp/cedet/semantic/lex.el
View File

@ -315,6 +315,42 @@ PROPERTY set."
#'(lambda (symbol) (setq keywords (cons symbol keywords)))
property)
keywords))
;;; Inline functions:
(defvar semantic-lex-unterminated-syntax-end-function)
(defvar semantic-lex-analysis-bounds)
(defvar semantic-lex-end-point)
(defsubst semantic-lex-token-bounds (token)
"Fetch the start and end locations of the lexical token TOKEN.
Return a pair (START . END)."
(if (not (numberp (car (cdr token))))
(cdr (cdr token))
(cdr token)))
(defsubst semantic-lex-token-start (token)
"Fetch the start position of the lexical token TOKEN.
See also the function `semantic-lex-token'."
(car (semantic-lex-token-bounds token)))
(defsubst semantic-lex-token-end (token)
"Fetch the end position of the lexical token TOKEN.
See also the function `semantic-lex-token'."
(cdr (semantic-lex-token-bounds token)))
(defsubst semantic-lex-unterminated-syntax-detected (syntax)
"Inside a lexical analyzer, use this when unterminated syntax was found.
Argument SYNTAX indicates the type of syntax that is unterminated.
The job of this function is to move (point) to a new logical location
so that analysis can continue, if possible."
(goto-char
(funcall semantic-lex-unterminated-syntax-end-function
syntax
(car semantic-lex-analysis-bounds)
(cdr semantic-lex-analysis-bounds)
))
(setq semantic-lex-end-point (point)))
;;; Type table handling.
;;
@ -1012,23 +1048,6 @@ variable after calling `semantic-lex-push-token'."
See also the function `semantic-lex-token'."
(car token))
(defsubst semantic-lex-token-bounds (token)
"Fetch the start and end locations of the lexical token TOKEN.
Return a pair (START . END)."
(if (not (numberp (car (cdr token))))
(cdr (cdr token))
(cdr token)))
(defsubst semantic-lex-token-start (token)
"Fetch the start position of the lexical token TOKEN.
See also the function `semantic-lex-token'."
(car (semantic-lex-token-bounds token)))
(defsubst semantic-lex-token-end (token)
"Fetch the end position of the lexical token TOKEN.
See also the function `semantic-lex-token'."
(cdr (semantic-lex-token-bounds token)))
(defsubst semantic-lex-token-text (token)
"Fetch the text associated with the lexical token TOKEN.
See also the function `semantic-lex-token'."
@ -1084,19 +1103,6 @@ Optional argument DEPTH is the depth to scan into lists."
;; Created analyzers become variables with the code associated with them
;; as the symbol value. These analyzers are assembled into a lexer
;; to create new lexical analyzers.
;;
(defsubst semantic-lex-unterminated-syntax-detected (syntax)
"Inside a lexical analyzer, use this when unterminated syntax was found.
Argument SYNTAX indicates the type of syntax that is unterminated.
The job of this function is to move (point) to a new logical location
so that analysis can continue, if possible."
(goto-char
(funcall semantic-lex-unterminated-syntax-end-function
syntax
(car semantic-lex-analysis-bounds)
(cdr semantic-lex-analysis-bounds)
))
(setq semantic-lex-end-point (point)))
(defcustom semantic-lex-debug-analyzers nil
"Non nil means to debug analyzers with syntax protection.

677
lisp/cedet/semantic/texi.el Normal file
View File

@ -0,0 +1,677 @@
;;; texi.el --- Semantic details for Texinfo files
;;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 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:
;;
;; Parse Texinfo buffers using regular expressions. The core parser
;; engine is the function `semantic-texi-parse-headings'. The
;; parser plug-in is the function `semantic-texi-parse-region' that
;; overrides `semantic-parse-region'.
(require 'semantic)
(require 'semantic/format)
(require 'texinfo)
(eval-when-compile
(require 'semantic/db)
(require 'semantic/db-find)
(require 'semantic/ctxt)
(require 'semantic/imenu)
(require 'semantic/doc)
(require 'senator))
(defvar semantic-texi-super-regex
"^@\\(top\\|chapter\\|\\(sub\\)*section\\|unnumbered\\(\\(sub\\)*sec\\)?\\|\
\\(chap\\|\\(sub\\)+\\|major\\)?heading\\|appendix\\(\\(sub\\)*sec\\)?\\|\
centerchap\\|def\\(var\\|un\\|fn\\|opt\\)x?\\)"
"Regular expression used to find special sections in a Texinfo file.")
(defvar semantic-texi-name-field-list
'( ("defvar" . 1)
("defvarx" . 1)
("defun" . 1)
("defunx" . 1)
("defopt" . 1)
("deffn" . 2)
("deffnx" . 2)
)
"List of definition commands, and the field position.
The field position is the field number (based at 1) where the
name of this section is.")
;;; Code:
(defun semantic-texi-parse-region (&rest ignore)
"Parse the current texinfo buffer for semantic tags.
IGNORE any arguments, always parse the whole buffer.
Each tag returned is of the form:
(\"NAME\" section (:members CHILDREN))
or
(\"NAME\" def)
It is an override of 'parse-region and must be installed by the
function `semantic-install-function-overrides'."
(mapcar 'semantic-texi-expand-tag
(semantic-texi-parse-headings)))
(defun semantic-texi-parse-changes ()
"Parse changes in the current texinfo buffer."
;; NOTE: For now, just schedule a full reparse.
;; To be implemented later.
(semantic-parse-tree-set-needs-rebuild))
(defun semantic-texi-expand-tag (tag)
"Expand the texinfo tag TAG."
(let ((chil (semantic-tag-components tag)))
(if chil
(semantic-tag-put-attribute
tag :members (mapcar 'semantic-texi-expand-tag chil)))
(car (semantic--tag-expand tag))))
(defun semantic-texi-parse-headings ()
"Parse the current texinfo buffer for all semantic tags now."
(let ((pass1 nil))
;; First search and snarf.
(save-excursion
(goto-char (point-min))
(let ((semantic--progress-reporter
(make-progress-reporter
(format "Parsing %s..."
(file-name-nondirectory buffer-file-name))
(point-min) (point-max))))
(while (re-search-forward semantic-texi-super-regex nil t)
(setq pass1 (cons (match-beginning 0) pass1))
(progress-reporter-update semantic--progress-reporter (point)))
(progress-reporter-done semantic--progress-reporter)))
(setq pass1 (nreverse pass1))
;; Now, make some tags while creating a set of children.
(car (semantic-texi-recursive-combobulate-list pass1 0))
))
(defsubst semantic-texi-new-section-tag (name members start end)
"Create a semantic tag of class section.
NAME is the name of this section.
MEMBERS is a list of semantic tags representing the elements that make
up this section.
START and END define the location of data described by the tag."
(append (semantic-tag name 'section :members members)
(list start end)))
(defsubst semantic-texi-new-def-tag (name start end)
"Create a semantic tag of class def.
NAME is the name of this definition.
START and END define the location of data described by the tag."
(append (semantic-tag name 'def)
(list start end)))
(defun semantic-texi-set-endpoint (metataglist pnt)
"Set the end point of the first section tag in METATAGLIST to PNT.
METATAGLIST is a list of tags in the intermediate tag format used by the
texinfo parser. PNT is the new point to set."
(let ((metatag nil))
(while (and metataglist
(not (eq (semantic-tag-class (car metataglist)) 'section)))
(setq metataglist (cdr metataglist)))
(setq metatag (car metataglist))
(when metatag
(setcar (nthcdr (1- (length metatag)) metatag) pnt)
metatag)))
(defun semantic-texi-recursive-combobulate-list (sectionlist level)
"Rearrange SECTIONLIST to be a hierarchical tag list starting at LEVEL.
Return the rearranged new list, with all remaining tags from
SECTIONLIST starting at ELT 2. Sections not are not dealt with as soon as a
tag with greater section value than LEVEL is found."
(let ((newl nil)
(oldl sectionlist)
tag
)
(save-excursion
(catch 'level-jump
(while oldl
(goto-char (car oldl))
(if (looking-at "@\\(\\w+\\)")
(let* ((word (match-string 1))
(levelmatch (assoc word texinfo-section-list))
text begin tmp
)
;; Set begin to the right location
(setq begin (point))
;; Get out of here if there if we made it that far.
(if (and levelmatch (<= (car (cdr levelmatch)) level))
(progn
(when newl
(semantic-texi-set-endpoint newl begin))
(throw 'level-jump t)))
;; Recombobulate
(if levelmatch
(let ((end (match-end 1)))
;; Levels sometimes have a @node just in front.
;; That node statement should be included in the space
;; for this entry.
(save-excursion
(skip-chars-backward "\n \t")
(beginning-of-line)
(when (looking-at "@node\\>")
(setq begin (point))))
;; When there is a match, the descriptive text
;; consists of the rest of the line.
(goto-char end)
(skip-chars-forward " \t")
(setq text (buffer-substring-no-properties
(point)
(progn (end-of-line) (point))))
;; Next, recurse into the body to find the end.
(setq tmp (semantic-texi-recursive-combobulate-list
(cdr oldl) (car (cdr levelmatch))))
;; Build a tag
(setq tag (semantic-texi-new-section-tag
text (car tmp) begin (point)))
;; Before appending the newtag, update the previous tag
;; if it is a section tag.
(when newl
(semantic-texi-set-endpoint newl begin))
;; Append new tag to our master list.
(setq newl (cons tag newl))
;; continue
(setq oldl (cdr tmp))
)
;; No match means we have a def*, so get the name from
;; it based on the type of thingy we found.
(setq levelmatch (assoc word semantic-texi-name-field-list)
tmp (or (cdr levelmatch) 1))
(forward-sexp tmp)
(skip-chars-forward " \t")
(setq text (buffer-substring-no-properties
(point)
(progn (forward-sexp 1) (point))))
;; Seek the end of this definition
(goto-char begin)
(semantic-texi-forward-deffn)
(setq tag (semantic-texi-new-def-tag text begin (point))
newl (cons tag newl))
;; continue
(setq oldl (cdr oldl)))
)
(error "Problem finding section in semantic/texi parser"))
;; (setq oldl (cdr oldl))
)
;; When oldl runs out, force a new endpoint as point-max
(when (not oldl)
(semantic-texi-set-endpoint newl (point-max)))
))
(cons (nreverse newl) oldl)))
(defun semantic-texi-forward-deffn ()
"Move forward over one deffn type definition.
The cursor should be on the @ sign."
(when (looking-at "@\\(\\w+\\)")
(let* ((type (match-string 1))
(seek (concat "^@end\\s-+" (regexp-quote type))))
(re-search-forward seek nil t))))
(define-mode-local-override semantic-tag-components
texinfo-mode (tag)
"Return components belonging to TAG."
(semantic-tag-get-attribute tag :members))
;;; Overrides: Context Parsing
;;
;; How to treat texi as a language?
;;
(defvar semantic-texi-environment-regexp
(if (string-match texinfo-environment-regexp "@menu")
;; Make sure our Emacs has menus in it.
texinfo-environment-regexp
;; If no menus, then merge in the menu concept.
(when (string-match "cartouche" texinfo-environment-regexp)
(concat (substring texinfo-environment-regexp
0 (match-beginning 0))
"menu\\|"
(substring texinfo-environment-regexp
(match-beginning 0)))))
"Regular expression for matching texinfo enviroments.
uses `texinfo-environment-regexp', but makes sure that it
can handle the @menu environment.")
(define-mode-local-override semantic-up-context texinfo-mode ()
"Handle texinfo constructs which do not use parenthetical nesting."
(let ((done nil))
(save-excursion
(let ((parenthetical (semantic-up-context-default))
)
(when (not parenthetical)
;; We are in parenthises. Are they the types of parens
;; belonging to a texinfo construct?
(forward-word -1)
(when (looking-at "@\\w+{")
(setq done (point))))))
;; If we are not in a parenthetical node, then find a block instead.
;; Use the texinfo support to find block start/end constructs.
(save-excursion
(while (and (not done)
(re-search-backward semantic-texi-environment-regexp nil t))
;; For any hit, if we find an @end foo, then jump to the
;; matching @foo. If it is not an end, then we win!
(if (not (looking-at "@end\\s-+\\(\\w+\\)"))
(setq done (point))
;; Skip over this block
(let ((env (match-string 1)))
(re-search-backward (concat "@" env))))
))
;; All over, post what we find.
(if done
;; We found something, so use it.
(progn (goto-char done)
nil)
t)))
(define-mode-local-override semantic-beginning-of-context texinfo-mode (&optional point)
"Move to the beginning of the context surrounding POINT."
(if (semantic-up-context point)
;; If we can't go up, we can't do this either.
t
;; We moved, so now we need to skip into whatever this thing is.
(forward-word 1) ;; skip the command
(if (looking-at "\\s-*{")
;; In a short command. Go in.
(down-list 1)
;; An environment. Go to the next line.
(end-of-line)
(forward-char 1))
nil))
(define-mode-local-override semantic-ctxt-current-class-list
texinfo-mode (&optional point)
"Determine the class of tags that can be used at POINT.
For texinfo, there two possibilities returned.
1) 'function - for a call to a texinfo function
2) 'word - indicates an english word.
It would be nice to know function arguments too, but not today."
(let ((sym (semantic-ctxt-current-symbol)))
(if (and sym (= (aref (car sym) 0) ?@))
'(function)
'(word))))
;;; Overrides : Formatting
;;
;; Various override to better format texi tags.
;;
(define-mode-local-override semantic-format-tag-abbreviate
texinfo-mode (tag &optional parent color)
"Texinfo tags abbreviation."
(let ((class (semantic-tag-class tag))
(name (semantic-format-tag-name tag parent color))
)
(cond ((eq class 'function)
(concat name "{ }"))
(t (semantic-format-tag-abbreviate-default tag parent color)))
))
(define-mode-local-override semantic-format-tag-prototype
texinfo-mode (tag &optional parent color)
"Texinfo tags abbreviation."
(semantic-format-tag-abbreviate tag parent color))
;;; Texi Unique Features
;;
(defun semantic-tag-texi-section-text-bounds (tag)
"Get the bounds to the text of TAG.
The text bounds is the text belonging to this node excluding
the text of any child nodes, but including any defuns."
(let ((memb (semantic-tag-components tag)))
;; Members.. if one is a section, check it out.
(while (and memb (not (semantic-tag-of-class-p (car memb) 'section)))
(setq memb (cdr memb)))
;; No members? ... then a simple problem!
(if (not memb)
(semantic-tag-bounds tag)
;; Our end is their beginning...
(list (semantic-tag-start tag) (semantic-tag-start (car memb))))))
(defun semantic-texi-current-environment (&optional point)
"Return as a string the type of the current environment.
Optional argument POINT is where to look for the environment."
(save-excursion
(when point (goto-char (point)))
(while (and (or (not (looking-at semantic-texi-environment-regexp))
(looking-at "@end"))
(not (semantic-up-context)))
)
(when (looking-at semantic-texi-environment-regexp)
(match-string 1))))
;;; Analyzer
;;
(eval-when-compile
(require 'semantic/analyze))
(define-mode-local-override semantic-analyze-current-context
texinfo-mode (point)
"Analysis context makes no sense for texinfo. Return nil."
(let* ((prefixandbounds (semantic-ctxt-current-symbol-and-bounds (point)))
(prefix (car prefixandbounds))
(bounds (nth 2 prefixandbounds))
(prefixclass (semantic-ctxt-current-class-list))
)
(when prefix
(require 'semantic-analyze)
(semantic-analyze-context
"Context-for-texinfo"
:buffer (current-buffer)
:scope nil
:bounds bounds
:prefix prefix
:prefixtypes nil
:prefixclass prefixclass)
)
))
(defvar semantic-texi-command-completion-list
(append (mapcar (lambda (a) (car a)) texinfo-section-list)
(condition-case nil
texinfo-environments
(error
;; XEmacs doesn't use the above. Split up its regexp
(split-string texinfo-environment-regexp "\\\\|\\|\\^@\\\\(\\|\\\\)")
))
;; Is there a better list somewhere? Here are few
;; of the top of my head.
"anchor" "asis"
"bullet"
"code" "copyright"
"defun" "deffn" "defoption" "defvar" "dfn"
"emph" "end"
"ifinfo" "iftex" "inforef" "item" "itemx"
"kdb"
"node"
"ref"
"set" "setfilename" "settitle"
"value" "var"
"xref"
)
"List of commands that we might bother completing.")
(define-mode-local-override semantic-analyze-possible-completions
texinfo-mode (context)
"List smart completions at point.
Since texinfo is not a programming language the default version is not
useful. Insted, look at the current symbol. If it is a command
do primitive texinfo built ins. If not, use ispell to lookup words
that start with that symbol."
(let ((prefix (car (oref context :prefix)))
)
(cond ((member 'function (oref context :prefixclass))
;; Do completion for texinfo commands
(let* ((cmd (substring prefix 1))
(lst (all-completions
cmd semantic-texi-command-completion-list)))
(mapcar (lambda (f) (semantic-tag (concat "@" f) 'function))
lst))
)
((member 'word (oref context :prefixclass))
;; Do completion for words via ispell.
(require 'ispell)
(let ((word-list (lookup-words prefix)))
(mapcar (lambda (f) (semantic-tag f 'word)) word-list))
)
(t nil))
))
;;; Parser Setup
;;
(defun semantic-default-texi-setup ()
"Set up a buffer for parsing of Texinfo files."
;; This will use our parser.
(semantic-install-function-overrides
'((parse-region . semantic-texi-parse-region)
(parse-changes . semantic-texi-parse-changes)))
(setq semantic-parser-name "TEXI"
;; Setup a dummy parser table to enable parsing!
semantic--parse-table t
imenu-create-index-function 'semantic-create-imenu-index
semantic-command-separation-character "@"
semantic-type-relation-separator-character '(":")
semantic-symbol->name-assoc-list '((section . "Section")
(def . "Definition")
)
semantic-imenu-expandable-tag-classes '(section)
semantic-imenu-bucketize-file nil
semantic-imenu-bucketize-type-members nil
senator-step-at-start-end-tag-classes '(section)
semantic-stickyfunc-sticky-classes '(section)
)
(local-set-key [(f9)] 'semantic-texi-update-doc-from-texi)
)
(add-hook 'texinfo-mode-hook 'semantic-default-texi-setup)
;;; Special features of Texinfo tag streams
;;
;; This section provides specialized access into texinfo files.
;; Because texinfo files often directly refer to functions and programs
;; it is useful to access the texinfo file from the C code for document
;; maintainance.
(defun semantic-texi-associated-files (&optional buffer)
"Find texinfo files associated with BUFFER."
(save-excursion
(if buffer (set-buffer buffer))
(cond ((and (fboundp 'ede-documentation-files)
ede-minor-mode (ede-current-project))
;; When EDE is active, ask it.
(ede-documentation-files)
)
((and (featurep 'semanticdb) (semanticdb-minor-mode-p))
;; See what texinfo files we have loaded in the database
(let ((tabs (semanticdb-get-database-tables
semanticdb-current-database))
(r nil))
(while tabs
(if (eq (oref (car tabs) major-mode) 'texinfo-mode)
(setq r (cons (oref (car tabs) file) r)))
(setq tabs (cdr tabs)))
r))
(t
(directory-files default-directory nil "\\.texi$"))
)))
;; Turns out this might not be useful.
;; Delete later if that is true.
(defun semantic-texi-find-documentation (name &optional type)
"Find the function or variable NAME of TYPE in the texinfo source.
NAME is a string representing some functional symbol.
TYPE is a string, such as \"variable\" or \"Command\" used to find
the correct definition in case NAME qualifies as several things.
When this function exists, POINT is at the definition.
If the doc was not found, an error is thrown.
Note: TYPE not yet implemented."
(let ((f (semantic-texi-associated-files))
stream match)
(while (and f (not match))
(unless stream
(with-current-buffer (find-file-noselect (car f))
(setq stream (semantic-fetch-tags))))
(setq match (semantic-find-first-tag-by-name name stream))
(when match
(set-buffer (semantic-tag-buffer match))
(goto-char (semantic-tag-start match)))
(setq f (cdr f)))))
(defun semantic-texi-update-doc-from-texi (&optional tag)
"Update the documentation in the texinfo deffn class tag TAG.
The current buffer must be a texinfo file containing TAG.
If TAG is nil, determine a tag based on the current position."
(interactive)
(unless (or (featurep 'semanticdb) (semanticdb-minor-mode-p))
(error "Texinfo updating only works when `semanticdb' is being used"))
(semantic-fetch-tags)
(unless tag
(beginning-of-line)
(setq tag (semantic-current-tag)))
(unless (semantic-tag-of-class-p tag 'def)
(error "Only deffns (or defun or defvar) can be updated"))
(let* ((name (semantic-tag-name tag))
(tags (semanticdb-strip-find-results
(semanticdb-with-match-any-mode
(semanticdb-brute-deep-find-tags-by-name name))
'name))
(docstring nil)
(docstringproto nil)
(docstringvar nil)
(doctag nil)
(doctagproto nil)
(doctagvar nil)
)
(save-excursion
(while (and tags (not docstring))
(let ((sourcetag (car tags)))
;; There could be more than one! Come up with a better
;; solution someday.
(when (semantic-tag-buffer sourcetag)
(set-buffer (semantic-tag-buffer sourcetag))
(unless (eq major-mode 'texinfo-mode)
(cond ((semantic-tag-get-attribute sourcetag :prototype-flag)
;; If we found a match with doc that is a prototype, then store
;; that, but don't exit till we find the real deal.
(setq docstringproto (semantic-documentation-for-tag sourcetag)
doctagproto sourcetag))
((eq (semantic-tag-class sourcetag) 'variable)
(setq docstringvar (semantic-documentation-for-tag sourcetag)
doctagvar sourcetag))
((semantic-tag-get-attribute sourcetag :override-function-flag)
nil)
(t
(setq docstring (semantic-documentation-for-tag sourcetag))))
(setq doctag (if docstring sourcetag nil))))
(setq tags (cdr tags)))))
;; If we found a prototype of the function that has some doc, but not the
;; actual function, lets make due with that.
(if (not docstring)
(cond ((stringp docstringvar)
(setq docstring docstringvar
doctag doctagvar))
((stringp docstringproto)
(setq docstring docstringproto
doctag doctagproto))))
;; Test for doc string
(unless docstring
(error "Could not find documentation for %s" (semantic-tag-name tag)))
;; If we have a string, do the replacement.
(delete-region (semantic-tag-start tag)
(semantic-tag-end tag))
;; Use useful functions from the docaument library.
(require 'document)
(document-insert-texinfo doctag (semantic-tag-buffer doctag))
))
(defun semantic-texi-update-doc-from-source (&optional tag)
"Update the documentation for the source TAG.
The current buffer must be a non-texinfo source file containing TAG.
If TAG is nil, determine the tag based on the current position.
The current buffer must include TAG."
(interactive)
(when (eq major-mode 'texinfo-mode)
(error "Not a source file"))
(semantic-fetch-tags)
(unless tag
(setq tag (semantic-current-tag)))
(unless (semantic-documentation-for-tag tag)
(error "Cannot find interesting documentation to use for %s"
(semantic-tag-name tag)))
(let* ((name (semantic-tag-name tag))
(texi (semantic-texi-associated-files))
(doctag nil)
(docbuff nil))
(while (and texi (not doctag))
(set-buffer (find-file-noselect (car texi)))
(setq doctag (car (semantic-deep-find-tags-by-name
name (semantic-fetch-tags)))
docbuff (if doctag (current-buffer) nil))
(setq texi (cdr texi)))
(unless doctag
(error "Tag %s is not yet documented. Use the `document' command"
name))
;; Ok, we should have everything we need. Do the deed.
(if (get-buffer-window docbuff)
(set-buffer docbuff)
(switch-to-buffer docbuff))
(goto-char (semantic-tag-start doctag))
(delete-region (semantic-tag-start doctag)
(semantic-tag-end doctag))
;; Use useful functions from the document library.
(require 'document)
(document-insert-texinfo tag (semantic-tag-buffer tag))
))
(defun semantic-texi-update-doc (&optional tag)
"Update the documentation for TAG.
If the current buffer is a texinfo file, then find the source doc, and
update it. If the current buffer is a source file, then get the
documentation for this item, find the existing doc in the associated
manual, and update that."
(interactive)
(cond ((eq major-mode 'texinfo-mode)
(semantic-texi-update-doc-from-texi tag))
(t
(semantic-texi-update-doc-from-source tag))))
(defun semantic-texi-goto-source (&optional tag)
"Jump to the source for the definition in the texinfo file TAG.
If TAG is nil, it is derived from the deffn under POINT."
(interactive)
(unless (or (featurep 'semanticdb) (semanticdb-minor-mode-p))
(error "Texinfo updating only works when `semanticdb' is being used"))
(semantic-fetch-tags)
(unless tag
(beginning-of-line)
(setq tag (semantic-current-tag)))
(unless (semantic-tag-of-class-p tag 'def)
(error "Only deffns (or defun or defvar) can be updated"))
(let* ((name (semantic-tag-name tag))
(tags (semanticdb-fast-strip-find-results
(semanticdb-with-match-any-mode
(semanticdb-brute-deep-find-tags-by-name name nil 'name))
))
(done nil)
)
(save-excursion
(while (and tags (not done))
(set-buffer (semantic-tag-buffer (car tags)))
(unless (eq major-mode 'texinfo-mode)
(switch-to-buffer (semantic-tag-buffer (car tags)))
(goto-char (semantic-tag-start (car tags)))
(setq done t))
(setq tags (cdr tags)))
(if (not done)
(error "Could not find tag for %s" (semantic-tag-name tag)))
)))
(provide 'semantic/texi)
;;; semantic-texi.el ends here