lisp/cedet/semantic/analyze/fcn.el

   1 ;;; semantic/analyze/fcn.el --- Analyzer support functions.
   2
   3 ;; Copyright (C) 2007-2014 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          (if (semantic-tag-named-parent type)
 169              (semantic-analyze-unsplit-name `(,(semantic-tag-named-parent type)
 170                                               ,(semantic-tag-name type)))
 171            (semantic-tag-name type)))
 172         ((stringp type)
 173          type)
 174         ((listp type)
 175          (car type))
 176         (t nil)))
 177
 178 (defun semantic-analyze-tag-type (tag &optional scope nometaderef)
 179   "Return the semantic tag for a type within the type of TAG.
 180 TAG can be a variable, function or other type of tag.
 181 The behavior of TAG's type is defined by `semantic-analyze-type'.
 182 Optional SCOPE represents a calculated scope in which the
 183 types might be found.  This can be nil.
 184 If NOMETADEREF, then do not dereference metatypes.  This is
 185 used by the analyzer debugger."
 186   (semantic-analyze-type (semantic-tag-type tag) scope nometaderef))
 187
 188 (defun semantic-analyze-type (type-declaration &optional scope nometaderef)
 189   "Return the semantic tag for TYPE-DECLARATION.
 190 TAG can be a variable, function or other type of tag.
 191 The type of tag (such as a class or struct) is a name.
 192 Lookup this name in database, and return all slots/fields
 193 within that types field.  Also handles anonymous types.
 194 Optional SCOPE represents a calculated scope in which the
 195 types might be found.  This can be nil.
 196 If NOMETADEREF, then do not dereference metatypes.  This is
 197 used by the analyzer debugger."
 198   (require 'semantic/scope)
 199   (let ((name nil)
 200         (typetag nil)
 201         )
 202
 203     ;; Is it an anonymous type?
 204     (if (and type-declaration
 205              (semantic-tag-p type-declaration)
 206              (semantic-tag-of-class-p type-declaration 'type)
 207              (not (semantic-tag-prototype-p type-declaration))
 208              )
 209         ;; We have an anonymous type for TAG with children.
 210         ;; Use this type directly.
 211         (if nometaderef
 212             type-declaration
 213           (semantic-analyze-dereference-metatype-stack
 214            type-declaration scope type-declaration))
 215
 216       ;; Not an anonymous type.  Look up the name of this type
 217       ;; elsewhere, and report back.
 218       (setq name (semantic-analyze-type-to-name type-declaration))
 219
 220       (if (and name (not (string= name "")))
 221           (progn
 222             ;; Find a type of that name in scope.
 223             (setq typetag (and scope (semantic-scope-find name 'type scope)))
 224             ;; If no typetag, try the typecache
 225             (when (not typetag)
 226               (setq typetag (semanticdb-typecache-find name))))
 227
 228         ;; No name to look stuff up with.
 229         (error "Semantic tag %S has no type information"
 230                (semantic-tag-name type-declaration)))
 231
 232       ;; Handle lists of tags.
 233       (when (and (consp typetag) (semantic-tag-p (car typetag)))
 234         (setq typetag (semantic-analyze-select-best-tag typetag 'type))
 235         )
 236
 237       ;; We now have a tag associated with the type.  We need to deref it.
 238       ;;
 239       ;; If we were asked not to (ie - debugger) push the typecache anyway.
 240       (if nometaderef
 241           typetag
 242         (unwind-protect
 243             (progn
 244               (semantic-scope-set-typecache
 245                scope (semantic-scope-tag-get-scope typetag))
 246               (semantic-analyze-dereference-metatype-stack typetag scope type-declaration)
 247               )
 248           (semantic-scope-set-typecache scope nil)
 249           )))))
 250
 251 (autoload 'semantic-tag-similar-p "semantic/tag-ls")
 252
 253 (defun semantic-analyze-dereference-metatype-stack (type scope &optional type-declaration)
 254   "Dereference metatypes repeatedly until we hit a real TYPE.
 255 Uses `semantic-analyze-dereference-metatype'.
 256 Argument SCOPE is the scope object with additional items in which to search.
 257 Optional argument TYPE-DECLARATION is how TYPE was found referenced."
 258   (let ((lasttype type)
 259         (lasttypedeclaration type-declaration)
 260         (nexttype (semantic-analyze-dereference-metatype type scope type-declaration))
 261         (idx 0))
 262     (catch 'metatype-recursion
 263       (while (and nexttype (not (semantic-tag-similar-p (car nexttype) lasttype)))
 264         (setq lasttype (car nexttype)
 265               lasttypedeclaration (cadr nexttype))
 266         (setq nexttype (semantic-analyze-dereference-metatype lasttype scope lasttypedeclaration))
 267         (setq idx (1+ idx))
 268         (when (> idx 20) (message "Possible metatype recursion for %S"
 269                                   (semantic-tag-name lasttype))
 270               (throw 'metatype-recursion nil))
 271         ))
 272     lasttype))
 273
 274 ;; @ TODO - the typecache can also return a stack of scope names.
 275
 276 (defun semantic-analyze-dereference-metatype-1 (ans scope)
 277   "Do extra work after dereferencing a metatype.
 278 ANS is the answer from the language specific query.
 279 SCOPE is the current scope."
 280   (require 'semantic/scope)
 281   ;; If ANS is a string, or if ANS is a short tag, we
 282   ;; need to do some more work to look it up.
 283   (if (stringp ans)
 284       ;; The metatype is just a string... look it up.
 285       (or (and scope (car-safe
 286                       ;; @todo - should this be `find the best one'?
 287                       (semantic-scope-find ans 'type scope)))
 288           (let ((tcsans nil))
 289             (prog1
 290                 (setq tcsans
 291                       (semanticdb-typecache-find ans))
 292               ;; While going through the metatype, if we have
 293               ;; a scope, push our new cache in.
 294               (when scope
 295                 (semantic-scope-set-typecache
 296                  scope (semantic-scope-tag-get-scope tcsans))
 297                 ))
 298             ))
 299     (when (and (semantic-tag-p ans)
 300                (eq (semantic-tag-class ans) 'type))
 301       ;; We have a tag.
 302       (if (semantic-tag-prototype-p ans)
 303           ;; It is a prototype.. find the real one.
 304           (or (and scope
 305                    (car-safe
 306                     (semantic-scope-find (semantic-tag-name ans)
 307                                          'type scope)))
 308               (let ((tcsans nil))
 309                 (prog1
 310                     (setq tcsans
 311                           (semanticdb-typecache-find (semantic-tag-name ans)))
 312                   ;; While going through the metatype, if we have
 313                   ;; a scope, push our new cache in.
 314                   (when scope
 315                     (semantic-scope-set-typecache
 316                      scope (semantic-scope-tag-get-scope tcsans))
 317                     ))))
 318         ;; We have a tag, and it is not a prototype.
 319         ans))
 320     ))
 321
 322 (provide 'semantic/analyze/fcn)
 323
 324 ;;; semantic/analyze/fcn.el ends here