Mercurial > emacs
diff lisp/cedet/semantic/analyze/fcn.el @ 104421:b66bb908c129
cedet/semantic/debug.el,
cedet/semantic/doc.el,
cedet/semantic/tag-write.el,
cedet/semantic/analyze/complete.el,
cedet/semantic/analyze/debug.el,
cedet/semantic/analyze/fcn.el,
cedet/semantic/analyze/refs.el: New files.
author | Chong Yidong <cyd@stupidchicken.com> |
---|---|
date | Sat, 29 Aug 2009 19:45:47 +0000 |
parents | |
children | 2bf481006ba4 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/analyze/fcn.el Sat Aug 29 19:45:47 2009 +0000 @@ -0,0 +1,325 @@ +;;; semantic/analyze/fcn.el --- Analyzer support functions. + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Analyzer support functions. + +;;; Code: + +;;; Small Mode Specific Options +;; +;; These queries allow a major mode to help the analyzer make decisions. +;; +(define-overloadable-function semantic-analyze-tag-prototype-p (tag) + "Non-nil if TAG is a prototype." + ) + +(defun semantic-analyze-tag-prototype-p-default (tag) + "Non-nil if TAG is a prototype." + (let ((p (semantic-tag-get-attribute tag :prototype-flag))) + (cond + ;; Trust the parser author. + (p p) + ;; Empty types might be a prototype. + ((eq (semantic-tag-class tag) 'type) + (not (semantic-tag-type-members tag))) + ;; No other heuristics. + (t nil)) + )) + +;;------------------------------------------------------------ + +(define-overloadable-function semantic-analyze-split-name (name) + "Split a tag NAME into a sequence. +Sometimes NAMES are gathered from the parser that are compounded, +such as in C++ where foo::bar means: + \"The class BAR in the namespace FOO.\" +Return the string NAME for no change, or a list if it needs to be split.") + +(defun semantic-analyze-split-name-default (name) + "Don't split up NAME by default." + name) + +(define-overloadable-function semantic-analyze-unsplit-name (namelist) + "Assemble a NAMELIST into a string representing a compound name. +Return the string representing the compound name.") + +(defun semantic-analyze-unsplit-name-default (namelist) + "Concatenate the names in NAMELIST with a . between." + (mapconcat 'identity namelist ".")) + +;;; SELECTING +;; +;; If you narrow things down to a list of tags that all mean +;; the same thing, how to you pick one? Select or merge. +;; + +(defun semantic-analyze-select-best-tag (sequence &optional tagclass) + "For a SEQUENCE of tags, all with good names, pick the best one. +If SEQUENCE is made up of namespaces, merge the namespaces together. +If SEQUENCE has several prototypes, find the non-prototype. +If SEQUENCE has some items w/ no type information, find the one with a type. +If SEQUENCE is all prototypes, or has no prototypes, get the first one. +Optional TAGCLASS indicates to restrict the return to only +tags of TAGCLASS." + + ;; If there is a srew up and we get just one tag.. massage over it. + (when (semantic-tag-p sequence) + (setq sequence (list sequence))) + + ;; Filter out anything not of TAGCLASS + (when tagclass + (setq sequence (semantic-find-tags-by-class tagclass sequence))) + + (if (< (length sequence) 2) + ;; If the remaining sequence is 1 tag or less, just return it + ;; and skip the rest of this mumbo-jumbo. + (car sequence) + + ;; 1) + ;; This step will eliminate a vast majority of the types, + ;; in addition to merging namespaces together. + ;; + ;; 2) + ;; It will also remove prototypes. + (setq sequence (semanticdb-typecache-merge-streams sequence nil)) + + (if (< (length sequence) 2) + ;; If the remaining sequence after the merge is 1 tag or less, + ;; just return it and skip the rest of this mumbo-jumbo. + (car sequence) + + (let ((best nil) + (notypeinfo nil) + ) + (while (and (not best) sequence) + + ;; 3) select a non-prototype. + (if (not (semantic-tag-type (car sequence))) + (setq notypeinfo (car sequence)) + + (setq best (car sequence)) + ) + + (setq sequence (cdr sequence))) + + ;; Select the best, or at least the prototype. + (or best notypeinfo))))) + +;;; Tag Finding +;; +;; Mechanism for lookup up tags by name. +;; +(defun semantic-analyze-find-tags-by-prefix (prefix) + ;; @todo - only used in semantic-complete. Find something better? + "Attempt to find a tag with PREFIX. +This is a wrapper on top of semanticdb, and semantic search functions. +Almost all searches use the same arguments." + (if (and (fboundp 'semanticdb-minor-mode-p) + (semanticdb-minor-mode-p)) + ;; Search the database & concatenate all matches together. + (semanticdb-strip-find-results + (semanticdb-find-tags-for-completion prefix) + 'name) + ;; Search just this file because there is no DB available. + (semantic-find-tags-for-completion + prefix (current-buffer)))) + +;;; Finding Datatypes +;; +;; Finding a data type by name within a project. +;; +(defun semantic-analyze-type-to-name (type) + "Get the name of TAG's type. +The TYPE field in a tag can be nil (return nil) +or a string, or a non-positional tag." + (cond ((semantic-tag-p type) + (semantic-tag-name type)) + ((stringp type) + type) + ((listp type) + (car type)) + (t nil))) + +(defun semantic-analyze-tag-type (tag &optional scope nometaderef) + "Return the semantic tag for a type within the type of TAG. +TAG can be a variable, function or other type of tag. +The behavior of TAG's type is defined by `semantic-analyze-type'. +Optional SCOPE represents a calculated scope in which the +types might be found. This can be nil. +If NOMETADEREF, then do not dereference metatypes. This is +used by the analyzer debugger." + (semantic-analyze-type (semantic-tag-type tag) scope nometaderef)) + +(defun semantic-analyze-type (type-declaration &optional scope nometaderef) + "Return the semantic tag for TYPE-DECLARATION. +TAG can be a variable, function or other type of tag. +The type of tag (such as a class or struct) is a name. +Lookup this name in database, and return all slots/fields +within that types field. Also handles anonymous types. +Optional SCOPE represents a calculated scope in which the +types might be found. This can be nil. +If NOMETADEREF, then do not dereference metatypes. This is +used by the analyzer debugger." + (let ((name nil) + (typetag nil) + ) + + ;; Is it an anonymous type? + (if (and type-declaration + (semantic-tag-p type-declaration) + (semantic-tag-of-class-p type-declaration 'type) + (not (semantic-analyze-tag-prototype-p type-declaration)) + ) + ;; We have an anonymous type for TAG with children. + ;; Use this type directly. + (if nometaderef + type-declaration + (semantic-analyze-dereference-metatype-stack + type-declaration scope type-declaration)) + + ;; Not an anonymous type. Look up the name of this type + ;; elsewhere, and report back. + (setq name (semantic-analyze-type-to-name type-declaration)) + + (if (and name (not (string= name ""))) + (progn + ;; Find a type of that name in scope. + (setq typetag (and scope (semantic-scope-find name 'type scope))) + ;; If no typetag, try the typecache + (when (not typetag) + (setq typetag (semanticdb-typecache-find name)))) + + ;; No name to look stuff up with. + (error "Semantic tag %S has no type information" + (semantic-tag-name type-declaration))) + + ;; Handle lists of tags. + (when (and (consp typetag) (semantic-tag-p (car typetag))) + (setq typetag (semantic-analyze-select-best-tag typetag 'type)) + ) + + ;; We now have a tag associated with the type. We need to deref it. + ;; + ;; If we were asked not to (ie - debugger) push the typecache anyway. + (if nometaderef + typetag + (unwind-protect + (progn + (semantic-scope-set-typecache + scope (semantic-scope-tag-get-scope typetag)) + (semantic-analyze-dereference-metatype-stack typetag scope type-declaration) + ) + (semantic-scope-set-typecache scope nil) + ))))) + +(defun semantic-analyze-dereference-metatype-stack (type scope &optional type-declaration) + "Dereference metatypes repeatedly until we hit a real TYPE. +Uses `semantic-analyze-dereference-metatype'. +Argument SCOPE is the scope object with additional items in which to search. +Optional argument TYPE-DECLARATION is how TYPE was found referenced." + (let ((lasttype type) + (lasttypedeclaration type-declaration) + (nexttype (semantic-analyze-dereference-metatype type scope type-declaration)) + (idx 0)) + (catch 'metatype-recursion + (while (and nexttype (not (eq (car nexttype) lasttype))) + (setq lasttype (car nexttype) + lasttypedeclaration (cadr nexttype)) + (setq nexttype (semantic-analyze-dereference-metatype lasttype scope lasttypedeclaration)) + (setq idx (1+ idx)) + (when (> idx 20) (message "Possible metatype recursion for %S" + (semantic-tag-name lasttype)) + (throw 'metatype-recursion nil)) + )) + lasttype)) + +(define-overloadable-function semantic-analyze-dereference-metatype (type scope &optional type-declaration) + ;; todo - move into typecahe!! + "Return a concrete type tag based on input TYPE tag. +A concrete type is an actual declaration of a memory description, +such as a structure, or class. A meta type is an alias, +or a typedef in C or C++. If TYPE is concrete, it +is returned. If it is a meta type, it will return the concrete +type defined by TYPE. +The default behavior always returns TYPE. +Override functions need not return a real semantic tag. +Just a name, or short tag will be ok. It will be expanded here. +SCOPE is the scope object with additional items in which to search for names." + (catch 'default-behavior + (let* ((ans-tuple (:override + ;; Nothing fancy, just return type by default. + (throw 'default-behavior (list type type-declaration)))) + (ans-type (car ans-tuple)) + (ans-type-declaration (cadr ans-tuple))) + (list (semantic-analyze-dereference-metatype-1 ans-type scope) ans-type-declaration)))) + +;; @ TODO - the typecache can also return a stack of scope names. + +(defun semantic-analyze-dereference-metatype-1 (ans scope) + "Do extra work after dereferencing a metatype. +ANS is the answer from the the language specific query. +SCOPE is the current scope." + ;; If ANS is a string, or if ANS is a short tag, we + ;; need to do some more work to look it up. + (if (stringp ans) + ;; The metatype is just a string... look it up. + (or (and scope (car-safe + ;; @todo - should this be `find the best one'? + (semantic-scope-find ans 'type scope))) + (let ((tcsans nil)) + (prog1 + (setq tcsans + (semanticdb-typecache-find ans)) + ;; While going through the metatype, if we have + ;; a scope, push our new cache in. + (when scope + (semantic-scope-set-typecache + scope (semantic-scope-tag-get-scope tcsans)) + )) + )) + (when (and (semantic-tag-p ans) + (eq (semantic-tag-class ans) 'type)) + ;; We have a tag. + (if (semantic-analyze-tag-prototype-p ans) + ;; It is a prototype.. find the real one. + (or (and scope + (car-safe + (semantic-scope-find (semantic-tag-name ans) + 'type scope))) + (let ((tcsans nil)) + (prog1 + (setq tcsans + (semanticdb-typecache-find (semantic-tag-name ans))) + ;; While going through the metatype, if we have + ;; a scope, push our new cache in. + (when scope + (semantic-scope-set-typecache + scope (semantic-scope-tag-get-scope tcsans)) + )))) + ;; We have a tag, and it is not a prototype. + ans)) + )) + +(provide 'semantic/analyze/fcn) + +;;; semantic/analyze/fcn.el ends here