lisp/cedet/semantic/analyze/fcn.el

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