cgit.sxemacs.org Git - packages/blob - xemacs-packages/semantic/semantic-analyze.el

   1 ;;; semantic-analyze.el --- Analyze semantic tags against local context
   2
   3 ;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007 Eric M. Ludlam
   4
   5 ;; Author: Eric M. Ludlam <zappo@gnu.org>
   6 ;; Keywords: syntax
   7 ;; X-RCS: $Id: semantic-analyze.el,v 1.53 2007/05/17 15:46:42 zappo Exp $
   8
   9 ;; This file is not part of GNU Emacs.
  10
  11 ;; Semantic is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; This software is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27 ;;
  28 ;; Semantic, as a tool, provides a nice list of searchable tags.
  29 ;; That information can provide some very accurate answers if the current
  30 ;; context of a position is known.
  31 ;;
  32 ;; Semantic-ctxt provides ways of analyzing, and manipulating the
  33 ;; semantic context of a language in code.
  34 ;;
  35 ;; This library provides routines for finding intelligent answers to
  36 ;; tough problems, such as if an argument to a function has the correct
  37 ;; return type, or all possible tags that fit in a given local context.
  38 ;;
  39
  40 ;;; Vocabulary:
  41 ;;
  42 ;; Here are some words used to describe different things in the analyzer:
  43 ;;
  44 ;; tag - A single entity
  45 ;; prefix - The beginning of a symbol, usually used to look up something
  46 ;;       incomplete.
  47 ;; type - The name of a datatype in the langauge.
  48 ;; metatype - If a type is named in a declaration like:
  49 ;;       struct moose somevariable;
  50 ;;       that name "moose" can be turned into a concrete type.
  51 ;; tag sequence - In C code, a list of dereferences, such as:
  52 ;;       this.that.theother();
  53 ;; parent - For a datatype in an OO language, another datatype
  54 ;;       inherited from.  This excludes interfaces.
  55 ;; scope - A list of tags that can be dereferenced that cannot
  56 ;;       be found from the global namespace.
  57 ;; scopetypes - A list of tags which are datatype that contain
  58 ;;       the scope.  The scopetypes need to have the scope extracted
  59 ;;       in a way that honors the type of inheritance.
  60 ;; nest/nested - When one tag is contained entirely in another.
  61 ;;
  62 ;; context - A semantic datatype representing a point in a buffer.
  63 ;;
  64 ;; constriant - If a context specifies a specific datatype is needed,
  65 ;;       that is a constraint.
  66 ;; constants - Some datatypes define elements of themselves as a
  67 ;;       constant.  These need to be returned as there would be no
  68 ;;       other possible completions.
  69 ;;
  70 (require 'inversion)
  71 (eval-and-compile
  72   (inversion-require 'eieio "0.18beta1"))
  73 (require 'semantic-format)
  74 (require 'semantic-ctxt)
  75 (require 'semantic-sort)
  76 (eval-when-compile (require 'semanticdb)
  77                    (require 'semanticdb-find))
  78
  79 ;;; Code:
  80
  81 ;;; Small Mode Specific Options
  82 ;;
  83 ;; These queries allow a major mode to help the analyzer make decisions.
  84 ;;
  85 (define-overload semantic-analyze-tag-prototype-p (tag)
  86   "Non-nil if TAG is a prototype."
  87   )
  88
  89 (defun semantic-analyze-tag-prototype-p-default (tag)
  90   "Non-nil if TAG is a prototype."
  91   (let ((p (semantic-tag-get-attribute tag :prototype-flag)))
  92     (cond
  93      ;; Trust the parser author.
  94      (p p)
  95      ;; Empty types might be a prototype.
  96      ((eq (semantic-tag-class tag) 'type)
  97       (not (semantic-tag-type-members tag)))
  98      ;; No other heuristics.
  99      (t nil))
 100     ))
 101
 102 (define-overload semantic-analyze-split-name (name)
 103   "Split a tag NAME into a sequence.
 104 Sometimes NAMES are gathered from the parser that are compounded,
 105 such as in C++ where foo::bar means:
 106   \"The class BAR in the namespace FOO.\"
 107 Return the string NAME for no change, or a list if it needs to be split.")
 108
 109 (defun semantic-analyze-split-name-default (name)
 110   "Don't split up NAME by default."
 111   name)
 112
 113 (define-overload semantic-analyze-dereference-metatype (type scope)
 114   "Return a concrete type tag based on input TYPE tag.
 115 A concrete type is an actual declaration of a memory description,
 116 such as a structure, or class.  A meta type is an alias,
 117 or a typedef in C or C++.  If TYPE is concrete, it
 118 is returned.  If it is a meta type, it will return the concrete
 119 type defined by TYPE.
 120 The default behavior always returns TYPE.
 121 Override functions need not return a real semantic tag.
 122 Just a name, or short tag will be ok.  It will be expanded here.
 123 SCOPE is the additional scope in which to search for names."
 124   (catch 'default-behavior
 125     (let ((ans (:override
 126                 ;; Nothing fancy, just return type be default.
 127                 (throw 'default-behavior type))))
 128       ;; If ANS is a string, or if ANS is a short tag, we
 129       ;; need to do some more work to look it up.
 130       (cond ((stringp ans)
 131              (semantic-analyze-find-tag ans nil scope))
 132             ((and (semantic-tag-p ans)
 133                   (eq (semantic-tag-class ans) 'type)
 134                   (semantic-tag-type-members ans))
 135              ans)
 136             ((and (semantic-tag-p ans)
 137                   (eq (semantic-tag-class ans) 'type)
 138                   (not (semantic-tag-type-members ans)))
 139              (semantic-analyze-find-tag
 140               (semantic-tag-name ans) nil scope))
 141             (t nil)))))
 142
 143 ;;; SELECTING/MERGING
 144 ;;
 145 ;; If you narrow things down to a list of tags that all mean
 146 ;; the same thing, how to you pick one?  Select or merge.
 147 ;;
 148
 149 (defun semantic-analyze-merge-namespaces (spaces)
 150   "Merge all the namespaces SPACES into a single super-tag.
 151 TODO: consider some higher level find routine to do this."
 152   (if (not (string= (semantic-tag-type (car spaces))
 153                     "namespace"))
 154       (signal 'wrong-type-argument (list (car spaces) "namespace")))
 155   (let ((first (car spaces))
 156         (members nil))
 157     (while spaces
 158       (if (string= (semantic-tag-type (car spaces)) "namespace")
 159           (setq members (append members
 160                                 (semantic-tag-type-members (car spaces))))
 161         ;; Else ... how did we get here?
 162         (message "Non namespace?? : %s"
 163                  (semantic-format-tag-summarize (car spaces))))
 164       (setq spaces (cdr spaces)))
 165
 166     ;; Create the new tag.
 167     (let ((nt (semantic-tag-new-type (semantic-tag-name first)
 168                                      (semantic-tag-type first)
 169                                      members
 170                                      nil)))
 171       (semantic-tag-set-faux nt)
 172       nt)))
 173
 174 (defun semantic-analyze-select-best-tag (sequence &optional tagclass)
 175   "For a SEQUENCE of tags, pick the best one.
 176 If SEQUENCE is made up of namespaces, merge the namespaces together.
 177 If SEQUENCE has several prototypes, find the non-prototype.
 178 If SEQUENCE has some items w/ no type information, find the one with a type.
 179 If SEQUENCE is all prototypes, or has no prototypes, get the first one.
 180 Optional TAGCLASS indicates to restrict the return to only
 181 tags of TAGCLASS."
 182   ;; 1) If these are namespace, merge them together.
 183   (if (and (or (not tagclass) (eq tagclass 'type))
 184            (semantic-tag-of-class-p (car sequence) 'type)
 185            (string= (semantic-tag-type (car sequence)) "namespace"))
 186       (semantic-analyze-merge-namespaces sequence)
 187     ;; 2) Loop over them, select a non-prototype.
 188     (let ((best nil)
 189           (proto nil)
 190           (notypeinfo nil)
 191           )
 192       (while (and (not best) sequence)
 193
 194         (when (or (not tagclass)
 195                   (semantic-tag-of-class-p (car sequence) tagclass))
 196           ;; Prototypes are second class tags
 197           (if (semantic-analyze-tag-prototype-p (car sequence))
 198               (setq proto (car sequence))
 199             ;; Typeless symbols are third class tags
 200             (if (not (semantic-tag-type (car sequence)))
 201                 (setq notypeinfo (car sequence))
 202
 203               (setq best (car sequence))))
 204           )
 205
 206         (setq sequence (cdr sequence)))
 207
 208       ;; Select the best, or at least the prototype.
 209       (or best proto notypeinfo))))
 210
 211 ;;; Tag Finding
 212 ;;
 213 ;; Mechanism for lookup up tags by name.
 214 ;;
 215 (defun semantic-analyze-find-tags-by-prefix (prefix)
 216   "Attempt to find a tag with PREFIX.
 217 This is a wrapper on top of semanticdb, and semantic search functions.
 218 Almost all searches use the same arguments."
 219   (if (and (fboundp 'semanticdb-minor-mode-p)
 220            (semanticdb-minor-mode-p))
 221       ;; Search the database & concatenate all matches together.
 222       (semanticdb-strip-find-results
 223        (semanticdb-find-tags-for-completion prefix)
 224        t)
 225     ;; Search just this file because there is no DB available.
 226     (semantic-find-tags-for-completion
 227      prefix (current-buffer))))
 228
 229 (defun semantic-analyze-find-tag (name &optional tagclass scope)
 230   "Return the first tag found with NAME or nil if not found.
 231 Optional argument TAGCLASS specifies the class of tag to return, such
 232 as 'function or 'variable.
 233 Optional argument SCOPE specifies additional type tags which are in
 234 SCOPE and do not need prefixing to find.
 235 This is a wrapper on top of semanticdb, and semantic search functions.
 236 Almost all searches use the same arguments."
 237   (let ((namelst (semantic-analyze-split-name name)))
 238     (cond
 239      ;; If the splitter gives us a list, use the sequence finder
 240      ;; to get the list.  Since this routine is expected to return
 241      ;; only one tag, return the LAST tag found from the sequence
 242      ;; which is supposedly the nexted reference.
 243      ;;
 244      ;; Of note, the SEQUENCE function below calls this function
 245      ;; (recursively now) so the names that we get from the above
 246      ;; fcn better not, in turn, be splittable.
 247      ((listp namelst)
 248       (let ((seq (semantic-analyze-find-tag-sequence
 249                   namelst nil scope)))
 250         (car (nreverse seq))))
 251      ;; If NAME is solo, then do our searches for it here.
 252      ((stringp namelst)
 253       (let ((retlist
 254              (or (and scope (semantic-find-tags-by-name name scope))
 255                  (if (and (fboundp 'semanticdb-minor-mode-p)
 256                           (semanticdb-minor-mode-p))
 257                      ;; Search the database
 258                      (semanticdb-strip-find-results
 259                       (semanticdb-find-tags-by-name name)
 260                       ;; This T means to find files for matching symbols
 261                       t)
 262                    ;; Search just this file
 263                    (semantic-find-tags-by-name
 264                     name (current-buffer))))))
 265
 266         (semantic-analyze-select-best-tag retlist tagclass))))))
 267
 268 ;;; Finding Datatypes
 269 ;;
 270 ;; Finding a data type by name within a project.
 271 ;;
 272 (defun semantic-analyze-tag-type-to-name (tag)
 273   "Get the name of TAG's type.
 274 The TYPE field in a tag can be nil (return nil)
 275 or a string, or a non-positional tag."
 276   (let ((tt (semantic-tag-type tag)))
 277     (cond ((semantic-tag-p tt)
 278            (semantic-tag-name tt))
 279           ((stringp tt)
 280            tt)
 281           ((listp tt)
 282            (car tt))
 283           (t nil))))
 284
 285 (defun semantic-analyze-tag-type (tag scope)
 286   "Return the semantic tag for a type within the type of TAG.
 287 TAG can be a variable, function or other type of tag.
 288 The type of tag (such as a class or struct) is a name.
 289 Lookup this name in database, and return all slots/fields
 290 within that types field.  Also handles anonymous types.
 291 SCOPE represents a calculated scope in which the types might be found."
 292   (let ((ttype (semantic-tag-type tag))
 293         (name nil)
 294         (typetag nil)
 295         )
 296
 297     ;; Is it an anonymous type?
 298     (if (and ttype
 299              (semantic-tag-p ttype)
 300              (eq (semantic-tag-class ttype) 'type)
 301              (semantic-analyze-type-parts ttype)
 302              ;(semantic-tag-children ttype)
 303              )
 304         ;; We have an anonymous type for TAG with children.
 305         ;; Use this type directly.
 306         (semantic-analyze-dereference-metatype ttype scope)
 307
 308       ;; Not an anonymous type.  Look up the name of this type
 309       ;; elsewhere, and report back.
 310       (setq name (semantic-analyze-tag-type-to-name tag))
 311       (if (and name (not (string= name "")))
 312           ;; Find a type of that name in scope.
 313           (setq typetag (semantic-analyze-find-tag name 'type scope))
 314         ;; No name to look stuff up with.
 315         (error "Semantic tag %S has no type information"
 316                (semantic-tag-name ttype)))
 317
 318       ;; Handle lists of tags.
 319       (when (and (listp typetag) (semantic-tag-p (car typetag)))
 320         (setq typetag (semantic-analyze-select-best-tag typetag 'type))
 321         )
 322
 323       ;; We now have a tag associated with the type.
 324       (semantic-analyze-dereference-metatype typetag scope))))
 325
 326 (defun semantic-analyze-type-parts (type &optional scope)
 327   "Return all parts of TYPE, a tag representing a TYPE declaration.
 328 SCOPE include additional tags which are in scope.
 329 This includes both the TYPE parts, and all functions found in all
 330 databases which have this type as a property."
 331   (let (;; SLOTS are the slots directly a part of TYPE.
 332         (slots (semantic-tag-components type))
 333         ;; EXTMETH are externally defined methods that are still
 334         ;; a part of this class.
 335         (extmeth (semantic-tag-external-member-children type t))
 336         ;; INHERITED are tags found in classes that our TYPE tag
 337         ;; inherits from.
 338         (inherited (semantic-analyze-inherited-tags type scope))
 339         )
 340     ;; Flatten the database output.
 341     (append slots extmeth inherited)
 342     ))
 343
 344 ;;; Tag Sequences
 345 ;;
 346 ;; A list of strings is a sequence.  Each string needs to be found,
 347 ;; and it's datatype determined so the next string can be identified.
 348 ;;
 349 (defun semantic-analyze-find-tag-sequence (sequence &optional localvar
 350                                                     scope typereturn)
 351   "Attempt to find all tags in SEQUENCE.
 352 Optional argument LOCALVAR is the list of local variables to use when
 353 finding the details on the first element of SEQUENCE in case
 354 it is not found in the global set of tables.
 355 Optional argument SCOPE are additional terminals to search which are currently
 356 scoped.  These are not local variables, but symbols available in a structure
 357 which doesn't need to be dereferneced.
 358 Optional argument TYPERETURN is a symbol in which the types of all found
 359 will be stored.  If nil, that data is thrown away."
 360   (let ((s sequence)                    ;copy of the sequence
 361         (tmp nil)                       ;tmp find variable
 362         (nexttype nil)                  ;a tag for the type next in sequence
 363         (tag nil)                       ;tag return list
 364         (tagtype nil)                   ;tag types return list
 365         )
 366     ;; For the first entry, it better be a variable, but it might
 367     ;; be in the local context too.
 368     ;; NOTE: Don't forget c++ namespace foo::bar.
 369     (setq tmp (or
 370                ;; This should be first, but bugs in the
 371                ;; C parser will turn function calls into
 372                ;; assumed int return function prototypes.  Yuck!
 373                (semantic-find-tags-by-name
 374                 (car s) localvar)
 375                (semantic-find-tags-by-name
 376                 (car s) (semantic-get-local-arguments))
 377                (semantic-find-tags-by-name
 378                 (car s) scope)
 379                (semantic-analyze-find-tag (car s))
 380                ))
 381
 382     (if (and (listp tmp) (semantic-tag-p (car tmp)))
 383         (setq tmp (semantic-analyze-select-best-tag tmp)))
 384     (if (not (semantic-tag-p tmp))
 385         (error "Cannot find definition for \"%s\"" (car s)))
 386     (setq s (cdr s))
 387     (setq tag (cons tmp tag))
 388
 389     ;; For the middle entries
 390     (while s
 391       ;; Using the tag found in TMP, lets find the tag
 392       ;; representing the full typeographic information of its
 393       ;; type, and use that to determine the search context for
 394       ;; (car s)
 395       (let ((tmptype
 396              ;; In some cases the found TMP is a type,
 397              ;; and we can use it directly.
 398              (cond ((eq (semantic-tag-class tmp) 'type)
 399                     tmp)
 400                    (t
 401                     (semantic-analyze-tag-type tmp scope))))
 402             (slots nil))
 403
 404         ;; Get the children
 405         (setq slots (semantic-analyze-type-parts tmptype))
 406
 407         ;; find (car s) in the list o slots
 408         (setq tmp (semantic-find-tags-by-name (car s) slots))
 409
 410         ;; If we have lots
 411         (if (and (listp tmp) (semantic-tag-p (car tmp)))
 412             (setq tmp (semantic-analyze-select-best-tag tmp)))
 413
 414         ;; Make sure we have a tag.
 415         (if (not (semantic-tag-p tmp))
 416             (if (cdr s)
 417                 ;; In the middle, we need to keep seeking our types out.
 418                 (error "Cannot find definition for \"%s\"" (car s))
 419               ;; Else, it's ok to end with a non-tag
 420               (setq tmp (car s))))
 421
 422         (setq tag (cons tmp tag))
 423         (setq tagtype (cons tmptype tagtype))
 424         )
 425       (setq s (cdr s)))
 426
 427     (if typereturn (set typereturn (nreverse tagtype)))
 428     ;; Return the mess
 429     (nreverse tag)))
 430
 431 ;;; Scope Determination
 432 ;;
 433 ;; A context is in a scope, which is a list of tags which are
 434 ;; visible to the current context, but are not "global" variables
 435 ;; or functions.
 436 ;;
 437 (defun semantic-analyze-inherited-tags (type scope)
 438   "Return all tags that TYPE inherits from.
 439 Argument SCOPE specify additional tags that are in scope
 440 whose tags can be searched when needed.
 441 For langauges with protection on specific methods or slots,
 442 it should strip out those not accessable by methods of TYPE."
 443   (let (;; PARENTS specifies only the superclasses and not
 444         ;; interfaces.  Inheriting from an interfaces implies
 445         ;; you have a copy of all methods locally.  I think.
 446         (parents (semantic-tag-type-superclasses type))
 447         (p nil)
 448         (ret nil)
 449         )
 450     (while parents
 451       (setq p (car parents))
 452       ;; Get this parent
 453       (let ((oneparent
 454              (semantic-analyze-find-tag
 455               (cond ((stringp p) p)
 456                     ((semantic-tag-p p) (semantic-tag-name p))
 457                     ((and (listp p) (stringp (car p)))
 458                      (car p)))
 459               'type scope)))
 460         (when oneparent
 461           ;; Get tags from this parent.
 462           (let* ((alltags (semantic-analyze-type-parts oneparent))
 463                  (accessabletags (append
 464                                   ;; @todo: Is there a better way to ask
 465                                   ;;        this question than two full
 466                                   ;;        searches?
 467                                   (semantic-find-tags-by-scope-protection
 468                                    'public oneparent alltags)
 469                                   (semantic-find-tags-by-scope-protection
 470                                    'protected oneparent alltags))))
 471             (setq ret (append ret accessabletags)))
 472           ;; is this right?
 473           (setq ret (append ret (semantic-analyze-inherited-tags
 474                                  oneparent scope)))
 475           ))
 476         ;; Continue on
 477       (setq parents (cdr parents)))
 478     ret))
 479
 480 (defun semantic-analyze-scoped-tags (typelist)
 481   "Return a list of tags accessable when TYPELIST is in scope.
 482 Tags returned are not in the global name space, but are instead
 483 scoped inside a class or namespace.  Such items can be referenced
 484 without use of \"object.function()\" style syntax due to an
 485 implicit \"object\"."
 486   (let ((typelist2 nil)
 487         (currentscope nil))
 488     ;; Loop over typelist, and find and merge all namespaces matching
 489     ;; the names in typelist.
 490     (while typelist
 491       (if (string= (semantic-tag-type (car typelist)) "namespace")
 492           (setq typelist2 (cons (semantic-analyze-find-tag
 493                                  (semantic-tag-name (car typelist))
 494                                  'type
 495                                  typelist2)
 496                                 typelist2))
 497         ;; No namespace, just append...
 498         (setq typelist2 (cons (car typelist) typelist2)))
 499       (setq typelist (cdr typelist)))
 500
 501     ;; Loop over the types (which should be sorted by postion
 502     ;; adding to the scopelist as we go, and using the scopelist
 503     ;; for additional searching!
 504     (while typelist2
 505       (setq currentscope (append
 506                           currentscope
 507                           (semantic-analyze-type-parts (car typelist2)
 508                                                        currentscope)))
 509       (setq typelist2 (cdr typelist2)))
 510     currentscope))
 511
 512 (defun semantic-analyze-scope-nested-tags (&optional position scopetypes)
 513   "Return a list of types in order of nesting for the context of POSITION.
 514 If POSITION is in a method with a named parent, find that parent, and
 515 identify it's scope via overlay instead.
 516 Optional SCOPETYPES are additional scoped entities in which our parent might
 517 be found.
 518 This only finds ONE immediate parent by name.  All other parents returned
 519 are from nesting data types."
 520   (save-excursion
 521     (if position (goto-char position))
 522     (let* ((stack (reverse (semantic-find-tag-by-overlay (point))))
 523            (tag (car stack))
 524            (pparent (car (cdr stack)))
 525            )
 526       ;; Only do this level of analysis for functions.
 527       (when (eq (semantic-tag-class tag) 'function)
 528         (if (and pparent (eq (semantic-tag-class pparent) 'type))
 529             ;; We have a parent in our stack, so analyze this stack
 530             ;; We are done.
 531             nil
 532           ;; No parent, we need to seek one out.
 533           (let ((p (semantic-tag-function-parent tag)))
 534             (when p
 535               ;; We have a parent, search for it.
 536               (let* ((searchname (cond ((stringp p) p)
 537                                       ((semantic-tag-p p)
 538                                        (semantic-tag-name p))
 539                                       ((and (listp p) (stringp (car p)))
 540                                        (car p))))
 541                      (scope (apply 'append
 542                                    (mapcar 'semantic-tag-type-members scopetypes)))
 543                      (ptag (semantic-analyze-find-tag searchname
 544                                                       'type scope)))
 545                 (setq pparent ptag)))
 546             ))
 547         ;; If we have a pparent tag, lets go there
 548         ;; an analyze that stack of tags.
 549         (when (and pparent (semantic-tag-with-position-p pparent))
 550           (semantic-go-to-tag pparent)
 551           (setq stack (reverse (semantic-find-tag-by-overlay (point))))
 552           (let ((returnlist nil))
 553             ;; Add things to STACK until we cease finding tags of class type.
 554             (while (and stack (eq (semantic-tag-class (car stack)) 'type))
 555               (setq returnlist (cons (car stack) returnlist)
 556                     stack (cdr stack)))
 557             (reverse returnlist))
 558           )))))
 559
 560 (defun semantic-analyze-scoped-types (&optional position)
 561   "Return a list of types current in scope at POSITION.
 562 This is based on what tags exist at POSITION, and any associated
 563 types available."
 564   (save-excursion
 565     (if position (goto-char position))
 566     (let ((tag (semantic-current-tag))
 567           (code-scoped-types nil)
 568           (parents nil))
 569       ;; Lets ask if any types are currently scoped.  Scoped
 570       ;; classes and types provide their public methods and types
 571       ;; in source code, but are unrelated hierarchically.
 572       (let ((sp (semantic-ctxt-scoped-types)))
 573         (while sp
 574           ;; Get this thing as a tag
 575           (let ((tmp (cond ((stringp (car sp))
 576                             (semantic-analyze-find-tag (car sp) 'type))
 577                            ((semantic-tag-p (car sp))
 578                             (car sp))
 579                            (t nil))))
 580             (when tmp
 581               (setq code-scoped-types
 582                     (cons tmp code-scoped-types))))
 583           (setq  sp (cdr sp))))
 584       (setq code-scoped-types (nreverse code-scoped-types))
 585       ;; Get the PARENTS including nesting scope for this location.
 586       (setq parents (semantic-analyze-scope-nested-tags
 587                      nil code-scoped-types))
 588       ;; We return a list in case a function can have multiple explicit
 589       ;; parents.
 590       (semantic-unique-tag-table
 591        (if parents
 592            (append parents code-scoped-types)
 593          code-scoped-types)))))
 594
 595 ;;; Simple utility functions
 596 ;;
 597 (defun semantic-analyze-calculate-bounds ()
 598   "At the current point, calculate the prefix and bounds.
 599 Return (PREFIX ENDSYM BOUNDS)"
 600   (let* ((prefix (semantic-ctxt-current-symbol))
 601          (endsym (car (reverse prefix)))
 602          (bounds (save-excursion
 603                    (cond ((string= endsym "")
 604                           (cons (point) (point))
 605                           )
 606                          ((and prefix (looking-at endsym))
 607                           (cons (point) (progn
 608                                           (condition-case nil
 609                                               (forward-sexp 1)
 610                                             (error nil))
 611                                           (point))))
 612                          (prefix
 613                           (condition-case nil
 614                               (cons (progn (forward-sexp -1) (point))
 615                                     (progn (forward-sexp 1) (point)))
 616                             (error nil)))
 617                          (t nil))))
 618          )
 619     (list prefix endsym bounds)))
 620
 621 ;;; Analysis Classes
 622 ;;
 623 ;; These classes represent what a context is.  Different types
 624 ;; of contexts provide differing amounts of information to help
 625 ;; provide completions.
 626 ;;
 627 (defclass semantic-analyze-context ()
 628   ((bounds :initarg :bounds
 629            :type list
 630            :documentation "The bounds of this context.
 631 Usually bound to the dimension of a single symbol or command.")
 632    (prefix :initarg :prefix
 633            :type list
 634            :documentation "List of tags defining local text.
 635 This can be nil, or a list where the last element can be a string
 636 representing text that may be incomplete.  Preceeding elements
 637 must be semantic tags representing variables or functions
 638 called in a dereference sequence.")
 639    (prefixclass :initarg :prefixclass
 640                 :type list
 641                 :documentation "Tag classes expected at this context.
 642 These are clases for tags, such as 'function, or 'variable.")
 643    (prefixtypes :initarg :prefixtypes
 644            :type list
 645            :documentation "List of tags defining types for :prefix.
 646 This list is one shorter than :prefix.  Each element is a semantic
 647 tag representing a type matching the semantic tag in the same
 648 position in PREFIX.")
 649    (scopetypes :initarg :scopetypes
 650                :type list
 651                :documentation "List of type tags in scope.
 652 When in a function is called, it may have certain other types
 653 in scope, such as classes in it's lineage.  This is a list
 654 of all those classes.")
 655    (scope :initarg :scope
 656           :type list
 657           :documentation "List of tags available in scopetype.
 658 See `semantic-analyze-scoped-tags' for details.")
 659    (localvariables :initarg :localvariables
 660                    :initform nil
 661                    :type list
 662                    :documentation "List of local variables.
 663 Local variables are defined withing the code scope.")
 664    (buffer :initarg :buffer
 665            :type buffer
 666            :documentation "The buffer this context is derived from.")
 667    )
 668   "Base analysis data for a any context.")
 669
 670 (defclass semantic-analyze-context-assignment (semantic-analyze-context)
 671   ((assignee :initarg :assignee
 672              :type list
 673              :documentation "A sequence of tags for an assignee.
 674 This is a variable into which some value is being placed.  The last
 675 item in the list is the variable accepting the value.  Earlier
 676 tags represent the variables being derefernece to get to the
 677 assignee."))
 678   "Analysis class for a value in an assignment.")
 679
 680 (defclass semantic-analyze-context-functionarg (semantic-analyze-context)
 681   ((function :initarg :function
 682              :type list
 683              :documentation "A sequence of tags for a function.
 684 This is a function being called.  The cursor will be in the position
 685 of an argument.
 686 The last tag in :function is the function being called.  Earlier
 687 tags represent the variables being dereferenced to get to the
 688 function.")
 689    (index :initarg :index
 690           :type integer
 691           :documentation "The index of the argument for this context.
 692 If a function takes 4 arguments, this value should be bound to
 693 the values 1 through 4.")
 694    (argument :initarg :argument
 695              :type list
 696              :documentation "A sequence of tags for the :index argument.
 697 The argument can accept a value of some type, and this contains the
 698 tag for that definition.  It should be a tag, but might
 699 be just a string in some circumstances.")
 700    )
 701   "Analysis class for a value as a function argument.")
 702
 703 (defclass semantic-analyze-context-return (semantic-analyze-context)
 704   () ; No extra data.
 705   "Analysis class for return data.
 706 Return data methods identify the requred type by the return value
 707 of the parent function.")
 708
 709 ;;; ANALYSIS
 710 ;;
 711 ;; Main Analysis function
 712 ;;
 713 ;;;###autoload
 714 (define-overload semantic-analyze-current-context (&optional position)
 715   "Analyze the current context at optional POSITION.
 716 If called interactively, display interesting information about POSITION
 717 in a separate buffer.
 718 Returns an object based on symbol `semantic-analyze-context'.
 719
 720 This function can be overriden with the symbol `analyze-context'.
 721 When overriding this function, your override will be called while
 722 cursor is at POSITION.  In addition, your function will not be called
 723 if a cached copy of the return object is found."
 724   (interactive "d")
 725   (if (not position) (setq position (point)))
 726   (save-excursion
 727     (goto-char position)
 728     (let* ((answer (semantic-get-cache-data 'current-context)))
 729       (with-syntax-table semantic-lex-syntax-table
 730         (when (not answer)
 731           (setq answer (:override))
 732           (when (and answer (oref answer bounds))
 733             (with-slots (bounds) answer
 734               (semantic-cache-data-to-buffer (current-buffer)
 735                                              (car bounds)
 736                                              (cdr bounds)
 737                                              answer
 738                                              'current-context
 739                                              'exit-cache-zone))
 740             ;; Check for interactivity
 741             (if (interactive-p)
 742                 (semantic-analyze-pop-to-context answer))))
 743
 744         answer))))
 745
 746 (defun semantic-analyze-current-context-default (position)
 747   "Analyze the current context at POSITION.
 748 Returns an object based on symbol `semantic-analyze-context'."
 749   (let* ((context-return nil)
 750          (startpoint (point))
 751          (prefixandbounds (semantic-analyze-calculate-bounds))
 752          (prefix (car prefixandbounds))
 753          (endsym (nth 1 prefixandbounds))
 754          (bounds (nth 2 prefixandbounds))
 755          (prefixclass (semantic-ctxt-current-class-list))
 756          (prefixtypes nil)
 757          (scopetypes nil)
 758          (scope nil)
 759          (localvar nil)
 760          (function nil)
 761          (fntag nil)
 762          arg fntagend argtag
 763          )
 764
 765     (unless (not bounds)
 766
 767       ;; Don't do the work if there are no bounds.
 768       (setq scopetypes (semantic-analyze-scoped-types position)
 769             scope (if scopetypes
 770                       (semantic-analyze-scoped-tags scopetypes))
 771             localvar (semantic-get-local-variables)
 772             function (semantic-ctxt-current-function))
 773
 774       (condition-case nil
 775           ;; If we are on lame stuff, it won't be found!
 776           (setq prefix (semantic-analyze-find-tag-sequence
 777                         prefix localvar scope 'prefixtypes))
 778         (error nil))
 779
 780       (when function
 781         ;; If we have a function, then we can get the argument
 782         (setq arg (semantic-ctxt-current-argument))
 783
 784         (condition-case nil
 785             (setq fntag
 786                   (semantic-analyze-find-tag-sequence
 787                    function localvar scope))
 788           (error nil))
 789
 790         (when fntag
 791           (setq fntagend (car (reverse fntag))
 792                 argtag
 793                 (when (semantic-tag-p fntagend)
 794                   (nth (1- arg) (semantic-tag-function-arguments fntagend)))
 795                 )))
 796
 797       (if fntag
 798           ;; If we found a tag for our function, we can go into
 799           ;; functional context analysis mode, meaning we have a type
 800           ;; for the argument.
 801           (setq context-return
 802                 (semantic-analyze-context-functionarg
 803                  "functionargument"
 804                  :buffer (current-buffer)
 805                  :function fntag
 806                  :index arg
 807                  :argument (list argtag)
 808                  :scope scope
 809                  :scopetypes scopetypes
 810                  :localvariables localvar
 811                  :prefix prefix
 812                  :prefixclass prefixclass
 813                  :bounds bounds
 814                  :prefixtypes prefixtypes))
 815
 816         ;; No function, try assignment
 817         (let ((assign (semantic-ctxt-current-assignment))
 818               (asstag nil))
 819           (if assign
 820               ;; We have an assignment
 821               (condition-case nil
 822                   (setq asstag (semantic-analyze-find-tag-sequence
 823                                 assign localvar scope))
 824                 (error nil)))
 825
 826           (if asstag
 827               (setq context-return
 828                     (semantic-analyze-context-assignment
 829                      "assignment"
 830                      :buffer (current-buffer)
 831                      :assignee asstag
 832                      :scope scope
 833                      :scopetypes scopetypes
 834                      :localvariables localvar
 835                      :bounds bounds
 836                      :prefix prefix
 837                      :prefixclass prefixclass
 838                      :prefixtypes prefixtypes))
 839
 840             ;; TODO: Identify return value condition.
 841
 842             ;; Nothing in particular
 843             (setq context-return
 844                   (semantic-analyze-context
 845                    "context"
 846                    :buffer (current-buffer)
 847                    :scope scope
 848                    :scopetypes scopetypes
 849                    :localvariables localvar
 850                    :bounds bounds
 851                    :prefix prefix
 852                    :prefixclass prefixclass
 853                    :prefixtypes prefixtypes)))))
 854
 855       ;; Return our context.
 856       context-return)))
 857
 858 \f
 859 ;;; COMPLETION
 860 ;;
 861 ;; Context Analysis Completion
 862 ;;
 863 (defmethod semantic-analyze-type-constraint
 864   ((context semantic-analyze-context) &optional desired-type)
 865   "Return a type constraint for completing :prefix in CONTEXT.
 866 Optional argument DESIRED-TYPE may be a non-type tag to analyze."
 867   (when (semantic-tag-p desired-type)
 868     ;; Convert the desired type if needed.
 869     (if (not (eq (semantic-tag-class desired-type) 'type))
 870         (setq desired-type (semantic-tag-type desired-type)))
 871     ;; Protect against plain strings
 872     (cond ((stringp desired-type)
 873            (setq desired-type (list desired-type 'type)))
 874           ((and (stringp (car desired-type))
 875                 (not (semantic-tag-p desired-type)))
 876            (setq desired-type (list (car desired-type) 'type)))
 877           ((semantic-tag-p desired-type)
 878            ;; We have a tag of some sort.  Yay!
 879            nil)
 880           (t (setq desired-type nil))
 881           )
 882     desired-type))
 883
 884 (defmethod semantic-analyze-type-constraint
 885   ((context semantic-analyze-context-functionarg))
 886   "Return a type constraint for completing :prefix in CONTEXT."
 887   (call-next-method context (car (oref context argument))))
 888
 889 (defmethod semantic-analyze-type-constraint
 890   ((context semantic-analyze-context-assignment))
 891   "Return a type constraint for completing :prefix in CONTEXT."
 892   (call-next-method context (car (reverse (oref context assignee)))))
 893
 894 (defmethod semantic-analyze-interesting-tag
 895   ((context semantic-analyze-context))
 896   "Return a tag from CONTEXT that would be most interesting to a user."
 897   (let ((prefix (oref context :prefix)))
 898     (cond ((semantic-tag-p (car prefix))
 899            ;; If the prefix is a tag, that is interesting.
 900            (car prefix))
 901           ((and (stringp (car prefix))
 902                 (semantic-tag-p (car (cdr prefix))))
 903            ;; Well, if it is a string, the predecessor might be
 904            ;; interesting.
 905            (car (cdr prefix)))
 906           (t
 907            ;; Nope, nothing good.
 908            nil))
 909     ))
 910
 911 (defmethod semantic-analyze-interesting-tag
 912   ((context semantic-analyze-context-functionarg))
 913   "Try the base, and if that fails, return what we are assigning into."
 914   (or (call-next-method) (car-safe (oref context :function))))
 915
 916 (defmethod semantic-analyze-interesting-tag
 917   ((context semantic-analyze-context-assignment))
 918   "Try the base, and if that fails, return what we are assigning into."
 919   (or (call-next-method) (car-safe (oref context :assignee))))
 920
 921 (define-overload semantic-analyze-type-constants (type)
 922   "For the tag TYPE, return any constant symbols of TYPE.
 923 Used as options when completing."
 924   (let ((ans
 925          (:override-with-args
 926              ((semantic-analyze-find-tag (semantic-tag-name type)))
 927            ;; Be default, we don't know.
 928            nil))
 929         (out nil))
 930     (dolist (elt ans)
 931       (cond
 932        ((stringp elt)
 933         (push (semantic-tag-new-variable
 934                elt (semantic-tag-name type) nil)
 935               out))
 936        ((semantic-tag-p elt)
 937         (push elt out))
 938        (t nil)))
 939     (nreverse out)))
 940
 941 (defun semantic-analyze-tags-of-class-list (tags classlist)
 942   "Return the tags in TAGS that are of classes in CLASSLIST."
 943   (let ((origc tags))
 944     ;; Accept only tags that are of the datatype specified by
 945     ;; the desired classes.
 946     (setq tags (apply 'append
 947                       (mapcar (lambda (class)
 948                                 (semantic-find-tags-by-class class origc))
 949                               classlist)))
 950     tags))
 951
 952 ;;;###autoload
 953 (define-overload semantic-analyze-possible-completions (context)
 954   "Return a list of semantic tags which are possible completions.
 955 CONTEXT is either a position (such as point), or a precalculated
 956 context.  Passing in a context is useful if the caller also needs
 957 to access parts of the analysis.
 958 Completions run through the following filters:
 959   * Elements currently in scope
 960   * Constants currently in scope
 961   * Elements match the :prefix in the CONTEXT.
 962   * Type of the completion matches the type of the context.
 963 Context type matching can identify the following:
 964   * No specific type
 965   * Assignment into a variable of some type.
 966   * Argument to a function with type constraints.
 967 When called interactively, displays the list of possible completions
 968 in a buffer."
 969   (interactive "d")
 970   (with-syntax-table semantic-lex-syntax-table
 971     (let* ((context (if (semantic-analyze-context-child-p context)
 972                         context
 973                       (semantic-analyze-current-context context)))
 974            (ans (:override)))
 975       ;; If interactive, display them.
 976       (when (interactive-p)
 977         (with-output-to-temp-buffer "*Possible Completions*"
 978           (semantic-analyze-princ-sequence ans "" (current-buffer)))
 979         (shrink-window-if-larger-than-buffer
 980          (get-buffer-window "*Possible Completions*")))
 981       ans)))
 982
 983 (defun semantic-analyze-possible-completions-default (context)
 984   "Default method for producing smart completions.
 985 Argument CONTEXT is an object specifying the locally derived context."
 986   (let* ((a context)
 987          (fnargs (save-excursion
 988                    (semantic-get-local-arguments
 989                     (car (oref a bounds)))))
 990          (desired-type (semantic-analyze-type-constraint a))
 991          (desired-class (oref a prefixclass))
 992          (prefix (oref a prefix))
 993          (prefixtypes (oref a prefixtypes))
 994          (completetext nil)
 995          (completetexttype nil)
 996          (c nil))
 997
 998     ;; Calculate what our prefix string is so that we can
 999     ;; find all our matching text.
1000     (setq completetext (car (reverse prefix)))
1001     (if (semantic-tag-p completetext)
1002         (setq completetext (semantic-tag-name completetext)))
1003
1004     (if (and (not completetext) (not desired-type))
1005         (error "Nothing to complete"))
1006
1007     (if (not completetext) (setq completetext ""))
1008
1009     ;; This better be a reasonable type, or we should fry it.
1010     ;; The prefixtypes should always be at least 1 less than
1011     ;; the prefix since the type is never looked up for the last
1012     ;; item when calculating a sequence.
1013     (setq completetexttype (car (reverse prefixtypes)))
1014     (if (or (not completetexttype)
1015             (not (and (semantic-tag-p completetexttype)
1016                       (eq (semantic-tag-class completetexttype) 'type))))
1017         ;; What should I do here?  I think this is an error condition.
1018         (setq completetexttype nil))
1019
1020     ;; There are many places to get our completion stream for.
1021     ;; Here we go.
1022     (if completetexttype
1023
1024         (setq c (semantic-find-tags-by-name-regexp
1025                  (concat "^" completetext)
1026                  (semantic-analyze-type-parts completetexttype
1027                                               (oref a scope))
1028                  ))
1029
1030       (let ((expr (concat "^" completetext)))
1031         ;; No type based on the completetext.  This is a free-range
1032         ;; var or function.  We need to expand our search beyond this
1033         ;; scope into semanticdb, etc.
1034         (setq c (append
1035                  ;; Argument list
1036                  (semantic-find-tags-by-name-regexp expr fnargs)
1037                  ;; Local variables
1038                  (semantic-find-tags-by-name-regexp expr
1039                                                     (oref a localvariables))
1040                  ;; The current scope
1041                  (semantic-find-tags-by-name-regexp expr (oref a scope))
1042                  ;; The world
1043                  (semantic-analyze-find-tags-by-prefix
1044                   completetext))
1045               )
1046         ))
1047
1048     (let ((origc c)
1049           (scope (oref a scope))
1050           (dtname (semantic-tag-name desired-type)))
1051
1052       ;; Reset c.
1053       (setq c nil)
1054
1055       ;; Loop over all the found matches, and catagorize them
1056       ;; as being possible features.
1057       (while origc
1058
1059         (cond
1060          ;; Strip operators
1061          ((semantic-tag-get-attribute (car origc) :operator-flag)
1062           nil
1063           )
1064
1065          ;; If we are completing from within some prefix,
1066          ;; then we want to exclude constructors and destructors
1067          ((and completetexttype
1068                (or (semantic-tag-get-attribute (car origc) :constructor-flag)
1069                    (semantic-tag-get-attribute (car origc) :destructor-flag)))
1070           nil
1071           )
1072
1073          ;; If there is a desired type, we need a pair of restrictions
1074          (desired-type
1075
1076           (cond
1077            ;; Ok, we now have a completion list based on the text we found
1078            ;; we want to complete on.  Now filter that stream against the
1079            ;; type we want to search for.
1080            ((string= dtname (semantic-analyze-tag-type-to-name (car origc)))
1081             (setq c (cons (car origc) c))
1082             )
1083
1084            ;; Now anything that is a compound type which could contain
1085            ;; additional things which are of the desired type
1086            ((semantic-tag-type (car origc))
1087             (let ((att (semantic-analyze-tag-type (car origc) scope))
1088                 )
1089               (if (and att (semantic-tag-type-members att))
1090                   (setq c (cons (car origc) c))))
1091             )
1092
1093            ) ; cond
1094           ); desired type
1095
1096          ;; No desired type, no other restrictions.  Just add.
1097          (t
1098           (setq c (cons (car origc) c)))
1099
1100          ); cond
1101
1102         (setq origc (cdr origc)))
1103
1104       (when desired-type
1105       ;; Some types, like the enum in C, have special constant values that
1106       ;; we could complete with.  Thus, if the target is an enum, we can
1107       ;; find possible symbol values to fill in that value.
1108       (let ((constants
1109              (semantic-analyze-type-constants desired-type)))
1110         (if constants
1111             (progn
1112               ;; Filter
1113               (setq constants
1114                     (semantic-find-tags-by-name-regexp
1115                      (concat "^" completetext)
1116                      constants))
1117               ;; Add to the list
1118               (setq c (append c constants)))
1119           )))
1120       )
1121
1122     (when desired-class
1123       (setq c (semantic-analyze-tags-of-class-list c desired-class)))
1124
1125     ;; Pull out trash.
1126     ;; NOTE TO SELF: Is this too slow?
1127     ;; OTHER NOTE: Do we not want to strip duplicates by name and
1128     ;; only by position?  When are duplicate by name but not by tag
1129     ;; useful?
1130     (setq c (semantic-unique-tag-table-by-name c))
1131
1132     ;; All done!
1133
1134     c))
1135
1136 \f
1137 ;;; DEBUG OUTPUT
1138 ;;
1139 ;; Friendly output of a context analysis.
1140 ;;
1141 (defcustom semantic-analyze-summary-function 'semantic-format-tag-prototype
1142   "*Function to use when creating items in Imenu.
1143 Some useful functions are found in `semantic-format-tag-functions'."
1144   :group 'semantic
1145   :type semantic-format-tag-custom-list)
1146
1147 (defun semantic-analyze-princ-sequence (sequence &optional prefix buff)
1148   "Send the tag SEQUENCE to standard out.
1149 Use PREFIX as a label.
1150 Use BUFF as a source of override methods."
1151   (while sequence
1152       (princ prefix)
1153       (cond
1154        ((semantic-tag-p (car sequence))
1155         (princ (funcall semantic-analyze-summary-function
1156                         (car sequence))))
1157        ((stringp (car sequence))
1158         (princ "\"")
1159         (princ (semantic--format-colorize-text (car sequence) 'variable))
1160         (princ "\""))
1161        (t
1162         (princ (format "'%S" (car sequence)))))
1163       (princ "\n")
1164       (setq sequence (cdr sequence))
1165       (setq prefix (make-string (length prefix) ? ))
1166       ))
1167
1168 (defmethod semantic-analyze-show ((context semantic-analyze-context))
1169   "Insert CONTEXT into the current buffer in a nice way."
1170   (semantic-analyze-princ-sequence (oref context prefix) "Prefix: " )
1171   (semantic-analyze-princ-sequence (oref context prefixclass) "Prefix Classes: ")
1172   (semantic-analyze-princ-sequence (oref context prefixtypes) "Prefix Types: ")
1173   (princ "--------\n")
1174   (semantic-analyze-princ-sequence (oref context scopetypes) "Scope Types: ")
1175   (semantic-analyze-princ-sequence (oref context scope) "Scope: ")
1176   (semantic-analyze-princ-sequence (oref context localvariables) "LocalVars: ")
1177   )
1178
1179 (defmethod semantic-analyze-show ((context semantic-analyze-context-assignment))
1180   "Insert CONTEXT into the current buffer in a nice way."
1181   (semantic-analyze-princ-sequence (oref context assignee) "Assignee: ")
1182   (call-next-method))
1183
1184 (defmethod semantic-analyze-show ((context semantic-analyze-context-functionarg))
1185   "Insert CONTEXT into the current buffer in a nice way."
1186   (semantic-analyze-princ-sequence (oref context function) "Function: ")
1187   (princ "Argument Index: ")
1188   (princ (oref context index))
1189   (princ "\n")
1190   (semantic-analyze-princ-sequence (oref context argument) "Argument: ")
1191   (call-next-method))
1192
1193 (defun semantic-analyze-pop-to-context (context)
1194   "Display CONTEXT in a temporary buffer.
1195 CONTEXT's content is described in `semantic-analyze-current-context'."
1196   (with-output-to-temp-buffer "*Semantic Context Analysis*"
1197     (princ "Context Type: ")
1198     (princ (object-name context))
1199     (princ "\n")
1200     (princ "Bounds: ")
1201     (princ (oref context bounds))
1202     (princ "\n")
1203     (semantic-analyze-show context)
1204     )
1205   (shrink-window-if-larger-than-buffer
1206    (get-buffer-window "*Semantic Context Analysis*"))
1207   )
1208
1209 (provide 'semantic-analyze)
1210
1211 ;;; semantic-analyze.el ends here