lisp/cedet/semantic/analyze/fcn.el

   1 ;;; semantic/analyze/fcn.el --- Analyzer support functions.
   2
   3 ;; Copyright (C) 2007-2012 Free Software Foundation, Inc.
   4
   5 ;; Author: Eric M. Ludlam <zappo@gnu.org>
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23 ;;
  24 ;; Analyzer support functions.
  25
  26 ;;; Code:
  27
  28 (require 'semantic)
  29 (eval-when-compile (require 'semantic/find))
  30
  31 (declare-function semanticdb-typecache-merge-streams "semantic/db-typecache")
  32 (declare-function semantic-scope-find "semantic/scope")
  33 (declare-function semantic-scope-set-typecache "semantic/scope")
  34 (declare-function semantic-scope-tag-get-scope "semantic/scope")
  35
  36 ;;; Small Mode Specific Options
  37 ;;
  38 ;; These queries allow a major mode to help the analyzer make decisions.
  39 ;;
  40 (define-overloadable-function semantic-analyze-tag-prototype-p (tag)
  41   "Non-nil if TAG is a prototype."
  42   )
  43
  44 (defun semantic-analyze-tag-prototype-p-default (tag)
  45   "Non-nil if TAG is a prototype."
  46   (let ((p (semantic-tag-get-attribute tag :prototype-flag)))
  47     (cond
  48      ;; Trust the parser author.
  49      (p p)
  50      ;; Empty types might be a prototype.
  51      ((eq (semantic-tag-class tag) 'type)
  52       (not (semantic-tag-type-members tag)))
  53      ;; No other heuristics.
  54      (t nil))
  55     ))
  56
  57 ;;------------------------------------------------------------
  58
  59 (define-overloadable-function semantic-analyze-split-name (name)
  60   "Split a tag NAME into a sequence.
  61 Sometimes NAMES are gathered from the parser that are compounded,
  62 such as in C++ where foo::bar means:
  63   \"The class BAR in the namespace FOO.\"
  64 Return the string NAME for no change, or a list if it needs to be split.")
  65
  66 (defun semantic-analyze-split-name-default (name)
  67   "Don't split up NAME by default."
  68   name)
  69
  70 (define-overloadable-function semantic-analyze-unsplit-name (namelist)
  71   "Assemble a NAMELIST into a string representing a compound name.
  72 Return the string representing the compound name.")
  73
  74 (defun semantic-analyze-unsplit-name-default (namelist)
  75   "Concatenate the names in NAMELIST with a . between."
  76   (mapconcat 'identity namelist "."))
  77
  78 ;;; SELECTING
  79 ;;
  80 ;; If you narrow things down to a list of tags that all mean
  81 ;; the same thing, how to you pick one?  Select or merge.
  82 ;;
  83
  84 (defun semantic-analyze-select-best-tag (sequence &optional tagclass)
  85   "For a SEQUENCE of tags, all with good names, pick the best one.
  86 If SEQUENCE is made up of namespaces, merge the namespaces together.
  87 If SEQUENCE has several prototypes, find the non-prototype.
  88 If SEQUENCE has some items w/ no type information, find the one with a type.
  89 If SEQUENCE is all prototypes, or has no prototypes, get the first one.
  90 Optional TAGCLASS indicates to restrict the return to only
  91 tags of TAGCLASS."
  92
  93   ;; If there is a srew up and we get just one tag.. massage over it.
  94   (when (semantic-tag-p sequence)
  95     (setq sequence (list sequence)))
  96
  97   ;; Filter out anything not of TAGCLASS
  98   (when tagclass
  99     (setq sequence (semantic-find-tags-by-class tagclass sequence)))
 100
 101   (if (< (length sequence) 2)
 102       ;; If the remaining sequence is 1 tag or less, just return it
 103       ;; and skip the rest of this mumbo-jumbo.
 104       (car sequence)
 105
 106     ;; 1)
 107     ;; This step will eliminate a vast majority of the types,
 108     ;; in addition to merging namespaces together.
 109     ;;
 110     ;; 2)
 111     ;; It will also remove prototypes.
 112     (require 'semantic/db-typecache)
 113     (setq sequence (semanticdb-typecache-merge-streams sequence nil))
 114
 115     (if (< (length sequence) 2)
 116         ;; If the remaining sequence after the merge is 1 tag or less,
 117         ;; just return it and skip the rest of this mumbo-jumbo.
 118         (car sequence)
 119
 120       (let ((best nil)
 121             (notypeinfo nil)
 122             )
 123         (while (and (not best) sequence)
 124
 125           ;; 3) select a non-prototype.
 126           (if (not (semantic-tag-type (car sequence)))
 127               (setq notypeinfo (car sequence))
 128
 129             (setq best (car sequence))
 130             )
 131
 132           (setq sequence (cdr sequence)))
 133
 134         ;; Select the best, or at least the prototype.
 135         (or best notypeinfo)))))
 136
 137 ;;; Tag Finding
 138 ;;
 139 ;; Mechanism for lookup up tags by name.
 140 ;;
 141 (defun semantic-analyze-find-tags-by-prefix (prefix)
 142   ;; @todo - only used in semantic-complete.  Find something better?
 143   "Attempt to find a tag with PREFIX.
 144 This is a wrapper on top of semanticdb, and semantic search functions.
 145 Almost all searches use the same arguments."
 146   (if (and (fboundp 'semanticdb-minor-mode-p)
 147            (semanticdb-minor-mode-p))
 148       ;; Search the database & concatenate all matches together.
 149       (semanticdb-strip-find-results
 150        (semanticdb-find-tags-for-completion prefix)
 151        'name)
 152     ;; Search just this file because there is no DB available.
 153     (semantic-find-tags-for-completion
 154      prefix (current-buffer))))
 155
 156 ;;; Finding Datatypes
 157 ;;
 158
 159 (define-overloadable-function semantic-analyze-dereference-metatype (type scope &optional type-declaration)
 160   ;; todo - move into typecache!!
 161   "Return a concrete type tag based on input TYPE tag.
 162 A concrete type is an actual declaration of a memory description,
 163 such as a structure, or class.  A meta type is an alias,
 164 or a typedef in C or C++.  If TYPE is concrete, it
 165 is returned.  If it is a meta type, it will return the concrete
 166 type defined by TYPE.
 167 The default behavior always returns TYPE.
 168 Override functions need not return a real semantic tag.
 169 Just a name, or short tag will be ok.  It will be expanded here.
 170 SCOPE is the scope object with additional items in which to search for names."
 171   (catch 'default-behavior
 172     (let* ((ans-tuple (:override
 173                        ;; Nothing fancy, just return type by default.
 174                        (throw 'default-behavior (list type type-declaration))))
 175            (ans-type (car ans-tuple))
 176            (ans-type-declaration (cadr ans-tuple)))
 177        (list (semantic-analyze-dereference-metatype-1 ans-type scope) ans-type-declaration))))
 178
 179 ;; Finding a data type by name within a project.
 180 ;;
 181 (defun semantic-analyze-type-to-name (type)
 182   "Get the name of TAG's type.
 183 The TYPE field in a tag can be nil (return nil)
 184 or a string, or a non-positional tag."
 185   (cond ((semantic-tag-p type)
 186          (semantic-tag-name type))
 187         ((stringp type)
 188          type)
 189         ((listp type)
 190          (car type))
 191         (t nil)))
 192
 193 (defun semantic-analyze-tag-type (tag &optional scope nometaderef)
 194   "Return the semantic tag for a type within the type of TAG.
 195 TAG can be a variable, function or other type of tag.
 196 The behavior of TAG's type is defined by `semantic-analyze-type'.
 197 Optional SCOPE represents a calculated scope in which the
 198 types might be found.  This can be nil.
 199 If NOMETADEREF, then do not dereference metatypes.  This is
 200 used by the analyzer debugger."
 201   (semantic-analyze-type (semantic-tag-type tag) scope nometaderef))
 202
 203 (defun semantic-analyze-type (type-declaration &optional scope nometaderef)
 204   "Return the semantic tag for TYPE-DECLARATION.
 205 TAG can be a variable, function or other type of tag.
 206 The type of tag (such as a class or struct) is a name.
 207 Lookup this name in database, and return all slots/fields
 208 within that types field.  Also handles anonymous types.
 209 Optional SCOPE represents a calculated scope in which the
 210 types might be found.  This can be nil.
 211 If NOMETADEREF, then do not dereference metatypes.  This is
 212 used by the analyzer debugger."
 213   (require 'semantic/scope)
 214   (let ((name nil)
 215         (typetag nil)
 216         )
 217
 218     ;; Is it an anonymous type?
 219     (if (and type-declaration
 220              (semantic-tag-p type-declaration)
 221              (semantic-tag-of-class-p type-declaration 'type)
 222              (not (semantic-analyze-tag-prototype-p type-declaration))
 223              )
 224         ;; We have an anonymous type for TAG with children.
 225         ;; Use this type directly.
 226         (if nometaderef
 227             type-declaration
 228           (semantic-analyze-dereference-metatype-stack
 229            type-declaration scope type-declaration))
 230
 231       ;; Not an anonymous type.  Look up the name of this type
 232       ;; elsewhere, and report back.
 233       (setq name (semantic-analyze-type-to-name type-declaration))
 234
 235       (if (and name (not (string= name "")))
 236           (progn
 237             ;; Find a type of that name in scope.
 238             (setq typetag (and scope (semantic-scope-find name 'type scope)))
 239             ;; If no typetag, try the typecache
 240             (when (not typetag)
 241               (setq typetag (semanticdb-typecache-find name))))
 242
 243         ;; No name to look stuff up with.
 244         (error "Semantic tag %S has no type information"
 245                (semantic-tag-name type-declaration)))
 246
 247       ;; Handle lists of tags.
 248       (when (and (consp typetag) (semantic-tag-p (car typetag)))
 249         (setq typetag (semantic-analyze-select-best-tag typetag 'type))
 250         )
 251
 252       ;; We now have a tag associated with the type.  We need to deref it.
 253       ;;
 254       ;; If we were asked not to (ie - debugger) push the typecache anyway.
 255       (if nometaderef
 256           typetag
 257         (unwind-protect
 258             (progn
 259               (semantic-scope-set-typecache
 260                scope (semantic-scope-tag-get-scope typetag))
 261               (semantic-analyze-dereference-metatype-stack typetag scope type-declaration)
 262               )
 263           (semantic-scope-set-typecache scope nil)
 264           )))))
 265
 266 (defun semantic-analyze-dereference-metatype-stack (type scope &optional type-declaration)
 267   "Dereference metatypes repeatedly until we hit a real TYPE.
 268 Uses `semantic-analyze-dereference-metatype'.
 269 Argument SCOPE is the scope object with additional items in which to search.
 270 Optional argument TYPE-DECLARATION is how TYPE was found referenced."
 271   (let ((lasttype type)
 272         (lasttypedeclaration type-declaration)
 273         (nexttype (semantic-analyze-dereference-metatype type scope type-declaration))
 274         (idx 0))
 275     (catch 'metatype-recursion
 276       (while (and nexttype (not (eq (car nexttype) lasttype)))
 277         (setq lasttype (car nexttype)
 278               lasttypedeclaration (cadr nexttype))
 279         (setq nexttype (semantic-analyze-dereference-metatype lasttype scope lasttypedeclaration))
 280         (setq idx (1+ idx))
 281         (when (> idx 20) (message "Possible metatype recursion for %S"
 282                                   (semantic-tag-name lasttype))
 283               (throw 'metatype-recursion nil))
 284         ))
 285     lasttype))
 286
 287 ;; @ TODO - the typecache can also return a stack of scope names.
 288
 289 (defun semantic-analyze-dereference-metatype-1 (ans scope)
 290   "Do extra work after dereferencing a metatype.
 291 ANS is the answer from the language specific query.
 292 SCOPE is the current scope."
 293   (require 'semantic/scope)
 294   ;; If ANS is a string, or if ANS is a short tag, we
 295   ;; need to do some more work to look it up.
 296   (if (stringp ans)
 297       ;; The metatype is just a string... look it up.
 298       (or (and scope (car-safe
 299                       ;; @todo - should this be `find the best one'?
 300                       (semantic-scope-find ans 'type scope)))
 301           (let ((tcsans nil))
 302             (prog1
 303                 (setq tcsans
 304                       (semanticdb-typecache-find ans))
 305               ;; While going through the metatype, if we have
 306               ;; a scope, push our new cache in.
 307               (when scope
 308                 (semantic-scope-set-typecache
 309                  scope (semantic-scope-tag-get-scope tcsans))
 310                 ))
 311             ))
 312     (when (and (semantic-tag-p ans)
 313                (eq (semantic-tag-class ans) 'type))
 314       ;; We have a tag.
 315       (if (semantic-analyze-tag-prototype-p ans)
 316           ;; It is a prototype.. find the real one.
 317           (or (and scope
 318                    (car-safe
 319                     (semantic-scope-find (semantic-tag-name ans)
 320                                          'type scope)))
 321               (let ((tcsans nil))
 322                 (prog1
 323                     (setq tcsans
 324                           (semanticdb-typecache-find (semantic-tag-name ans)))
 325                   ;; While going through the metatype, if we have
 326                   ;; a scope, push our new cache in.
 327                   (when scope
 328                     (semantic-scope-set-typecache
 329                      scope (semantic-scope-tag-get-scope tcsans))
 330                     ))))
 331         ;; We have a tag, and it is not a prototype.
 332         ans))
 333     ))
 334
 335 (provide 'semantic/analyze/fcn)
 336
 337 ;;; semantic/analyze/fcn.el ends here