code.delx.au - gnu-emacs/blob - lisp/cedet/semantic/tag.el

   1 ;;; tag.el --- tag creation and access
   2
   3 ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
   4 ;;; 2008, 2009 Free Software Foundation, Inc.
   5
   6 ;; Author: Eric M. Ludlam <zappo@gnu.org>
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24 ;;
  25 ;; I.  The core production of semantic is the list of tags produced by the
  26 ;;    different parsers.  This file provides 3 APIs related to tag access:
  27 ;;
  28 ;;    1) Primitive Tag Access
  29 ;;       There is a set of common features to all tags.  These access
  30 ;;       functions can get these values.
  31 ;;    2) Standard Tag Access
  32 ;;       A Standard Tag should be produced by most traditional languages
  33 ;;       with standard styles common to typed object oriented languages.
  34 ;;       These functions can access these data elements from a tag.
  35 ;;    3) Generic Tag Access
  36 ;;       Access to tag structure in a more direct way.
  37 ;;         ** May not be forward compatible.
  38 ;;
  39 ;; II.  There is also an API for tag creation.  Use `semantic-tag' to create
  40 ;;     a new tag.
  41 ;;
  42 ;; III.  Tag Comparison.  Allows explicit or comparitive tests to see
  43 ;;      if two tags are the same.
  44
  45 ;;; History:
  46 ;;
  47
  48 ;;; Code:
  49 ;;
  50
  51 ;; Keep this only so long as we have obsolete fcns.
  52 (require 'semantic/fw)
  53 (require 'semantic/lex)
  54
  55 (declare-function semantic-ctxt-current-mode "semantic/ctxt")
  56 (declare-function semantic-analyze-split-name "semantic/analyze/fcn")
  57 (declare-function semantic-fetch-tags "semantic")
  58 (declare-function semantic-clear-toplevel-cache "semantic")
  59 (declare-function semantic-documentation-for-tag "semantic/doc")
  60 (declare-function semantic-format-tag-prototype "semantic/format")
  61 (declare-function semantic-format-tag-summarize "semantic/format")
  62 (declare-function semantic-format-tag-name "semantic/format")
  63
  64 (defconst semantic-tag-version "2.0pre7"
  65   "Version string of semantic tags made with this code.")
  66
  67 (defconst semantic-tag-incompatible-version "1.0"
  68   "Version string of semantic tags which are not currently compatible.
  69 These old style tags may be loaded from a file with semantic db.
  70 In this case, we must flush the old tags and start over.")
  71 \f
  72 ;;; Primitive Tag access system:
  73 ;;
  74 ;; Raw tags in semantic are lists of 5 elements:
  75 ;;
  76 ;;   (NAME CLASS ATTRIBUTES PROPERTIES OVERLAY)
  77 ;;
  78 ;; Where:
  79 ;;
  80 ;;   - NAME is a string that represents the tag name.
  81 ;;
  82 ;;   - CLASS is a symbol that represent the class of the tag (for
  83 ;;     example, usual classes are `type', `function', `variable',
  84 ;;     `include', `package', `code').
  85 ;;
  86 ;;   - ATTRIBUTES is a public list of attributes that describes
  87 ;;     language data represented by the tag (for example, a variable
  88 ;;     can have a `:constant-flag' attribute, a function an `:arguments'
  89 ;;     attribute, etc.).
  90 ;;
  91 ;;   - PROPERTIES is a private list of properties used internally.
  92 ;;
  93 ;;   - OVERLAY represent the location of data described by the tag.
  94 ;;
  95
  96 (defsubst semantic-tag-name (tag)
  97   "Return the name of TAG.
  98 For functions, variables, classes, typedefs, etc., this is the identifier
  99 that is being defined.  For tags without an obvious associated name, this
 100 may be the statement type, e.g., this may return @code{print} for python's
 101 print statement."
 102   (car tag))
 103
 104 (defsubst semantic-tag-class (tag)
 105   "Return the class of TAG.
 106 That is, the symbol 'variable, 'function, 'type, or other.
 107 There is no limit to the symbols that may represent the class of a tag.
 108 Each parser generates tags with classes defined by it.
 109
 110 For functional languages, typical tag classes are:
 111
 112 @table @code
 113 @item type
 114 Data types, named map for a memory block.
 115 @item function
 116 A function or method, or named execution location.
 117 @item variable
 118 A variable, or named storage for data.
 119 @item include
 120 Statement that represents a file from which more tags can be found.
 121 @item package
 122 Statement that declairs this file's package name.
 123 @item code
 124 Code that has not name or binding to any other symbol, such as in a script.
 125 @end table
 126 "
 127   (nth 1 tag))
 128
 129 (defsubst semantic-tag-attributes (tag)
 130   "Return the list of public attributes of TAG.
 131 That is a property list: (ATTRIBUTE-1 VALUE-1 ATTRIBUTE-2 VALUE-2...)."
 132   (nth 2 tag))
 133
 134 (defsubst semantic-tag-properties (tag)
 135   "Return the list of private properties of TAG.
 136 That is a property list: (PROPERTY-1 VALUE-1 PROPERTY-2 VALUE-2...)."
 137   (nth 3 tag))
 138
 139 (defsubst semantic-tag-overlay (tag)
 140   "Return the OVERLAY part of TAG.
 141 That is, an overlay or an unloaded buffer representation.
 142 This function can also return an array of the form [ START END ].
 143 This occurs for tags that are not currently linked into a buffer."
 144   (nth 4 tag))
 145
 146 (defsubst semantic--tag-overlay-cdr (tag)
 147   "Return the cons cell whose car is the OVERLAY part of TAG.
 148 That function is for internal use only."
 149   (nthcdr 4 tag))
 150
 151 (defsubst semantic--tag-set-overlay (tag overlay)
 152   "Set the overlay part of TAG with OVERLAY.
 153 That function is for internal use only."
 154   (setcar (semantic--tag-overlay-cdr tag) overlay))
 155
 156 (defsubst semantic-tag-start (tag)
 157   "Return the start location of TAG."
 158   (let ((o (semantic-tag-overlay tag)))
 159     (if (semantic-overlay-p o)
 160         (semantic-overlay-start o)
 161       (aref o 0))))
 162
 163 (defsubst semantic-tag-end (tag)
 164   "Return the end location of TAG."
 165   (let ((o (semantic-tag-overlay tag)))
 166     (if (semantic-overlay-p o)
 167         (semantic-overlay-end o)
 168       (aref o 1))))
 169
 170 (defsubst semantic-tag-bounds (tag)
 171   "Return the location (START END) of data TAG describes."
 172   (list (semantic-tag-start tag)
 173         (semantic-tag-end tag)))
 174
 175 (defun semantic-tag-set-bounds (tag start end)
 176   "In TAG, set the START and END location of data it describes."
 177   (let ((o (semantic-tag-overlay tag)))
 178     (if (semantic-overlay-p o)
 179         (semantic-overlay-move o start end)
 180       (semantic--tag-set-overlay tag (vector start end)))))
 181
 182 (defun semantic-tag-in-buffer-p (tag)
 183   "Return the buffer TAG resides in IFF tag is already in a buffer.
 184 If a tag is not in a buffer, return nil."
 185   (let ((o (semantic-tag-overlay tag)))
 186      ;; TAG is currently linked to a buffer, return it.
 187     (when (and (semantic-overlay-p o)
 188                (semantic-overlay-live-p o))
 189       (semantic-overlay-buffer o))))
 190
 191 (defsubst semantic--tag-get-property (tag property)
 192   "From TAG, extract the value of PROPERTY.
 193 Return the value found, or nil if PROPERTY is not one of the
 194 properties of TAG.
 195 That function is for internal use only."
 196   (plist-get (semantic-tag-properties tag) property))
 197
 198 (defun semantic-tag-buffer (tag)
 199   "Return the buffer TAG resides in.
 200 If TAG has an originating file, read that file into a (maybe new)
 201 buffer, and return it.
 202 Return nil if there is no buffer for this tag."
 203   (let ((buff (semantic-tag-in-buffer-p tag)))
 204     (if buff
 205         buff
 206       ;; TAG has an originating file, read that file into a buffer, and
 207       ;; return it.
 208      (if (semantic--tag-get-property tag :filename)
 209          (find-file-noselect (semantic--tag-get-property tag :filename))
 210        ;; TAG is not in Emacs right now, no buffer is available.
 211        ))))
 212
 213 (defun semantic-tag-mode (&optional tag)
 214   "Return the major mode active for TAG.
 215 TAG defaults to the tag at point in current buffer.
 216 If TAG has a :mode property return it.
 217 If point is inside TAG bounds, return the major mode active at point.
 218 Return the major mode active at beginning of TAG otherwise.
 219 See also the function `semantic-ctxt-current-mode'."
 220   (require 'semantic/find)
 221   (or tag (setq tag (semantic-current-tag)))
 222   (or (semantic--tag-get-property tag :mode)
 223       (let ((buffer (semantic-tag-buffer tag))
 224             (start (semantic-tag-start tag))
 225             (end   (semantic-tag-end tag)))
 226         (save-excursion
 227           (and buffer (set-buffer buffer))
 228           ;; Unless point is inside TAG bounds, move it to the
 229           ;; beginning of TAG.
 230           (or (and (>= (point) start) (< (point) end))
 231               (goto-char start))
 232           (require 'semantic/ctxt)
 233           (semantic-ctxt-current-mode)))))
 234
 235 (defsubst semantic--tag-attributes-cdr (tag)
 236   "Return the cons cell whose car is the ATTRIBUTES part of TAG.
 237 That function is for internal use only."
 238   (nthcdr 2 tag))
 239
 240 (defsubst semantic-tag-put-attribute (tag attribute value)
 241   "Change value in TAG of ATTRIBUTE to VALUE.
 242 If ATTRIBUTE already exists, its value is set to VALUE, otherwise the
 243 new ATTRIBUTE VALUE pair is added.
 244 Return TAG.
 245 Use this function in a parser when not all attributes are known at the
 246 same time."
 247   (let* ((plist-cdr (semantic--tag-attributes-cdr tag)))
 248     (when (consp plist-cdr)
 249       (setcar plist-cdr
 250               (semantic-tag-make-plist
 251                (plist-put (car plist-cdr) attribute value))))
 252     tag))
 253
 254 (defun semantic-tag-put-attribute-no-side-effect (tag attribute value)
 255   "Change value in TAG of ATTRIBUTE to VALUE without side effects.
 256 All cons cells in the attribute list are replicated so that there
 257 are no side effects if TAG is in shared lists.
 258 If ATTRIBUTE already exists, its value is set to VALUE, otherwise the
 259 new ATTRIBUTE VALUE pair is added.
 260 Return TAG."
 261   (let* ((plist-cdr (semantic--tag-attributes-cdr tag)))
 262     (when (consp plist-cdr)
 263       (setcar plist-cdr
 264               (semantic-tag-make-plist
 265                (plist-put (copy-sequence (car plist-cdr))
 266                           attribute value))))
 267     tag))
 268
 269 (defsubst semantic-tag-get-attribute (tag attribute)
 270   "From TAG, return the value of ATTRIBUTE.
 271 ATTRIBUTE is a symbol whose specification value to get.
 272 Return the value found, or nil if ATTRIBUTE is not one of the
 273 attributes of TAG."
 274   (plist-get (semantic-tag-attributes tag) attribute))
 275
 276 ;; These functions are for internal use only!
 277 (defsubst semantic--tag-properties-cdr (tag)
 278   "Return the cons cell whose car is the PROPERTIES part of TAG.
 279 That function is for internal use only."
 280   (nthcdr 3 tag))
 281
 282 (defun semantic--tag-put-property (tag property value)
 283   "Change value in TAG of PROPERTY to VALUE.
 284 If PROPERTY already exists, its value is set to VALUE, otherwise the
 285 new PROPERTY VALUE pair is added.
 286 Return TAG.
 287 That function is for internal use only."
 288   (let* ((plist-cdr (semantic--tag-properties-cdr tag)))
 289     (when (consp plist-cdr)
 290       (setcar plist-cdr
 291               (semantic-tag-make-plist
 292                (plist-put (car plist-cdr) property value))))
 293     tag))
 294
 295 (defun semantic--tag-put-property-no-side-effect (tag property value)
 296   "Change value in TAG of PROPERTY to VALUE without side effects.
 297 All cons cells in the property list are replicated so that there
 298 are no side effects if TAG is in shared lists.
 299 If PROPERTY already exists, its value is set to VALUE, otherwise the
 300 new PROPERTY VALUE pair is added.
 301 Return TAG.
 302 That function is for internal use only."
 303   (let* ((plist-cdr (semantic--tag-properties-cdr tag)))
 304     (when (consp plist-cdr)
 305       (setcar plist-cdr
 306               (semantic-tag-make-plist
 307                (plist-put (copy-sequence (car plist-cdr))
 308                           property value))))
 309     tag))
 310
 311 (defun semantic-tag-file-name (tag)
 312   "Return the name of the file from which TAG originated.
 313 Return nil if that information can't be obtained.
 314 If TAG is from a loaded buffer, then that buffer's filename is used.
 315 If TAG is unlinked, but has a :filename property, then that is used."
 316   (let ((buffer (semantic-tag-in-buffer-p tag)))
 317     (if buffer
 318         (buffer-file-name buffer)
 319       (semantic--tag-get-property tag :filename))))
 320 \f
 321 ;;; Tag tests and comparisons.
 322 (defsubst semantic-tag-p (tag)
 323   "Return non-nil if TAG is most likely a semantic tag."
 324   (condition-case nil
 325       (and (consp tag)
 326            (stringp (car tag))                ; NAME
 327            (symbolp (nth 1 tag)) (nth 1 tag)  ; TAG-CLASS
 328            (listp (nth 2 tag))                ; ATTRIBUTES
 329            (listp (nth 3 tag))                ; PROPERTIES
 330            )
 331     ;; If an error occurs, then it most certainly is not a tag.
 332     (error nil)))
 333
 334 (defsubst semantic-tag-of-class-p (tag class)
 335   "Return non-nil if class of TAG is CLASS."
 336   (eq (semantic-tag-class tag) class))
 337
 338 (defsubst semantic-tag-type-members (tag)
 339   "Return the members of the type that TAG describes.
 340 That is the value of the `:members' attribute."
 341   (semantic-tag-get-attribute tag :members))
 342
 343 (defun semantic-tag-with-position-p (tag)
 344   "Return non-nil if TAG has positional information."
 345   (and (semantic-tag-p tag)
 346        (let ((o (semantic-tag-overlay tag)))
 347          (or (and (semantic-overlay-p o)
 348                   (semantic-overlay-live-p o))
 349              (arrayp o)))))
 350
 351 (defun semantic-equivalent-tag-p (tag1 tag2)
 352   "Compare TAG1 and TAG2 and return non-nil if they are equivalent.
 353 Use `equal' on elements the name, class, and position.
 354 Use this function if tags are being copied and regrouped to test
 355 for if two tags represent the same thing, but may be constructed
 356 of different cons cells."
 357   (and (equal (semantic-tag-name tag1) (semantic-tag-name tag2))
 358        (semantic-tag-of-class-p tag1 (semantic-tag-class tag2))
 359        (or (and (not (semantic-tag-overlay tag1))
 360                 (not (semantic-tag-overlay tag2)))
 361            (and (semantic-tag-overlay tag1)
 362                 (semantic-tag-overlay tag2)
 363                 (equal (semantic-tag-bounds tag1)
 364                        (semantic-tag-bounds tag2))))))
 365
 366 (defsubst semantic-tag-type (tag)
 367   "Return the value of the `:type' attribute of TAG.
 368 For a function it would be the data type of the return value.
 369 For a variable, it is the storage type of that variable.
 370 For a data type, the type is the style of datatype, such as
 371 struct or union."
 372   (semantic-tag-get-attribute tag :type))
 373
 374 (defun semantic-tag-similar-p (tag1 tag2 &rest ignorable-attributes)
 375   "Test to see if TAG1 and TAG2 are similar.
 376 Two tags are similar if their name, datatype, and various attributes
 377 are the same.
 378
 379 Similar tags that have sub-tags such as arg lists or type members,
 380 are similar w/out checking the sub-list of tags.
 381 Optional argument IGNORABLE-ATTRIBUTES are attributes to ignore while comparing similarity."
 382   (let* ((A1 (and (equal (semantic-tag-name tag1) (semantic-tag-name tag2))
 383                   (semantic-tag-of-class-p tag1 (semantic-tag-class tag2))
 384                   (semantic-tag-of-type-p tag1 (semantic-tag-type tag2))))
 385          (attr1 (semantic-tag-attributes tag1))
 386          (A2 (= (length attr1) (length (semantic-tag-attributes tag2))))
 387          (A3 t)
 388          )
 389     (when (and (not A2) ignorable-attributes)
 390       (setq A2 t))
 391     (while (and A2 attr1 A3)
 392       (let ((a (car attr1))
 393             (v (car (cdr attr1))))
 394
 395         (cond ((or (eq a :type) ;; already tested above.
 396                    (memq a ignorable-attributes)) ;; Ignore them...
 397                nil)
 398
 399               ;; Don't test sublists of tags
 400               ((and (listp v) (semantic-tag-p (car v)))
 401                nil)
 402
 403               ;; The attributes are not the same?
 404               ((not (equal v (semantic-tag-get-attribute tag2 a)))
 405                (setq A3 nil))
 406               (t
 407                nil))
 408         )
 409       (setq attr1 (cdr (cdr attr1))))
 410
 411     (and A1 A2 A3)
 412     ))
 413
 414 (defun semantic-tag-similar-with-subtags-p (tag1 tag2 &rest ignorable-attributes)
 415   "Test to see if TAG1 and TAG2 are similar.
 416 Uses `semantic-tag-similar-p' but also recurses through sub-tags, such
 417 as argument lists and type members.
 418 Optional argument IGNORABLE-ATTRIBUTES is passed down to
 419 `semantic-tag-similar-p'."
 420   (let ((C1 (semantic-tag-components tag1))
 421         (C2 (semantic-tag-components tag2))
 422         )
 423     (if (or (/= (length C1) (length C2))
 424             (not (semantic-tag-similar-p tag1 tag2 ignorable-attributes))
 425             )
 426         ;; Basic test fails.
 427         nil
 428       ;; Else, check component lists.
 429       (catch 'component-dissimilar
 430         (while C1
 431
 432           (if (not (semantic-tag-similar-with-subtags-p
 433                     (car C1) (car C2) ignorable-attributes))
 434               (throw 'component-dissimilar nil))
 435
 436           (setq C1 (cdr C1))
 437           (setq C2 (cdr C2))
 438           )
 439         ;; If we made it this far, we are ok.
 440         t) )))
 441
 442
 443 (defun semantic-tag-of-type-p (tag type)
 444   "Compare TAG's type against TYPE.  Non nil if equivalent.
 445 TYPE can be a string, or a tag of class 'type.
 446 This can be complex since some tags might have a :type that is a tag,
 447 while other tags might just have a string.  This function will also be
 448 return true of TAG's type is compared directly to the declaration of a
 449 data type."
 450   (let* ((tagtype (semantic-tag-type tag))
 451          (tagtypestring (cond ((stringp tagtype)
 452                                tagtype)
 453                               ((and (semantic-tag-p tagtype)
 454                                     (semantic-tag-of-class-p tagtype 'type))
 455                                (semantic-tag-name tagtype))
 456                               (t "")))
 457          (typestring (cond ((stringp type)
 458                             type)
 459                            ((and (semantic-tag-p type)
 460                                  (semantic-tag-of-class-p type 'type))
 461                             (semantic-tag-name type))
 462                            (t "")))
 463          )
 464     (and
 465      tagtypestring
 466      (or
 467       ;; Matching strings (input type is string)
 468       (and (stringp type)
 469            (string= tagtypestring type))
 470       ;; Matching strings (tag type is string)
 471       (and (stringp tagtype)
 472            (string= tagtype typestring))
 473       ;; Matching tokens, and the type of the type is the same.
 474       (and (string= tagtypestring typestring)
 475            (if (and (semantic-tag-type tagtype) (semantic-tag-type type))
 476                (equal (semantic-tag-type tagtype) (semantic-tag-type type))
 477              t))
 478       ))
 479     ))
 480
 481 (defun semantic-tag-type-compound-p (tag)
 482   "Return non-nil the type of TAG is compound.
 483 Compound implies a structure or similar data type.
 484 Returns the list of tag members if it is compound."
 485   (let* ((tagtype (semantic-tag-type tag))
 486          )
 487     (when (and (semantic-tag-p tagtype)
 488                (semantic-tag-of-class-p tagtype 'type))
 489       ;; We have the potential of this being a nifty compound type.
 490       (semantic-tag-type-members tagtype)
 491       )))
 492
 493 (defun semantic-tag-faux-p (tag)
 494   "Return non-nil if TAG is a FAUX tag.
 495 FAUX tags are created to represent a construct that is
 496 not known to exist in the code.
 497
 498 Example: When the class browser sees methods to a class, but
 499 cannot find the class, it will create a faux tag to represent the
 500 class to store those methods."
 501   (semantic--tag-get-property tag :faux-flag))
 502 \f
 503 ;;; Tag creation
 504 ;;
 505
 506 ;; Is this function still necessary?
 507 (defun semantic-tag-make-plist (args)
 508   "Create a property list with ARGS.
 509 Args is a property list of the form (KEY1 VALUE1 ... KEYN VALUEN).
 510 Where KEY is a symbol, and VALUE is the value for that symbol.
 511 The return value will be a new property list, with these KEY/VALUE
 512 pairs eliminated:
 513
 514   - KEY associated to nil VALUE.
 515   - KEY associated to an empty string VALUE.
 516   - KEY associated to a zero VALUE."
 517   (let (plist key val)
 518     (while args
 519       (setq key  (car args)
 520             val  (nth 1 args)
 521             args (nthcdr 2 args))
 522       (or (member val '("" nil))
 523           (and (numberp val) (zerop val))
 524           (setq plist (cons key (cons val plist)))))
 525     ;; It is not useful to reverse the new plist.
 526     plist))
 527
 528 (defsubst semantic-tag (name class &rest attributes)
 529   "Create a generic semantic tag.
 530 NAME is a string representing the name of this tag.
 531 CLASS is the symbol that represents the class of tag this is,
 532 such as 'variable, or 'function.
 533 ATTRIBUTES is a list of additional attributes belonging to this tag."
 534   (list name class (semantic-tag-make-plist attributes) nil nil))
 535
 536 (defsubst semantic-tag-new-variable (name type &optional default-value &rest attributes)
 537   "Create a semantic tag of class 'variable.
 538 NAME is the name of this variable.
 539 TYPE is a string or semantic tag representing the type of this variable.
 540 Optional DEFAULT-VALUE is a string representing the default value of this variable.
 541 ATTRIBUTES is a list of additional attributes belonging to this tag."
 542   (apply 'semantic-tag name 'variable
 543          :type type
 544          :default-value default-value
 545          attributes))
 546
 547 (defsubst semantic-tag-new-function (name type arg-list &rest attributes)
 548   "Create a semantic tag of class 'function.
 549 NAME is the name of this function.
 550 TYPE is a string or semantic tag representing the type of this function.
 551 ARG-LIST is a list of strings or semantic tags representing the
 552 arguments of this function.
 553 ATTRIBUTES is a list of additional attributes belonging to this tag."
 554   (apply 'semantic-tag name 'function
 555          :type type
 556          :arguments arg-list
 557          attributes))
 558
 559 (defsubst semantic-tag-new-type (name type members parents &rest attributes)
 560   "Create a semantic tag of class 'type.
 561 NAME is the name of this type.
 562 TYPE is a string or semantic tag representing the type of this type.
 563 MEMBERS is a list of strings or semantic tags representing the
 564 elements that make up this type if it is a composite type.
 565 PARENTS is a cons cell.  (EXPLICIT-PARENTS . INTERFACE-PARENTS)
 566 EXPLICIT-PARENTS can be a single string (Just one parent) or a
 567 list of parents (in a multiple inheritance situation).  It can also
 568 be nil.
 569 INTERFACE-PARENTS is a list of strings representing the names of
 570 all INTERFACES, or abstract classes inherited from.  It can also be
 571 nil.
 572 This slot can be interesting because the form:
 573      ( nil \"string\")
 574 is a valid parent where there is no explicit parent, and only an
 575 interface.
 576 ATTRIBUTES is a list of additional attributes belonging to this tag."
 577   (apply 'semantic-tag name 'type
 578          :type type
 579          :members members
 580          :superclasses (car parents)
 581          :interfaces (cdr parents)
 582          attributes))
 583
 584 (defsubst semantic-tag-new-include (name system-flag &rest attributes)
 585   "Create a semantic tag of class 'include.
 586 NAME is the name of this include.
 587 SYSTEM-FLAG represents that we were able to identify this include as belonging
 588 to the system, as opposed to belonging to the local project.
 589 ATTRIBUTES is a list of additional attributes belonging to this tag."
 590   (apply 'semantic-tag name 'include
 591          :system-flag system-flag
 592          attributes))
 593
 594 (defsubst semantic-tag-new-package (name detail &rest attributes)
 595   "Create a semantic tag of class 'package.
 596 NAME is the name of this package.
 597 DETAIL is extra information about this package, such as a location where
 598 it can be found.
 599 ATTRIBUTES is a list of additional attributes belonging to this tag."
 600   (apply 'semantic-tag name 'package
 601          :detail detail
 602          attributes))
 603
 604 (defsubst semantic-tag-new-code (name detail &rest attributes)
 605   "Create a semantic tag of class 'code.
 606 NAME is a name for this code.
 607 DETAIL is extra information about the code.
 608 ATTRIBUTES is a list of additional attributes belonging to this tag."
 609   (apply 'semantic-tag name 'code
 610          :detail detail
 611          attributes))
 612
 613 (defsubst semantic-tag-set-faux (tag)
 614   "Set TAG to be a new FAUX tag.
 615 FAUX tags represent constructs not found in the source code.
 616 You can identify a faux tag with `semantic-tag-faux-p'"
 617   (semantic--tag-put-property tag :faux-flag t))
 618
 619 (defsubst semantic-tag-set-name (tag name)
 620   "Set TAG name to NAME."
 621   (setcar tag name))
 622
 623 ;;; Copying and cloning tags.
 624 ;;
 625 (defsubst semantic-tag-clone (tag &optional name)
 626   "Clone TAG, creating a new TAG.
 627 If optional argument NAME is not nil it specifies a new name for the
 628 cloned tag."
 629   ;; Right now, TAG is a list.
 630   (list (or name (semantic-tag-name tag))
 631         (semantic-tag-class tag)
 632         (copy-sequence (semantic-tag-attributes tag))
 633         (copy-sequence (semantic-tag-properties tag))
 634         (semantic-tag-overlay tag)))
 635
 636 (defun semantic-tag-copy (tag &optional name keep-file)
 637   "Return a copy of TAG unlinked from the originating buffer.
 638 If optional argument NAME is non-nil it specifies a new name for the
 639 copied tag.
 640 If optional argument KEEP-FILE is non-nil, and TAG was linked to a
 641 buffer, the originating buffer file name is kept in the `:filename'
 642 property of the copied tag.
 643 If KEEP-FILE is a string, and the orginating buffer is NOT available,
 644 then KEEP-FILE is stored on the `:filename' property.
 645 This runs the tag hook `unlink-copy-hook`."
 646   ;; Right now, TAG is a list.
 647   (let ((copy (semantic-tag-clone tag name)))
 648
 649     ;; Keep the filename if needed.
 650     (when keep-file
 651       (semantic--tag-put-property
 652        copy :filename (or (semantic-tag-file-name copy)
 653                           (and (stringp keep-file)
 654                                keep-file)
 655                           )))
 656
 657     (when (semantic-tag-with-position-p tag)
 658       ;; Convert the overlay to a vector, effectively 'unlinking' the tag.
 659       (semantic--tag-set-overlay
 660        copy (vector (semantic-tag-start copy) (semantic-tag-end copy)))
 661
 662       ;; Force the children to be copied also.
 663       ;;(let ((chil (semantic--tag-copy-list
 664       ;;             (semantic-tag-components-with-overlays tag)
 665       ;;             keep-file)))
 666       ;;;; Put the list into TAG.
 667       ;;)
 668
 669       ;; Call the unlink-copy hook.  This should tell tools that
 670       ;; this tag is not part of any buffer.
 671       (when (semantic-overlay-p (semantic-tag-overlay tag))
 672         (semantic--tag-run-hooks copy 'unlink-copy-hook))
 673       )
 674     copy))
 675
 676 ;;(defun semantic--tag-copy-list (tags &optional keep-file)
 677 ;;  "Make copies of TAGS and return the list of TAGS."
 678 ;;  (let ((out nil))
 679 ;;    (dolist (tag tags out)
 680 ;;      (setq out (cons (semantic-tag-copy tag nil keep-file)
 681 ;;                    out))
 682 ;;      )))
 683
 684 (defun semantic--tag-copy-properties (tag1 tag2)
 685   "Copy private properties from TAG1 to TAG2.
 686 Return TAG2.
 687 This function is for internal use only."
 688   (let ((plist (semantic-tag-properties tag1)))
 689     (while plist
 690       (semantic--tag-put-property tag2 (car plist) (nth 1 plist))
 691       (setq plist (nthcdr 2 plist)))
 692     tag2))
 693
 694 ;;; DEEP COPIES
 695 ;;
 696 (defun semantic-tag-deep-copy-one-tag (tag &optional filter)
 697   "Make a deep copy of TAG, applying FILTER to each child-tag.
 698 Properties and overlay info are not copied.
 699 FILTER takes TAG as an argument, and should returns a semantic-tag.
 700 It is safe for FILTER to modify the input tag and return it."
 701   (when (not filter) (setq filter 'identity))
 702   (when (not (semantic-tag-p tag))
 703     (signal 'wrong-type-argument (list tag 'semantic-tag-p)))
 704   (funcall filter (list (semantic-tag-name tag)
 705                         (semantic-tag-class tag)
 706                         (semantic--tag-deep-copy-attributes
 707                          (semantic-tag-attributes tag) filter)
 708                         nil
 709                         nil)))
 710
 711 (defun semantic--tag-deep-copy-attributes (attrs &optional filter)
 712   "Make a deep copy of ATTRS, applying FILTER to each child-tag.
 713
 714 It is safe to modify ATTR, and return a permutaion of that list.
 715
 716 FILTER takes TAG as an argument, and should returns a semantic-tag.
 717 It is safe for FILTER to modify the input tag and return it."
 718   (when (car attrs)
 719     (when (not (symbolp (car attrs))) (error "Bad Attribute List in tag"))
 720     (cons (car attrs)
 721           (cons (semantic--tag-deep-copy-value (nth 1 attrs) filter)
 722                 (semantic--tag-deep-copy-attributes (nthcdr 2 attrs) filter)))))
 723
 724 (defun semantic--tag-deep-copy-value (value &optional filter)
 725   "Make a deep copy of VALUE, applying FILTER to each child-tag.
 726
 727 It is safe to  modify VALUE, and return a permutaion of that list.
 728
 729 FILTER takes TAG as an argument, and should returns a semantic-tag.
 730 It is safe for FILTER to modify the input tag and return it."
 731   (cond
 732    ;; Another tag.
 733    ((semantic-tag-p value)
 734     (semantic-tag-deep-copy-one-tag value filter))
 735
 736    ;; A list of more tags
 737    ((and (listp value) (semantic-tag-p (car value)))
 738     (semantic--tag-deep-copy-tag-list value filter))
 739
 740    ;; Some arbitrary data.
 741    (t value)))
 742
 743 (defun semantic--tag-deep-copy-tag-list (tags &optional filter)
 744   "Make a deep copy of TAGS, applying FILTER to each child-tag.
 745
 746 It is safe to modify the TAGS list, and return a permutaion of that list.
 747
 748 FILTER takes TAG as an argument, and should returns a semantic-tag.
 749 It is safe for FILTER to modify the input tag and return it."
 750   (when (car tags)
 751     (if (semantic-tag-p (car tags))
 752         (cons (semantic-tag-deep-copy-one-tag (car tags) filter)
 753               (semantic--tag-deep-copy-tag-list (cdr tags) filter))
 754       (cons (car tags) (semantic--tag-deep-copy-tag-list (cdr tags) filter)))))
 755
 756 \f
 757 ;;; Standard Tag Access
 758 ;;
 759
 760 ;;; Common
 761 ;;
 762
 763 (defsubst semantic-tag-modifiers (tag)
 764   "Return the value of the `:typemodifiers' attribute of TAG."
 765   (semantic-tag-get-attribute tag :typemodifiers))
 766
 767 (defun semantic-tag-docstring (tag &optional buffer)
 768   "Return the documentation of TAG.
 769 That is the value defined by the `:documentation' attribute.
 770 Optional argument BUFFER indicates where to get the text from.
 771 If not provided, then only the POSITION can be provided.
 772
 773 If you want to get documentation for languages that do not store
 774 the documentation string in the tag itself, use
 775 `semantic-documentation-for-tag' instead."
 776   (let ((p (semantic-tag-get-attribute tag :documentation)))
 777     (cond
 778      ((stringp p) p) ;; it is the doc string.
 779
 780      ((semantic-lex-token-with-text-p p)
 781       (semantic-lex-token-text p))
 782
 783      ((and (semantic-lex-token-without-text-p p)
 784            buffer)
 785       (with-current-buffer buffer
 786         (semantic-lex-token-text (car (semantic-lex p (1+ p))))))
 787
 788      (t nil))))
 789
 790 ;;; Generic attributes for tags of any class.
 791 ;;
 792 (defsubst semantic-tag-named-parent (tag)
 793   "Return the parent of TAG.
 794 That is the value of the `:parent' attribute.
 795 If a definition can occur outside an actual parent structure, but
 796 refers to that parent by name, then the :parent attribute should be used."
 797   (semantic-tag-get-attribute tag :parent))
 798
 799 ;;; Tags of class `type'
 800
 801 (defun semantic-tag-type-superclasses (tag)
 802   "Return the list of superclass names of the type that TAG describes."
 803   (let ((supers (semantic-tag-get-attribute tag :superclasses)))
 804     (cond ((stringp supers)
 805            ;; If we have a string, make it a list.
 806            (list supers))
 807           ((semantic-tag-p supers)
 808            ;; If we have one tag, return just the name.
 809            (list (semantic-tag-name supers)))
 810           ((and (consp supers) (semantic-tag-p (car supers)))
 811            ;; If we have a tag list, then return the names.
 812            (mapcar (lambda (s) (semantic-tag-name s))
 813                    supers))
 814           ((consp supers)
 815            ;; A list of something, return it.
 816            supers))))
 817
 818 (defun semantic--tag-find-parent-by-name (name supers)
 819   "Find the superclass NAME in the list of SUPERS.
 820 If a simple search doesn't do it, try splitting up the names
 821 in SUPERS."
 822   (let ((stag nil))
 823     (setq stag (semantic-find-first-tag-by-name name supers))
 824     (when (not stag)
 825       (require 'semantic/analyze/fcn)
 826       (dolist (S supers)
 827         (let* ((sname (semantic-tag-name S))
 828                (splitparts (semantic-analyze-split-name sname))
 829                (parts (if (stringp splitparts)
 830                           (list splitparts)
 831                         (nreverse splitparts))))
 832           (when (string= name (car parts))
 833             (setq stag S))
 834           )))
 835
 836     stag))
 837
 838 (defun semantic-tag-type-superclass-protection (tag parentstring)
 839   "Return the inheritance protection in TAG from PARENTSTRING.
 840 PARENTSTRING is the name of the parent being inherited.
 841 The return protection is a symbol, 'public, 'protection, and 'private."
 842   (let ((supers (semantic-tag-get-attribute tag :superclasses)))
 843     (cond ((stringp supers)
 844            'public)
 845           ((semantic-tag-p supers)
 846            (let ((prot (semantic-tag-get-attribute supers :protection)))
 847              (or (cdr (assoc prot '(("public" . public)
 848                                     ("protected" . protected)
 849                                     ("private" . private))))
 850                  'public)))
 851           ((and (consp supers) (stringp (car supers)))
 852            'public)
 853           ((and (consp supers) (semantic-tag-p (car supers)))
 854            (let* ((stag (semantic--tag-find-parent-by-name parentstring supers))
 855                   (prot (when stag
 856                           (semantic-tag-get-attribute stag :protection))))
 857              (or (cdr (assoc prot '(("public" . public)
 858                                     ("protected" . protected)
 859                                     ("private" . private))))
 860                  (when (equal prot "unspecified")
 861                    (if (semantic-tag-of-type-p tag "class")
 862                        'private
 863                      'public))
 864                  'public))))
 865     ))
 866
 867 (defsubst semantic-tag-type-interfaces (tag)
 868   "Return the list of interfaces of the type that TAG describes."
 869   ;; @todo - make this as robust as the above.
 870   (semantic-tag-get-attribute tag :interfaces))
 871
 872 ;;; Tags of class `function'
 873 ;;
 874 (defsubst semantic-tag-function-arguments (tag)
 875   "Return the arguments of the function that TAG describes.
 876 That is the value of the `:arguments' attribute."
 877   (semantic-tag-get-attribute tag :arguments))
 878
 879 (defsubst semantic-tag-function-throws (tag)
 880   "Return the exceptions the function that TAG describes can throw.
 881 That is the value of the `:throws' attribute."
 882   (semantic-tag-get-attribute tag :throws))
 883
 884 (defsubst semantic-tag-function-parent (tag)
 885   "Return the parent of the function that TAG describes.
 886 That is the value of the `:parent' attribute.
 887 A function has a parent if it is a method of a class, and if the
 888 function does not appear in body of it's parent class."
 889   (semantic-tag-named-parent tag))
 890
 891 (defsubst semantic-tag-function-destructor-p (tag)
 892   "Return non-nil if TAG describes a destructor function.
 893 That is the value of the `:destructor-flag' attribute."
 894   (semantic-tag-get-attribute tag :destructor-flag))
 895
 896 (defsubst semantic-tag-function-constructor-p (tag)
 897   "Return non-nil if TAG describes a constructor function.
 898 That is the value of the `:constructor-flag' attribute."
 899   (semantic-tag-get-attribute tag :constructor-flag))
 900
 901 ;;; Tags of class `variable'
 902 ;;
 903 (defsubst semantic-tag-variable-default (tag)
 904   "Return the default value of the variable that TAG describes.
 905 That is the value of the attribute `:default-value'."
 906   (semantic-tag-get-attribute tag :default-value))
 907
 908 (defsubst semantic-tag-variable-constant-p (tag)
 909   "Return non-nil if the variable that TAG describes is a constant.
 910 That is the value of the attribute `:constant-flag'."
 911   (semantic-tag-get-attribute tag :constant-flag))
 912
 913 ;;; Tags of class `include'
 914 ;;
 915 (defsubst semantic-tag-include-system-p (tag)
 916   "Return non-nil if the include that TAG describes is a system include.
 917 That is the value of the attribute `:system-flag'."
 918   (semantic-tag-get-attribute tag :system-flag))
 919
 920 (define-overloadable-function semantic-tag-include-filename (tag)
 921   "Return a filename representation of TAG.
 922 The default action is to return the `semantic-tag-name'.
 923 Some languages do not use full filenames in their include statements.
 924 Override this method to translate the code represenation
 925 into a filename.  (A relative filename if necessary.)
 926
 927 See `semantic-dependency-tag-file' to expand an include
 928 tag to a full file name.")
 929
 930 (defun semantic-tag-include-filename-default (tag)
 931   "Return a filename representation of TAG.
 932 Returns `semantic-tag-name'."
 933   (semantic-tag-name tag))
 934
 935 ;;; Tags of class `code'
 936 ;;
 937 (defsubst semantic-tag-code-detail (tag)
 938   "Return detail information from code that TAG describes.
 939 That is the value of the attribute `:detail'."
 940   (semantic-tag-get-attribute tag :detail))
 941
 942 ;;; Tags of class `alias'
 943 ;;
 944 (defsubst semantic-tag-new-alias (name meta-tag-class value &rest attributes)
 945   "Create a semantic tag of class alias.
 946 NAME is a name for this alias.
 947 META-TAG-CLASS is the class of the tag this tag is an alias.
 948 VALUE is the aliased definition.
 949 ATTRIBUTES is a list of additional attributes belonging to this tag."
 950   (apply 'semantic-tag name 'alias
 951          :aliasclass meta-tag-class
 952          :definition value
 953          attributes))
 954
 955 (defsubst semantic-tag-alias-class (tag)
 956   "Return the class of tag TAG is an alias."
 957   (semantic-tag-get-attribute tag :aliasclass))
 958
 959 (define-overloadable-function semantic-tag-alias-definition (tag)
 960   "Return the definition TAG is an alias.
 961 The returned value is a tag of the class that
 962 `semantic-tag-alias-class' returns for TAG.
 963 The default is to return the value of the :definition attribute.
 964 Return nil if TAG is not of class 'alias."
 965   (when (semantic-tag-of-class-p tag 'alias)
 966     (:override
 967      (semantic-tag-get-attribute tag :definition))))
 968
 969 ;;; Language Specific Tag access via overload
 970 ;;
 971 (define-overloadable-function semantic-tag-components (tag)
 972   "Return a list of components for TAG.
 973 A Component is a part of TAG which itself may be a TAG.
 974 Examples include the elements of a structure in a
 975 tag of class `type, or the list of arguments to a
 976 tag of class 'function."
 977   )
 978
 979 (defun semantic-tag-components-default (tag)
 980   "Return a list of components for TAG.
 981 Perform the described task in `semantic-tag-components'."
 982   (cond ((semantic-tag-of-class-p tag 'type)
 983          (semantic-tag-type-members tag))
 984         ((semantic-tag-of-class-p tag 'function)
 985          (semantic-tag-function-arguments tag))
 986         (t nil)))
 987
 988 (define-overloadable-function semantic-tag-components-with-overlays (tag)
 989   "Return the list of top level components belonging to TAG.
 990 Children are any sub-tags which contain overlays.
 991
 992 Default behavior is to get `semantic-tag-components' in addition
 993 to the components of an anonymous types (if applicable.)
 994
 995 Note for language authors:
 996   If a mode defines a language tag that has tags in it with overlays
 997 you should still return them with this function.
 998 Ignoring this step will prevent several features from working correctly."
 999   )
1000
1001 (defun semantic-tag-components-with-overlays-default (tag)
1002   "Return the list of top level components belonging to TAG.
1003 Children are any sub-tags which contain overlays.
1004 The default action collects regular components of TAG, in addition
1005 to any components beloning to an anonymous type."
1006   (let ((explicit-children (semantic-tag-components tag))
1007         (type (semantic-tag-type tag))
1008         (anon-type-children nil)
1009         (all-children nil))
1010     ;; Identify if this tag has an anonymous structure as
1011     ;; its type.  This implies it may have children with overlays.
1012     (when (and type (semantic-tag-p type))
1013       (setq anon-type-children (semantic-tag-components type))
1014       ;; Add anonymous children
1015       (while anon-type-children
1016         (when (semantic-tag-with-position-p (car anon-type-children))
1017           (setq all-children (cons (car anon-type-children) all-children)))
1018         (setq anon-type-children (cdr anon-type-children))))
1019     ;; Add explicit children
1020     (while explicit-children
1021       (when (semantic-tag-with-position-p (car explicit-children))
1022         (setq all-children (cons (car explicit-children) all-children)))
1023       (setq explicit-children (cdr explicit-children)))
1024     ;; Return
1025     (nreverse all-children)))
1026
1027 (defun semantic-tag-children-compatibility (tag &optional positiononly)
1028   "Return children of TAG.
1029 If POSITIONONLY is nil, use `semantic-tag-components'.
1030 If POSITIONONLY is non-nil, use `semantic-tag-components-with-overlays'.
1031 DO NOT use this fcn in new code.  Use one of the above instead."
1032   (if positiononly
1033       (semantic-tag-components-with-overlays tag)
1034     (semantic-tag-components tag)))
1035 \f
1036 ;;; Tag Region
1037 ;;
1038 ;; A Tag represents a region in a buffer.  You can narrow to that tag.
1039 ;;
1040 (defun semantic-narrow-to-tag (&optional tag)
1041   "Narrow to the region specified by the bounds of TAG.
1042 See `semantic-tag-bounds'."
1043   (interactive)
1044   (if (not tag) (setq tag (semantic-current-tag)))
1045   (narrow-to-region (semantic-tag-start tag)
1046                     (semantic-tag-end tag)))
1047
1048 (defmacro semantic-with-buffer-narrowed-to-current-tag (&rest body)
1049   "Execute BODY with the buffer narrowed to the current tag."
1050   `(save-restriction
1051      (semantic-narrow-to-tag (semantic-current-tag))
1052      ,@body))
1053 (put 'semantic-with-buffer-narrowed-to-current-tag 'lisp-indent-function 0)
1054 (add-hook 'edebug-setup-hook
1055           (lambda ()
1056             (def-edebug-spec semantic-with-buffer-narrowed-to-current-tag
1057               (def-body))))
1058
1059 (defmacro semantic-with-buffer-narrowed-to-tag (tag &rest body)
1060   "Narrow to TAG, and execute BODY."
1061   `(save-restriction
1062      (semantic-narrow-to-tag ,tag)
1063      ,@body))
1064 (put 'semantic-with-buffer-narrowed-to-tag 'lisp-indent-function 1)
1065 (add-hook 'edebug-setup-hook
1066           (lambda ()
1067             (def-edebug-spec semantic-with-buffer-narrowed-to-tag
1068               (def-body))))
1069 \f
1070 ;;; Tag Hooks
1071 ;;
1072 ;; Semantic may want to provide special hooks when specific operations
1073 ;; are about to happen on a given tag.  These routines allow for hook
1074 ;; maintenance on a tag.
1075
1076 ;; Internal global variable used to manage tag hooks.  For example,
1077 ;; some implementation of `remove-hook' checks that the hook variable
1078 ;; is `default-boundp'.
1079 (defvar semantic--tag-hook-value)
1080
1081 (defun semantic-tag-add-hook (tag hook function &optional append)
1082   "Onto TAG, add to the value of HOOK the function FUNCTION.
1083 FUNCTION is added (if necessary) at the beginning of the hook list
1084 unless the optional argument APPEND is non-nil, in which case
1085 FUNCTION is added at the end.
1086 HOOK should be a symbol, and FUNCTION may be any valid function.
1087 See also the function `add-hook'."
1088   (let ((semantic--tag-hook-value (semantic--tag-get-property tag hook)))
1089     (add-hook 'semantic--tag-hook-value function append)
1090     (semantic--tag-put-property tag hook semantic--tag-hook-value)
1091     semantic--tag-hook-value))
1092
1093 (defun semantic-tag-remove-hook (tag hook function)
1094   "Onto TAG, remove from the value of HOOK the function FUNCTION.
1095 HOOK should be a symbol, and FUNCTION may be any valid function.  If
1096 FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in
1097 the list of hooks to run in HOOK, then nothing is done.
1098 See also the function `remove-hook'."
1099   (let ((semantic--tag-hook-value (semantic--tag-get-property tag hook)))
1100     (remove-hook 'semantic--tag-hook-value function)
1101     (semantic--tag-put-property tag hook semantic--tag-hook-value)
1102     semantic--tag-hook-value))
1103
1104 (defun semantic--tag-run-hooks (tag hook &rest args)
1105   "Run for TAG all expressions saved on the property HOOK.
1106 Each hook expression must take at least one argument, the TAG.
1107 For any given situation, additional ARGS may be passed."
1108   (let ((semantic--tag-hook-value (semantic--tag-get-property tag hook))
1109         (arglist (cons tag args)))
1110     (condition-case err
1111         ;; If a hook bombs, ignore it!  Usually this is tied into
1112         ;; some sort of critical system.
1113         (apply 'run-hook-with-args 'semantic--tag-hook-value arglist)
1114       (error (message "Error: %S" err)))))
1115 \f
1116 ;;; Tags and Overlays
1117 ;;
1118 ;; Overlays are used so that we can quickly identify tags from
1119 ;; buffer positions and regions using built in Emacs commands.
1120 ;;
1121
1122 (defsubst semantic--tag-unlink-list-from-buffer (tags)
1123   "Convert TAGS from using an overlay to using an overlay proxy.
1124 This function is for internal use only."
1125   (mapcar 'semantic--tag-unlink-from-buffer tags))
1126
1127 (defun semantic--tag-unlink-from-buffer (tag)
1128   "Convert TAG from using an overlay to using an overlay proxy.
1129 This function is for internal use only."
1130   (when (semantic-tag-p tag)
1131     (let ((o (semantic-tag-overlay tag)))
1132       (when (semantic-overlay-p o)
1133         (semantic--tag-set-overlay
1134          tag (vector (semantic-overlay-start o)
1135                      (semantic-overlay-end o)))
1136         (semantic-overlay-delete o))
1137       ;; Look for a link hook on TAG.
1138       (semantic--tag-run-hooks tag 'unlink-hook)
1139       ;; Fix the sub-tags which contain overlays.
1140       (semantic--tag-unlink-list-from-buffer
1141        (semantic-tag-components-with-overlays tag)))))
1142
1143 (defsubst semantic--tag-link-list-to-buffer (tags)
1144   "Convert TAGS from using an overlay proxy to using an overlay.
1145 This function is for internal use only."
1146   (mapcar 'semantic--tag-link-to-buffer tags))
1147
1148 (defun semantic--tag-link-to-buffer (tag)
1149   "Convert TAG from using an overlay proxy to using an overlay.
1150 This function is for internal use only."
1151   (when (semantic-tag-p tag)
1152     (let ((o (semantic-tag-overlay tag)))
1153       (when (and (vectorp o) (= (length o) 2))
1154         (setq o (semantic-make-overlay (aref o 0) (aref o 1)
1155                                        (current-buffer)))
1156         (semantic--tag-set-overlay tag o)
1157         (semantic-overlay-put o 'semantic tag)
1158         ;; Clear the :filename property
1159         (semantic--tag-put-property tag :filename nil))
1160       ;; Look for a link hook on TAG.
1161       (semantic--tag-run-hooks tag 'link-hook)
1162       ;; Fix the sub-tags which contain overlays.
1163       (semantic--tag-link-list-to-buffer
1164        (semantic-tag-components-with-overlays tag)))))
1165
1166 (defun semantic--tag-unlink-cache-from-buffer ()
1167   "Convert all tags in the current cache to use overlay proxys.
1168 This function is for internal use only."
1169   (require 'semantic)
1170   (semantic--tag-unlink-list-from-buffer
1171    ;; @todo- use fetch-tags-fast?
1172    (semantic-fetch-tags)))
1173
1174 (defvar semantic--buffer-cache)
1175
1176 (defun semantic--tag-link-cache-to-buffer ()
1177   "Convert all tags in the current cache to use overlays.
1178 This function is for internal use only."
1179   (require 'semantic)
1180   (condition-case nil
1181       ;; In this unique case, we cannot call the usual toplevel fn.
1182       ;; because we don't want a reparse, we want the old overlays.
1183       (semantic--tag-link-list-to-buffer
1184        semantic--buffer-cache)
1185     ;; Recover when there is an error restoring the cache.
1186     (error (message "Error recovering tag list")
1187            (semantic-clear-toplevel-cache)
1188            nil)))
1189 \f
1190 ;;; Tag Cooking
1191 ;;
1192 ;; Raw tags from a parser follow a different positional format than
1193 ;; those used in the buffer cache.  Raw tags need to be cooked into
1194 ;; semantic cache friendly tags for use by the masses.
1195 ;;
1196 (defsubst semantic--tag-expanded-p (tag)
1197   "Return non-nil if TAG is expanded.
1198 This function is for internal use only.
1199 See also the function `semantic--expand-tag'."
1200   ;; In fact a cooked tag is actually a list of cooked tags
1201   ;; because a raw tag can be expanded in several cooked ones!
1202   (when (consp tag)
1203     (while (and (semantic-tag-p (car tag))
1204                 (vectorp (semantic-tag-overlay (car tag))))
1205       (setq tag (cdr tag)))
1206     (null tag)))
1207
1208 (defvar semantic-tag-expand-function nil
1209   "Function used to expand a tag.
1210 It is passed each tag production, and must return a list of tags
1211 derived from it, or nil if it does not need to be expanded.
1212
1213 Languages with compound definitions should use this function to expand
1214 from one compound symbol into several.  For example, in C or Java the
1215 following definition is easily parsed into one tag:
1216
1217   int a, b;
1218
1219 This function should take this compound tag and turn it into two tags,
1220 one for A, and the other for B.")
1221 (make-variable-buffer-local 'semantic-tag-expand-function)
1222
1223 (defun semantic--tag-expand (tag)
1224   "Convert TAG from a raw state to a cooked state, and expand it.
1225 Returns a list of cooked tags.
1226
1227   The parser returns raw tags with positional data START END at the
1228 end of the tag data structure (a list for now).  We convert it from
1229 that to a cooked state that uses an overlay proxy, that is, a vector
1230 \[START END].
1231
1232   The raw tag is changed with side effects and maybe expanded in
1233 several derived tags when the variable `semantic-tag-expand-function'
1234 is set.
1235
1236 This function is for internal use only."
1237   (if (semantic--tag-expanded-p tag)
1238       ;; Just return TAG if it is already expanded (by a grammar
1239       ;; semantic action), or if it isn't recognized as a valid
1240       ;; semantic tag.
1241       tag
1242
1243     ;; Try to cook the tag.  This code will be removed when tag will
1244     ;; be directly created with the right format.
1245     (condition-case nil
1246         (let ((ocdr (semantic--tag-overlay-cdr tag)))
1247           ;; OCDR contains the sub-list of TAG whose car is the
1248           ;; OVERLAY part of TAG. That is, a list (OVERLAY START END).
1249           ;; Convert it into an overlay proxy ([START END]).
1250           (semantic--tag-set-overlay
1251            tag (vector (nth 1 ocdr) (nth 2 ocdr)))
1252           ;; Remove START END positions at end of tag.
1253           (setcdr ocdr nil)
1254           ;; At this point (length TAG) must be 5!
1255           ;;(unless (= (length tag) 5)
1256           ;;  (error "Tag expansion failed"))
1257           )
1258       (error
1259        (message "A Rule must return a single tag-line list!")
1260        (debug tag)
1261        nil))
1262
1263 ;;    @todo - I think we've waited long enough.  Lets find out.
1264 ;;
1265 ;;    ;; Compatibility code to be removed in future versions.
1266 ;;    (unless semantic-tag-expand-function
1267 ;;      ;; This line throws a byte compiler warning.
1268 ;;      (setq semantic-tag-expand-function semantic-expand-nonterminal)
1269 ;;      )
1270
1271     ;; Expand based on local configuration
1272     (if semantic-tag-expand-function
1273         (or (funcall semantic-tag-expand-function tag)
1274             (list tag))
1275       (list tag))))
1276 \f
1277 ;; Foreign tags
1278 ;;
1279 (defmacro semantic-foreign-tag-invalid (tag)
1280   "Signal that TAG is an invalid foreign tag."
1281   `(signal 'wrong-type-argument '(semantic-foreign-tag-p ,tag)))
1282
1283 (defsubst semantic-foreign-tag-p (tag)
1284   "Return non-nil if TAG is a foreign tag.
1285 That is, a tag unlinked from the originating buffer, which carries the
1286 originating buffer file name, and major mode."
1287   (and (semantic-tag-p tag)
1288        (semantic--tag-get-property tag :foreign-flag)))
1289
1290 (defsubst semantic-foreign-tag-check (tag)
1291   "Check that TAG is a valid foreign tag.
1292 Signal an error if not."
1293   (or (semantic-foreign-tag-p tag)
1294       (semantic-foreign-tag-invalid tag)))
1295
1296 (defun semantic-foreign-tag (&optional tag)
1297   "Return a copy of TAG as a foreign tag, or nil if it can't be done.
1298 TAG defaults to the tag at point in current buffer.
1299 See also `semantic-foreign-tag-p'."
1300   (require 'semantic/doc)
1301   (or tag (setq tag (semantic-current-tag)))
1302   (when (semantic-tag-p tag)
1303     (let ((ftag (semantic-tag-copy tag nil t))
1304           ;; Do extra work for the doc strings, since this is a
1305           ;; common use case.
1306           (doc (condition-case nil
1307                    (semantic-documentation-for-tag tag)
1308                  (error nil))))
1309       ;; A foreign tag must carry its originating buffer file name!
1310       (when (semantic--tag-get-property ftag :filename)
1311         (semantic--tag-put-property ftag :mode (semantic-tag-mode tag))
1312         (semantic--tag-put-property ftag :documentation doc)
1313         (semantic--tag-put-property ftag :foreign-flag t)
1314         ftag))))
1315
1316 ;; High level obtain/insert foreign tag overloads
1317 (define-overloadable-function semantic-obtain-foreign-tag (&optional tag)
1318   "Obtain a foreign tag from TAG.
1319 TAG defaults to the tag at point in current buffer.
1320 Return the obtained foreign tag or nil if failed."
1321   (semantic-foreign-tag tag))
1322
1323 (defun semantic-insert-foreign-tag-default (foreign-tag)
1324   "Insert FOREIGN-TAG into the current buffer.
1325 The default behavior assumes the current buffer is a language file,
1326 and attempts to insert a prototype/function call."
1327   ;; Long term goal: Have a mechanism for a tempo-like template insert
1328   ;; for the given tag.
1329   (require 'semantic/format)
1330   (insert (semantic-format-tag-prototype foreign-tag)))
1331
1332 (define-overloadable-function semantic-insert-foreign-tag (foreign-tag)
1333   "Insert FOREIGN-TAG into the current buffer.
1334 Signal an error if FOREIGN-TAG is not a valid foreign tag.
1335 This function is overridable with the symbol `insert-foreign-tag'."
1336   (require 'semantic/format)
1337   (semantic-foreign-tag-check foreign-tag)
1338   (:override)
1339   (message (semantic-format-tag-summarize foreign-tag)))
1340
1341 ;;; Support log modes here
1342 (define-mode-local-override semantic-insert-foreign-tag
1343   log-edit-mode (foreign-tag)
1344   "Insert foreign tags into log-edit mode."
1345   (require 'semantic/format)
1346   (insert (concat "(" (semantic-format-tag-name foreign-tag) "): ")))
1347
1348 (define-mode-local-override semantic-insert-foreign-tag
1349   change-log-mode (foreign-tag)
1350   "Insert foreign tags into log-edit mode."
1351   (require 'semantic/format)
1352   (insert (concat "(" (semantic-format-tag-name foreign-tag) "): ")))
1353
1354 \f
1355 ;;; EDEBUG display support
1356 ;;
1357 (eval-after-load "cedet-edebug"
1358   '(progn
1359      (cedet-edebug-add-print-override
1360       '(semantic-tag-p object)
1361       '(concat "#<TAG " (semantic-format-tag-name object) ">"))
1362      (cedet-edebug-add-print-override
1363       '(and (listp object) (semantic-tag-p (car object)))
1364       '(cedet-edebug-prin1-recurse object))
1365      ))
1366 \f
1367 ;;; Compatibility
1368 ;;
1369 (defconst semantic-token-version
1370   semantic-tag-version)
1371 (defconst semantic-token-incompatible-version
1372   semantic-tag-incompatible-version)
1373
1374 (semantic-alias-obsolete 'semantic-token-name
1375                          'semantic-tag-name)
1376
1377 (semantic-alias-obsolete 'semantic-token-token
1378                          'semantic-tag-class)
1379
1380 (semantic-alias-obsolete 'semantic-token-extra-specs
1381                          'semantic-tag-attributes)
1382
1383 (semantic-alias-obsolete 'semantic-token-properties
1384                          'semantic-tag-properties)
1385
1386 (semantic-alias-obsolete 'semantic-token-properties-cdr
1387                          'semantic--tag-properties-cdr)
1388
1389 (semantic-alias-obsolete 'semantic-token-overlay
1390                          'semantic-tag-overlay)
1391
1392 (semantic-alias-obsolete 'semantic-token-overlay-cdr
1393                          'semantic--tag-overlay-cdr)
1394
1395 (semantic-alias-obsolete 'semantic-token-start
1396                          'semantic-tag-start)
1397
1398 (semantic-alias-obsolete 'semantic-token-end
1399                          'semantic-tag-end)
1400
1401 (semantic-alias-obsolete 'semantic-token-extent
1402                          'semantic-tag-bounds)
1403
1404 (semantic-alias-obsolete 'semantic-token-buffer
1405                          'semantic-tag-buffer)
1406
1407 (semantic-alias-obsolete 'semantic-token-put
1408                          'semantic--tag-put-property)
1409
1410 (semantic-alias-obsolete 'semantic-token-put-no-side-effect
1411                          'semantic--tag-put-property-no-side-effect)
1412
1413 (semantic-alias-obsolete 'semantic-token-get
1414                          'semantic--tag-get-property)
1415
1416 (semantic-alias-obsolete 'semantic-token-add-extra-spec
1417                          'semantic-tag-put-attribute)
1418
1419 (semantic-alias-obsolete 'semantic-token-extra-spec
1420                          'semantic-tag-get-attribute)
1421
1422 (semantic-alias-obsolete 'semantic-token-type
1423                          'semantic-tag-type)
1424
1425 (semantic-alias-obsolete 'semantic-token-modifiers
1426                          'semantic-tag-modifiers)
1427
1428 (semantic-alias-obsolete 'semantic-token-docstring
1429                          'semantic-tag-docstring)
1430
1431 (semantic-alias-obsolete 'semantic-token-type-parts
1432                          'semantic-tag-type-members)
1433
1434 (defsubst semantic-token-type-parent (tag)
1435   "Return the parent of the type that TAG describes.
1436 The return value is a list.  A value of nil means no parents.
1437 The `car' of the list is either the parent class, or a list
1438 of parent classes.  The `cdr' of the list is the list of
1439 interfaces, or abstract classes which are parents of TAG."
1440   (cons (semantic-tag-get-attribute tag :superclasses)
1441         (semantic-tag-type-interfaces tag)))
1442 (make-obsolete 'semantic-token-type-parent
1443                "\
1444 use `semantic-tag-type-superclass' \
1445 and `semantic-tag-type-interfaces' instead")
1446
1447 (semantic-alias-obsolete 'semantic-token-type-parent-superclass
1448                          'semantic-tag-type-superclasses)
1449
1450 (semantic-alias-obsolete 'semantic-token-type-parent-implement
1451                          'semantic-tag-type-interfaces)
1452
1453 (semantic-alias-obsolete 'semantic-token-type-extra-specs
1454                          'semantic-tag-attributes)
1455
1456 (semantic-alias-obsolete 'semantic-token-type-extra-spec
1457                          'semantic-tag-get-attribute)
1458
1459 (semantic-alias-obsolete 'semantic-token-type-modifiers
1460                          'semantic-tag-modifiers)
1461
1462 (semantic-alias-obsolete 'semantic-token-function-args
1463                          'semantic-tag-function-arguments)
1464
1465 (semantic-alias-obsolete 'semantic-token-function-extra-specs
1466                          'semantic-tag-attributes)
1467
1468 (semantic-alias-obsolete 'semantic-token-function-extra-spec
1469                          'semantic-tag-get-attribute)
1470
1471 (semantic-alias-obsolete 'semantic-token-function-modifiers
1472                          'semantic-tag-modifiers)
1473
1474 (semantic-alias-obsolete 'semantic-token-function-throws
1475                          'semantic-tag-function-throws)
1476
1477 (semantic-alias-obsolete 'semantic-token-function-parent
1478                          'semantic-tag-function-parent)
1479
1480 (semantic-alias-obsolete 'semantic-token-function-destructor
1481                          'semantic-tag-function-destructor-p)
1482
1483 (semantic-alias-obsolete 'semantic-token-variable-default
1484                          'semantic-tag-variable-default)
1485
1486 (semantic-alias-obsolete 'semantic-token-variable-extra-specs
1487                          'semantic-tag-attributes)
1488
1489 (semantic-alias-obsolete 'semantic-token-variable-extra-spec
1490                          'semantic-tag-get-attribute)
1491
1492 (semantic-alias-obsolete 'semantic-token-variable-modifiers
1493                          'semantic-tag-modifiers)
1494
1495 (semantic-alias-obsolete 'semantic-token-variable-const
1496                          'semantic-tag-variable-constant-p)
1497
1498 (semantic-alias-obsolete 'semantic-token-variable-optsuffix
1499                          'semantic-tag-variable-optsuffix)
1500
1501 (semantic-alias-obsolete 'semantic-token-include-system
1502                          'semantic-tag-include-system-p)
1503
1504 (semantic-alias-obsolete 'semantic-token-p
1505                          'semantic-tag-p)
1506
1507 (semantic-alias-obsolete 'semantic-token-with-position-p
1508                          'semantic-tag-with-position-p)
1509
1510 (semantic-alias-obsolete 'semantic-tag-make-assoc-list
1511                          'semantic-tag-make-plist)
1512
1513 (semantic-alias-obsolete 'semantic-nonterminal-children
1514                          'semantic-tag-children-compatibility)
1515
1516 (semantic-alias-obsolete 'semantic-narrow-to-token
1517                          'semantic-narrow-to-tag)
1518
1519 (semantic-alias-obsolete 'semantic-with-buffer-narrowed-to-current-token
1520                          'semantic-with-buffer-narrowed-to-current-tag)
1521
1522 (semantic-alias-obsolete 'semantic-with-buffer-narrowed-to-token
1523                          'semantic-with-buffer-narrowed-to-tag)
1524
1525 (semantic-alias-obsolete 'semantic-deoverlay-token
1526                          'semantic--tag-unlink-from-buffer)
1527
1528 (semantic-alias-obsolete 'semantic-overlay-token
1529                          'semantic--tag-link-to-buffer)
1530
1531 (semantic-alias-obsolete 'semantic-deoverlay-list
1532                          'semantic--tag-unlink-list-from-buffer)
1533
1534 (semantic-alias-obsolete 'semantic-overlay-list
1535                          'semantic--tag-link-list-to-buffer)
1536
1537 (semantic-alias-obsolete 'semantic-deoverlay-cache
1538                          'semantic--tag-unlink-cache-from-buffer)
1539
1540 (semantic-alias-obsolete 'semantic-overlay-cache
1541                          'semantic--tag-link-cache-to-buffer)
1542
1543 (semantic-alias-obsolete 'semantic-cooked-token-p
1544                          'semantic--tag-expanded-p)
1545
1546 (semantic-varalias-obsolete 'semantic-expand-nonterminal
1547                             'semantic-tag-expand-function)
1548
1549 (semantic-alias-obsolete 'semantic-raw-to-cooked-token
1550                          'semantic--tag-expand)
1551
1552 ;; Lets test this out during this short transition.
1553 (semantic-alias-obsolete 'semantic-clone-tag
1554                          'semantic-tag-clone)
1555
1556 (semantic-alias-obsolete 'semantic-token
1557                          'semantic-tag)
1558
1559 (semantic-alias-obsolete 'semantic-token-new-variable
1560                          'semantic-tag-new-variable)
1561
1562 (semantic-alias-obsolete 'semantic-token-new-function
1563                          'semantic-tag-new-function)
1564
1565 (semantic-alias-obsolete 'semantic-token-new-type
1566                          'semantic-tag-new-type)
1567
1568 (semantic-alias-obsolete 'semantic-token-new-include
1569                          'semantic-tag-new-include)
1570
1571 (semantic-alias-obsolete 'semantic-token-new-package
1572                          'semantic-tag-new-package)
1573
1574 (semantic-alias-obsolete 'semantic-equivalent-tokens-p
1575                          'semantic-equivalent-tag-p)
1576
1577 (provide 'semantic/tag)
1578
1579 ;;; semantic-tag.el ends here