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

   1 ;;; semantic/tag.el --- tag creation and access
   2
   3 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008,
   4 ;;   2009, 2010, 2011, 2012  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 comparative tests to see
  43 ;;      if two tags are the same.
  44
  45 ;;; Code:
  46 ;;
  47
  48 ;; Keep this only so long as we have obsolete fcns.
  49 (require 'semantic/fw)
  50 (require 'semantic/lex)
  51
  52 (declare-function semantic-analyze-split-name "semantic/analyze/fcn")
  53 (declare-function semantic-fetch-tags "semantic")
  54 (declare-function semantic-clear-toplevel-cache "semantic")
  55
  56 (defconst semantic-tag-version "2.0"
  57   "Version string of semantic tags made with this code.")
  58
  59 (defconst semantic-tag-incompatible-version "1.0"
  60   "Version string of semantic tags which are not currently compatible.
  61 These old style tags may be loaded from a file with semantic db.
  62 In this case, we must flush the old tags and start over.")
  63 \f
  64 ;;; Primitive Tag access system:
  65 ;;
  66 ;; Raw tags in semantic are lists of 5 elements:
  67 ;;
  68 ;;   (NAME CLASS ATTRIBUTES PROPERTIES OVERLAY)
  69 ;;
  70 ;; Where:
  71 ;;
  72 ;;   - NAME is a string that represents the tag name.
  73 ;;
  74 ;;   - CLASS is a symbol that represent the class of the tag (for
  75 ;;     example, usual classes are `type', `function', `variable',
  76 ;;     `include', `package', `code').
  77 ;;
  78 ;;   - ATTRIBUTES is a public list of attributes that describes
  79 ;;     language data represented by the tag (for example, a variable
  80 ;;     can have a `:constant-flag' attribute, a function an `:arguments'
  81 ;;     attribute, etc.).
  82 ;;
  83 ;;   - PROPERTIES is a private list of properties used internally.
  84 ;;
  85 ;;   - OVERLAY represent the location of data described by the tag.
  86 ;;
  87
  88 (defsubst semantic-tag-name (tag)
  89   "Return the name of TAG.
  90 For functions, variables, classes, typedefs, etc., this is the identifier
  91 that is being defined.  For tags without an obvious associated name, this
  92 may be the statement type, e.g., this may return @code{print} for python's
  93 print statement."
  94   (car tag))
  95
  96 (defsubst semantic-tag-class (tag)
  97   "Return the class of TAG.
  98 That is, the symbol 'variable, 'function, 'type, or other.
  99 There is no limit to the symbols that may represent the class of a tag.
 100 Each parser generates tags with classes defined by it.
 101
 102 For functional languages, typical tag classes are:
 103
 104 @table @code
 105 @item type
 106 Data types, named map for a memory block.
 107 @item function
 108 A function or method, or named execution location.
 109 @item variable
 110 A variable, or named storage for data.
 111 @item include
 112 Statement that represents a file from which more tags can be found.
 113 @item package
 114 Statement that declares this file's package name.
 115 @item code
 116 Code that has not name or binding to any other symbol, such as in a script.
 117 @end table
 118 "
 119   (nth 1 tag))
 120
 121 (defsubst semantic-tag-attributes (tag)
 122   "Return the list of public attributes of TAG.
 123 That is a property list: (ATTRIBUTE-1 VALUE-1 ATTRIBUTE-2 VALUE-2...)."
 124   (nth 2 tag))
 125
 126 (defsubst semantic-tag-properties (tag)
 127   "Return the list of private properties of TAG.
 128 That is a property list: (PROPERTY-1 VALUE-1 PROPERTY-2 VALUE-2...)."
 129   (nth 3 tag))
 130
 131 (defsubst semantic-tag-overlay (tag)
 132   "Return the OVERLAY part of TAG.
 133 That is, an overlay or an unloaded buffer representation.
 134 This function can also return an array of the form [ START END ].
 135 This occurs for tags that are not currently linked into a buffer."
 136   (nth 4 tag))
 137
 138 (defsubst semantic--tag-overlay-cdr (tag)
 139   "Return the cons cell whose car is the OVERLAY part of TAG.
 140 That function is for internal use only."
 141   (nthcdr 4 tag))
 142
 143 (defsubst semantic--tag-set-overlay (tag overlay)
 144   "Set the overlay part of TAG with OVERLAY.
 145 That function is for internal use only."
 146   (setcar (semantic--tag-overlay-cdr tag) overlay))
 147
 148 (defsubst semantic-tag-start (tag)
 149   "Return the start location of TAG."
 150   (let ((o (semantic-tag-overlay tag)))
 151     (if (semantic-overlay-p o)
 152         (semantic-overlay-start o)
 153       (aref o 0))))
 154
 155 (defsubst semantic-tag-end (tag)
 156   "Return the end location of TAG."
 157   (let ((o (semantic-tag-overlay tag)))
 158     (if (semantic-overlay-p o)
 159         (semantic-overlay-end o)
 160       (aref o 1))))
 161
 162 (defsubst semantic-tag-bounds (tag)
 163   "Return the location (START END) of data TAG describes."
 164   (list (semantic-tag-start tag)
 165         (semantic-tag-end tag)))
 166
 167 (defun semantic-tag-set-bounds (tag start end)
 168   "In TAG, set the START and END location of data it describes."
 169   (let ((o (semantic-tag-overlay tag)))
 170     (if (semantic-overlay-p o)
 171         (semantic-overlay-move o start end)
 172       (semantic--tag-set-overlay tag (vector start end)))))
 173
 174 (defun semantic-tag-in-buffer-p (tag)
 175   "Return the buffer TAG resides in IFF tag is already in a buffer.
 176 If a tag is not in a buffer, return nil."
 177   (let ((o (semantic-tag-overlay tag)))
 178      ;; TAG is currently linked to a buffer, return it.
 179     (when (and (semantic-overlay-p o)
 180                (semantic-overlay-live-p o))
 181       (semantic-overlay-buffer o))))
 182
 183 (defsubst semantic--tag-get-property (tag property)
 184   "From TAG, extract the value of PROPERTY.
 185 Return the value found, or nil if PROPERTY is not one of the
 186 properties of TAG.
 187 That function is for internal use only."
 188   (plist-get (semantic-tag-properties tag) property))
 189
 190 (defun semantic-tag-buffer (tag)
 191   "Return the buffer TAG resides in.
 192 If TAG has an originating file, read that file into a (maybe new)
 193 buffer, and return it.
 194 Return nil if there is no buffer for this tag."
 195   (let ((buff (semantic-tag-in-buffer-p tag)))
 196     (if buff
 197         buff
 198       ;; TAG has an originating file, read that file into a buffer, and
 199       ;; return it.
 200      (if (semantic--tag-get-property tag :filename)
 201          (save-match-data
 202            (find-file-noselect (semantic--tag-get-property tag :filename)))
 203        ;; TAG is not in Emacs right now, no buffer is available.
 204        ))))
 205
 206 (defun semantic-tag-mode (&optional tag)
 207   "Return the major mode active for TAG.
 208 TAG defaults to the tag at point in current buffer.
 209 If TAG has a :mode property return it.
 210 If point is inside TAG bounds, return the major mode active at point.
 211 Return the major mode active at beginning of TAG otherwise.
 212 See also the function `semantic-ctxt-current-mode'."
 213   (or tag (setq tag (semantic-current-tag)))
 214   (or (semantic--tag-get-property tag :mode)
 215       (let ((buffer (semantic-tag-buffer tag))
 216             (start (semantic-tag-start tag))
 217             (end   (semantic-tag-end tag)))
 218         (save-excursion
 219           (and buffer (set-buffer buffer))
 220           ;; Unless point is inside TAG bounds, move it to the
 221           ;; beginning of TAG.
 222           (or (and (>= (point) start) (< (point) end))
 223               (goto-char start))
 224           (require 'semantic/ctxt)
 225           (semantic-ctxt-current-mode)))))
 226
 227 (defsubst semantic--tag-attributes-cdr (tag)
 228   "Return the cons cell whose car is the ATTRIBUTES part of TAG.
 229 That function is for internal use only."
 230   (nthcdr 2 tag))
 231
 232 (defsubst semantic-tag-put-attribute (tag attribute value)
 233   "Change value in TAG of ATTRIBUTE to VALUE.
 234 If ATTRIBUTE already exists, its value is set to VALUE, otherwise the
 235 new ATTRIBUTE VALUE pair is added.
 236 Return TAG.
 237 Use this function in a parser when not all attributes are known at the
 238 same time."
 239   (let* ((plist-cdr (semantic--tag-attributes-cdr tag)))
 240     (when (consp plist-cdr)
 241       (setcar plist-cdr
 242               (semantic-tag-make-plist
 243                (plist-put (car plist-cdr) attribute value))))
 244     tag))
 245
 246 (defun semantic-tag-put-attribute-no-side-effect (tag attribute value)
 247   "Change value in TAG of ATTRIBUTE to VALUE without side effects.
 248 All cons cells in the attribute list are replicated so that there
 249 are no side effects if TAG is in shared lists.
 250 If ATTRIBUTE already exists, its value is set to VALUE, otherwise the
 251 new ATTRIBUTE VALUE pair is added.
 252 Return TAG."
 253   (let* ((plist-cdr (semantic--tag-attributes-cdr tag)))
 254     (when (consp plist-cdr)
 255       (setcar plist-cdr
 256               (semantic-tag-make-plist
 257                (plist-put (copy-sequence (car plist-cdr))
 258                           attribute value))))
 259     tag))
 260
 261 (defsubst semantic-tag-get-attribute (tag attribute)
 262   "From TAG, return the value of ATTRIBUTE.
 263 ATTRIBUTE is a symbol whose specification value to get.
 264 Return the value found, or nil if ATTRIBUTE is not one of the
 265 attributes of TAG."
 266   (plist-get (semantic-tag-attributes tag) attribute))
 267
 268 ;; These functions are for internal use only!
 269 (defsubst semantic--tag-properties-cdr (tag)
 270   "Return the cons cell whose car is the PROPERTIES part of TAG.
 271 That function is for internal use only."
 272   (nthcdr 3 tag))
 273
 274 (defun semantic--tag-put-property (tag property value)
 275   "Change value in TAG of PROPERTY to VALUE.
 276 If PROPERTY already exists, its value is set to VALUE, otherwise the
 277 new PROPERTY VALUE pair is added.
 278 Return TAG.
 279 That function is for internal use only."
 280   (let* ((plist-cdr (semantic--tag-properties-cdr tag)))
 281     (when (consp plist-cdr)
 282       (setcar plist-cdr
 283               (semantic-tag-make-plist
 284                (plist-put (car plist-cdr) property value))))
 285     tag))
 286
 287 (defun semantic--tag-put-property-no-side-effect (tag property value)
 288   "Change value in TAG of PROPERTY to VALUE without side effects.
 289 All cons cells in the property list are replicated so that there
 290 are no side effects if TAG is in shared lists.
 291 If PROPERTY already exists, its value is set to VALUE, otherwise the
 292 new PROPERTY VALUE pair is added.
 293 Return TAG.
 294 That function is for internal use only."
 295   (let* ((plist-cdr (semantic--tag-properties-cdr tag)))
 296     (when (consp plist-cdr)
 297       (setcar plist-cdr
 298               (semantic-tag-make-plist
 299                (plist-put (copy-sequence (car plist-cdr))
 300                           property value))))
 301     tag))
 302
 303 (defun semantic-tag-file-name (tag)
 304   "Return the name of the file from which TAG originated.
 305 Return nil if that information can't be obtained.
 306 If TAG is from a loaded buffer, then that buffer's filename is used.
 307 If TAG is unlinked, but has a :filename property, then that is used."
 308   (let ((buffer (semantic-tag-in-buffer-p tag)))
 309     (if buffer
 310         (buffer-file-name buffer)
 311       (semantic--tag-get-property tag :filename))))
 312 \f
 313 ;;; Tag tests and comparisons.
 314 (defsubst semantic-tag-p (tag)
 315   "Return non-nil if TAG is most likely a semantic tag."
 316   (condition-case nil
 317       (and (consp tag)
 318            (stringp (car tag))                ; NAME
 319            (symbolp (nth 1 tag)) (nth 1 tag)  ; TAG-CLASS
 320            (listp (nth 2 tag))                ; ATTRIBUTES
 321            (listp (nth 3 tag))                ; PROPERTIES
 322            )
 323     ;; If an error occurs, then it most certainly is not a tag.
 324     (error nil)))
 325
 326 (defsubst semantic-tag-of-class-p (tag class)
 327   "Return non-nil if class of TAG is CLASS."
 328   (eq (semantic-tag-class tag) class))
 329
 330 (defsubst semantic-tag-type-members (tag)
 331   "Return the members of the type that TAG describes.
 332 That is the value of the `:members' attribute."
 333   (semantic-tag-get-attribute tag :members))
 334
 335 (defsubst semantic-tag-type (tag)
 336   "Return the value of the `:type' attribute of TAG.
 337 For a function it would be the data type of the return value.
 338 For a variable, it is the storage type of that variable.
 339 For a data type, the type is the style of datatype, such as
 340 struct or union."
 341   (semantic-tag-get-attribute tag :type))
 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 (defun semantic-tag-similar-p (tag1 tag2 &rest ignorable-attributes)
 367   "Test to see if TAG1 and TAG2 are similar.
 368 Two tags are similar if their name, datatype, and various attributes
 369 are the same.
 370
 371 Similar tags that have sub-tags such as arg lists or type members,
 372 are similar w/out checking the sub-list of tags.
 373 Optional argument IGNORABLE-ATTRIBUTES are attributes to ignore while comparing similarity."
 374   (let* ((A1 (and (equal (semantic-tag-name tag1) (semantic-tag-name tag2))
 375                   (semantic-tag-of-class-p tag1 (semantic-tag-class tag2))
 376                   (semantic-tag-of-type-p tag1 (semantic-tag-type tag2))))
 377          (attr1 (semantic-tag-attributes tag1))
 378          (A2 (= (length attr1) (length (semantic-tag-attributes tag2))))
 379          (A3 t)
 380          )
 381     (when (and (not A2) ignorable-attributes)
 382       (setq A2 t))
 383     (while (and A2 attr1 A3)
 384       (let ((a (car attr1))
 385             (v (car (cdr attr1))))
 386
 387         (cond ((or (eq a :type) ;; already tested above.
 388                    (memq a ignorable-attributes)) ;; Ignore them...
 389                nil)
 390
 391               ;; Don't test sublists of tags
 392               ((and (listp v) (semantic-tag-p (car v)))
 393                nil)
 394
 395               ;; The attributes are not the same?
 396               ((not (equal v (semantic-tag-get-attribute tag2 a)))
 397                (setq A3 nil))
 398               (t
 399                nil))
 400         )
 401       (setq attr1 (cdr (cdr attr1))))
 402
 403     (and A1 A2 A3)
 404     ))
 405
 406 (defun semantic-tag-similar-with-subtags-p (tag1 tag2 &rest ignorable-attributes)
 407   "Test to see if TAG1 and TAG2 are similar.
 408 Uses `semantic-tag-similar-p' but also recurses through sub-tags, such
 409 as argument lists and type members.
 410 Optional argument IGNORABLE-ATTRIBUTES is passed down to
 411 `semantic-tag-similar-p'."
 412   (let ((C1 (semantic-tag-components tag1))
 413         (C2 (semantic-tag-components tag2))
 414         )
 415     (if (or (/= (length C1) (length C2))
 416             (not (semantic-tag-similar-p tag1 tag2 ignorable-attributes))
 417             )
 418         ;; Basic test fails.
 419         nil
 420       ;; Else, check component lists.
 421       (catch 'component-dissimilar
 422         (while C1
 423
 424           (if (not (semantic-tag-similar-with-subtags-p
 425                     (car C1) (car C2) ignorable-attributes))
 426               (throw 'component-dissimilar nil))
 427
 428           (setq C1 (cdr C1))
 429           (setq C2 (cdr C2))
 430           )
 431         ;; If we made it this far, we are ok.
 432         t) )))
 433
 434
 435 (defun semantic-tag-of-type-p (tag type)
 436   "Compare TAG's type against TYPE.  Non nil if equivalent.
 437 TYPE can be a string, or a tag of class 'type.
 438 This can be complex since some tags might have a :type that is a tag,
 439 while other tags might just have a string.  This function will also be
 440 return true of TAG's type is compared directly to the declaration of a
 441 data type."
 442   (let* ((tagtype (semantic-tag-type tag))
 443          (tagtypestring (cond ((stringp tagtype)
 444                                tagtype)
 445                               ((and (semantic-tag-p tagtype)
 446                                     (semantic-tag-of-class-p tagtype 'type))
 447                                (semantic-tag-name tagtype))
 448                               (t "")))
 449          (typestring (cond ((stringp type)
 450                             type)
 451                            ((and (semantic-tag-p type)
 452                                  (semantic-tag-of-class-p type 'type))
 453                             (semantic-tag-name type))
 454                            (t "")))
 455          )
 456     (and
 457      tagtypestring
 458      (or
 459       ;; Matching strings (input type is string)
 460       (and (stringp type)
 461            (string= tagtypestring type))
 462       ;; Matching strings (tag type is string)
 463       (and (stringp tagtype)
 464            (string= tagtype typestring))
 465       ;; Matching tokens, and the type of the type is the same.
 466       (and (string= tagtypestring typestring)
 467            (if (and (semantic-tag-type tagtype) (semantic-tag-type type))
 468                (equal (semantic-tag-type tagtype) (semantic-tag-type type))
 469              t))
 470       ))
 471     ))
 472
 473 (defun semantic-tag-type-compound-p (tag)
 474   "Return non-nil the type of TAG is compound.
 475 Compound implies a structure or similar data type.
 476 Returns the list of tag members if it is compound."
 477   (let* ((tagtype (semantic-tag-type tag))
 478          )
 479     (when (and (semantic-tag-p tagtype)
 480                (semantic-tag-of-class-p tagtype 'type))
 481       ;; We have the potential of this being a nifty compound type.
 482       (semantic-tag-type-members tagtype)
 483       )))
 484
 485 (defun semantic-tag-faux-p (tag)
 486   "Return non-nil if TAG is a FAUX tag.
 487 FAUX tags are created to represent a construct that is
 488 not known to exist in the code.
 489
 490 Example: When the class browser sees methods to a class, but
 491 cannot find the class, it will create a faux tag to represent the
 492 class to store those methods."
 493   (semantic--tag-get-property tag :faux-flag))
 494 \f
 495 ;;; Tag creation
 496 ;;
 497
 498 ;; Is this function still necessary?
 499 (defun semantic-tag-make-plist (args)
 500   "Create a property list with ARGS.
 501 Args is a property list of the form (KEY1 VALUE1 ... KEYN VALUEN).
 502 Where KEY is a symbol, and VALUE is the value for that symbol.
 503 The return value will be a new property list, with these KEY/VALUE
 504 pairs eliminated:
 505
 506   - KEY associated to nil VALUE.
 507   - KEY associated to an empty string VALUE.
 508   - KEY associated to a zero VALUE."
 509   (let (plist key val)
 510     (while args
 511       (setq key  (car args)
 512             val  (nth 1 args)
 513             args (nthcdr 2 args))
 514       (or (member val '("" nil))
 515           (and (numberp val) (zerop val))
 516           (setq plist (cons key (cons val plist)))))
 517     ;; It is not useful to reverse the new plist.
 518     plist))
 519
 520 (defsubst semantic-tag (name class &rest attributes)
 521   "Create a generic semantic tag.
 522 NAME is a string representing the name of this tag.
 523 CLASS is the symbol that represents the class of tag this is,
 524 such as 'variable, or 'function.
 525 ATTRIBUTES is a list of additional attributes belonging to this tag."
 526   (list name class (semantic-tag-make-plist attributes) nil nil))
 527
 528 (defsubst semantic-tag-new-variable (name type &optional default-value &rest attributes)
 529   "Create a semantic tag of class 'variable.
 530 NAME is the name of this variable.
 531 TYPE is a string or semantic tag representing the type of this variable.
 532 Optional DEFAULT-VALUE is a string representing the default value of this
 533 variable.  ATTRIBUTES is a list of additional attributes belonging to this
 534 tag."
 535   (apply 'semantic-tag name 'variable
 536          :type type
 537          :default-value default-value
 538          attributes))
 539
 540 (defsubst semantic-tag-new-function (name type arg-list &rest attributes)
 541   "Create a semantic tag of class 'function.
 542 NAME is the name of this function.
 543 TYPE is a string or semantic tag representing the type of this function.
 544 ARG-LIST is a list of strings or semantic tags representing the
 545 arguments of this function.
 546 ATTRIBUTES is a list of additional attributes belonging to this tag."
 547   (apply 'semantic-tag name 'function
 548          :type type
 549          :arguments arg-list
 550          attributes))
 551
 552 (defsubst semantic-tag-new-type (name type members parents &rest attributes)
 553   "Create a semantic tag of class 'type.
 554 NAME is the name of this type.
 555 TYPE is a string or semantic tag representing the type of this type.
 556 MEMBERS is a list of strings or semantic tags representing the
 557 elements that make up this type if it is a composite type.
 558 PARENTS is a cons cell.  (EXPLICIT-PARENTS . INTERFACE-PARENTS)
 559 EXPLICIT-PARENTS can be a single string (Just one parent) or a
 560 list of parents (in a multiple inheritance situation).  It can also
 561 be nil.
 562 INTERFACE-PARENTS is a list of strings representing the names of
 563 all INTERFACES, or abstract classes inherited from.  It can also be
 564 nil.
 565 This slot can be interesting because the form:
 566      ( nil \"string\")
 567 is a valid parent where there is no explicit parent, and only an
 568 interface.
 569 ATTRIBUTES is a list of additional attributes belonging to this tag."
 570   (apply 'semantic-tag name 'type
 571          :type type
 572          :members members
 573          :superclasses (car parents)
 574          :interfaces (cdr parents)
 575          attributes))
 576
 577 (defsubst semantic-tag-new-include (name system-flag &rest attributes)
 578   "Create a semantic tag of class 'include.
 579 NAME is the name of this include.
 580 SYSTEM-FLAG represents that we were able to identify this include as belonging
 581 to the system, as opposed to belonging to the local project.
 582 ATTRIBUTES is a list of additional attributes belonging to this tag."
 583   (apply 'semantic-tag name 'include
 584          :system-flag system-flag
 585          attributes))
 586
 587 (defsubst semantic-tag-new-package (name detail &rest attributes)
 588   "Create a semantic tag of class 'package.
 589 NAME is the name of this package.
 590 DETAIL is extra information about this package, such as a location where
 591 it can be found.
 592 ATTRIBUTES is a list of additional attributes belonging to this tag."
 593   (apply 'semantic-tag name 'package
 594          :detail detail
 595          attributes))
 596
 597 (defsubst semantic-tag-new-code (name detail &rest attributes)
 598   "Create a semantic tag of class 'code.
 599 NAME is a name for this code.
 600 DETAIL is extra information about the code.
 601 ATTRIBUTES is a list of additional attributes belonging to this tag."
 602   (apply 'semantic-tag name 'code
 603          :detail detail
 604          attributes))
 605
 606 (defsubst semantic-tag-set-faux (tag)
 607   "Set TAG to be a new FAUX tag.
 608 FAUX tags represent constructs not found in the source code.
 609 You can identify a faux tag with `semantic-tag-faux-p'"
 610   (semantic--tag-put-property tag :faux-flag t))
 611
 612 (defsubst semantic-tag-set-name (tag name)
 613   "Set TAG name to NAME."
 614   (setcar tag name))
 615
 616 ;;; Copying and cloning tags.
 617 ;;
 618 (defsubst semantic-tag-clone (tag &optional name)
 619   "Clone TAG, creating a new TAG.
 620 If optional argument NAME is not nil it specifies a new name for the
 621 cloned tag."
 622   ;; Right now, TAG is a list.
 623   (list (or name (semantic-tag-name tag))
 624         (semantic-tag-class tag)
 625         (copy-sequence (semantic-tag-attributes tag))
 626         (copy-sequence (semantic-tag-properties tag))
 627         (semantic-tag-overlay tag)))
 628
 629 (defun semantic-tag-copy (tag &optional name keep-file)
 630   "Return a copy of TAG unlinked from the originating buffer.
 631 If optional argument NAME is non-nil it specifies a new name for the
 632 copied tag.
 633 If optional argument KEEP-FILE is non-nil, and TAG was linked to a
 634 buffer, the originating buffer file name is kept in the `:filename'
 635 property of the copied tag.
 636 If KEEP-FILE is a string, and the originating buffer is NOT available,
 637 then KEEP-FILE is stored on the `:filename' property.
 638 This runs the tag hook `unlink-copy-hook`."
 639   ;; Right now, TAG is a list.
 640   (let ((copy (semantic-tag-clone tag name)))
 641
 642     ;; Keep the filename if needed.
 643     (when keep-file
 644       (semantic--tag-put-property
 645        copy :filename (or (semantic-tag-file-name copy)
 646                           (and (stringp keep-file)
 647                                keep-file)
 648                           )))
 649
 650     (when (semantic-tag-with-position-p tag)
 651       ;; Convert the overlay to a vector, effectively 'unlinking' the tag.
 652       (semantic--tag-set-overlay
 653        copy (vector (semantic-tag-start copy) (semantic-tag-end copy)))
 654
 655       ;; Force the children to be copied also.
 656       ;;(let ((chil (semantic--tag-copy-list
 657       ;;             (semantic-tag-components-with-overlays tag)
 658       ;;             keep-file)))
 659       ;;;; Put the list into TAG.
 660       ;;)
 661
 662       ;; Call the unlink-copy hook.  This should tell tools that
 663       ;; this tag is not part of any buffer.
 664       (when (semantic-overlay-p (semantic-tag-overlay tag))
 665         (semantic--tag-run-hooks copy 'unlink-copy-hook))
 666       )
 667     copy))
 668
 669 ;;(defun semantic--tag-copy-list (tags &optional keep-file)
 670 ;;  "Make copies of TAGS and return the list of TAGS."
 671 ;;  (let ((out nil))
 672 ;;    (dolist (tag tags out)
 673 ;;      (setq out (cons (semantic-tag-copy tag nil keep-file)
 674 ;;                    out))
 675 ;;      )))
 676
 677 (defun semantic--tag-copy-properties (tag1 tag2)
 678   "Copy private properties from TAG1 to TAG2.
 679 Return TAG2.
 680 This function is for internal use only."
 681   (let ((plist (semantic-tag-properties tag1)))
 682     (while plist
 683       (semantic--tag-put-property tag2 (car plist) (nth 1 plist))
 684       (setq plist (nthcdr 2 plist)))
 685     tag2))
 686
 687 ;;; DEEP COPIES
 688 ;;
 689 (defun semantic-tag-deep-copy-one-tag (tag &optional filter)
 690   "Make a deep copy of TAG, applying FILTER to each child-tag.
 691 No properties are copied except for :filename.
 692 Overlay will be a vector.
 693 FILTER takes TAG as an argument, and should return a `semantic-tag'.
 694 It is safe for FILTER to modify the input tag and return it."
 695   (when (not filter) (setq filter 'identity))
 696   (when (not (semantic-tag-p tag))
 697     (signal 'wrong-type-argument (list tag 'semantic-tag-p)))
 698   (let ((ol (semantic-tag-overlay tag))
 699         (fn (semantic-tag-file-name tag)))
 700     (funcall filter (list (semantic-tag-name tag)
 701                           (semantic-tag-class tag)
 702                           (semantic--tag-deep-copy-attributes
 703                            (semantic-tag-attributes tag) filter)
 704                           ;; Only copy the filename property
 705                           (when fn (list :filename fn))
 706                           ;; Only setup a vector if we had an overlay.
 707                           (when ol (vector (semantic-tag-start tag)
 708                                            (semantic-tag-end tag)))))))
 709
 710 (defun semantic--tag-deep-copy-attributes (attrs &optional filter)
 711   "Make a deep copy of ATTRS, applying FILTER to each child-tag.
 712
 713 It is safe to modify ATTR, and return a permutation of that list.
 714
 715 FILTER takes TAG as an argument, and should returns a semantic-tag.
 716 It is safe for FILTER to modify the input tag and return it."
 717   (when (car attrs)
 718     (when (not (symbolp (car attrs))) (error "Bad Attribute List in tag"))
 719     (cons (car attrs)
 720           (cons (semantic--tag-deep-copy-value (nth 1 attrs) filter)
 721                 (semantic--tag-deep-copy-attributes (nthcdr 2 attrs) filter)))))
 722
 723 (defun semantic--tag-deep-copy-value (value &optional filter)
 724   "Make a deep copy of VALUE, applying FILTER to each child-tag.
 725
 726 It is safe to modify VALUE, and return a permutation of that list.
 727
 728 FILTER takes TAG as an argument, and should returns a semantic-tag.
 729 It is safe for FILTER to modify the input tag and return it."
 730   (cond
 731    ;; Another tag.
 732    ((semantic-tag-p value)
 733     (semantic-tag-deep-copy-one-tag value filter))
 734
 735    ;; A list of more tags
 736    ((and (listp value) (semantic-tag-p (car value)))
 737     (semantic--tag-deep-copy-tag-list value filter))
 738
 739    ;; Some arbitrary data.
 740    (t value)))
 741
 742 (defun semantic--tag-deep-copy-tag-list (tags &optional filter)
 743   "Make a deep copy of TAGS, applying FILTER to each child-tag.
 744
 745 It is safe to modify the TAGS list, and return a permutation of that list.
 746
 747 FILTER takes TAG as an argument, and should returns a semantic-tag.
 748 It is safe for FILTER to modify the input tag and return it."
 749   (when (car tags)
 750     (if (semantic-tag-p (car tags))
 751         (cons (semantic-tag-deep-copy-one-tag (car tags) filter)
 752               (semantic--tag-deep-copy-tag-list (cdr tags) filter))
 753       (cons (car tags) (semantic--tag-deep-copy-tag-list (cdr tags) filter)))))
 754
 755 \f
 756 ;;; Standard Tag Access
 757 ;;
 758
 759 ;;; Common
 760 ;;
 761 (defsubst semantic-tag-modifiers (tag)
 762   "Return the value of the `:typemodifiers' attribute of TAG."
 763   (semantic-tag-get-attribute tag :typemodifiers))
 764
 765 (defun semantic-tag-docstring (tag &optional buffer)
 766   "Return the documentation of TAG.
 767 That is the value defined by the `:documentation' attribute.
 768 Optional argument BUFFER indicates where to get the text from.
 769 If not provided, then only the POSITION can be provided.
 770
 771 If you want to get documentation for languages that do not store
 772 the documentation string in the tag itself, use
 773 `semantic-documentation-for-tag' instead."
 774   (let ((p (semantic-tag-get-attribute tag :documentation)))
 775     (cond
 776      ((stringp p) p) ;; it is the doc string.
 777
 778      ((semantic-lex-token-with-text-p p)
 779       (semantic-lex-token-text p))
 780
 781      ((and (semantic-lex-token-without-text-p p)
 782            buffer)
 783       (with-current-buffer buffer
 784         (semantic-lex-token-text (car (semantic-lex p (1+ p))))))
 785
 786      (t nil))))
 787
 788 ;;; Generic attributes for tags of any class.
 789 ;;
 790 (defsubst semantic-tag-named-parent (tag)
 791   "Return the parent of TAG.
 792 That is the value of the `:parent' attribute.
 793 If a definition can occur outside an actual parent structure, but
 794 refers to that parent by name, then the :parent attribute should be used."
 795   (semantic-tag-get-attribute tag :parent))
 796
 797 ;;; Tags of class `type'
 798
 799 (defun semantic-tag-type-superclasses (tag)
 800   "Return the list of superclass names of the type that TAG describes."
 801   (let ((supers (semantic-tag-get-attribute tag :superclasses)))
 802     (cond ((stringp supers)
 803            ;; If we have a string, make it a list.
 804            (list supers))
 805           ((semantic-tag-p supers)
 806            ;; If we have one tag, return just the name.
 807            (list (semantic-tag-name supers)))
 808           ((and (consp supers) (semantic-tag-p (car supers)))
 809            ;; If we have a tag list, then return the names.
 810            (mapcar (lambda (s) (semantic-tag-name s))
 811                    supers))
 812           ((consp supers)
 813            ;; A list of something, return it.
 814            supers))))
 815
 816 (defun semantic--tag-find-parent-by-name (name supers)
 817   "Find the superclass NAME in the list of SUPERS.
 818 If a simple search doesn't do it, try splitting up the names
 819 in SUPERS."
 820   (let ((stag nil))
 821     (setq stag (semantic-find-first-tag-by-name name supers))
 822
 823     (when (not stag)
 824       (require 'semantic/analyze/fcn)
 825       (dolist (S supers)
 826         (let* ((sname (semantic-tag-name S))
 827                (splitparts (semantic-analyze-split-name sname))
 828                (parts (if (stringp splitparts)
 829                           (list splitparts)
 830                         (nreverse splitparts))))
 831           (when (string= name (car parts))
 832             (setq stag S))
 833           )))
 834
 835     stag))
 836
 837 (defun semantic-tag-type-superclass-protection (tag parentstring)
 838   "Return the inheritance protection in TAG from PARENTSTRING.
 839 PARENTSTRING is the name of the parent being inherited.
 840 The return protection is a symbol, 'public, 'protection, and 'private."
 841   (let ((supers (semantic-tag-get-attribute tag :superclasses)))
 842     (cond ((stringp supers)
 843            'public)
 844           ((semantic-tag-p supers)
 845            (let ((prot (semantic-tag-get-attribute supers :protection)))
 846              (or (cdr (assoc prot '(("public" . public)
 847                                     ("protected" . protected)
 848                                     ("private" . private))))
 849                  'public)))
 850           ((and (consp supers) (stringp (car supers)))
 851            'public)
 852           ((and (consp supers) (semantic-tag-p (car supers)))
 853            (let* ((stag (semantic--tag-find-parent-by-name parentstring supers))
 854                   (prot (when stag
 855                           (semantic-tag-get-attribute stag :protection))))
 856              (or (cdr (assoc prot '(("public" . public)
 857                                     ("protected" . protected)
 858                                     ("private" . private))))
 859                  (when (equal prot "unspecified")
 860                    (if (semantic-tag-of-type-p tag "class")
 861                        'private
 862                      'public))
 863                  'public))))
 864     ))
 865
 866 (defsubst semantic-tag-type-interfaces (tag)
 867   "Return the list of interfaces of the type that TAG describes."
 868   ;; @todo - make this as robust as the above.
 869   (semantic-tag-get-attribute tag :interfaces))
 870
 871 ;;; Tags of class `function'
 872 ;;
 873 (defsubst semantic-tag-function-arguments (tag)
 874   "Return the arguments of the function that TAG describes.
 875 That is the value of the `:arguments' attribute."
 876   (semantic-tag-get-attribute tag :arguments))
 877
 878 (defsubst semantic-tag-function-throws (tag)
 879   "Return the exceptions the function that TAG describes can throw.
 880 That is the value of the `:throws' attribute."
 881   (semantic-tag-get-attribute tag :throws))
 882
 883 (defsubst semantic-tag-function-parent (tag)
 884   "Return the parent of the function that TAG describes.
 885 That is the value of the `:parent' attribute.
 886 A function has a parent if it is a method of a class, and if the
 887 function does not appear in body of its parent class."
 888   (semantic-tag-named-parent tag))
 889
 890 (defsubst semantic-tag-function-destructor-p (tag)
 891   "Return non-nil if TAG describes a destructor function.
 892 That is the value of the `:destructor-flag' attribute."
 893   (semantic-tag-get-attribute tag :destructor-flag))
 894
 895 (defsubst semantic-tag-function-constructor-p (tag)
 896   "Return non-nil if TAG describes a constructor function.
 897 That is the value of the `:constructor-flag' attribute."
 898   (semantic-tag-get-attribute tag :constructor-flag))
 899
 900 ;;; Tags of class `variable'
 901 ;;
 902 (defsubst semantic-tag-variable-default (tag)
 903   "Return the default value of the variable that TAG describes.
 904 That is the value of the attribute `:default-value'."
 905   (semantic-tag-get-attribute tag :default-value))
 906
 907 (defsubst semantic-tag-variable-constant-p (tag)
 908   "Return non-nil if the variable that TAG describes is a constant.
 909 That is the value of the attribute `:constant-flag'."
 910   (semantic-tag-get-attribute tag :constant-flag))
 911
 912 ;;; Tags of class `include'
 913 ;;
 914 (defsubst semantic-tag-include-system-p (tag)
 915   "Return non-nil if the include that TAG describes is a system include.
 916 That is the value of the attribute `:system-flag'."
 917   (semantic-tag-get-attribute tag :system-flag))
 918
 919 (define-overloadable-function semantic-tag-include-filename (tag)
 920   "Return a filename representation of TAG.
 921 The default action is to return the `semantic-tag-name'.
 922 Some languages do not use full filenames in their include statements.
 923 Override this method to translate the code represenation
 924 into a filename.  (A relative filename if necessary.)
 925
 926 See `semantic-dependency-tag-file' to expand an include
 927 tag to a full file name.")
 928
 929 (defun semantic-tag-include-filename-default (tag)
 930   "Return a filename representation of TAG.
 931 Returns `semantic-tag-name'."
 932   (semantic-tag-name tag))
 933
 934 ;;; Tags of class `code'
 935 ;;
 936 (defsubst semantic-tag-code-detail (tag)
 937   "Return detail information from code that TAG describes.
 938 That is the value of the attribute `:detail'."
 939   (semantic-tag-get-attribute tag :detail))
 940
 941 ;;; Tags of class `alias'
 942 ;;
 943 (defsubst semantic-tag-new-alias (name meta-tag-class value &rest attributes)
 944   "Create a semantic tag of class alias.
 945 NAME is a name for this alias.
 946 META-TAG-CLASS is the class of the tag this tag is an alias.
 947 VALUE is the aliased definition.
 948 ATTRIBUTES is a list of additional attributes belonging to this tag."
 949   (apply 'semantic-tag name 'alias
 950          :aliasclass meta-tag-class
 951          :definition value
 952          attributes))
 953
 954 (defsubst semantic-tag-alias-class (tag)
 955   "Return the class of tag TAG is an alias."
 956   (semantic-tag-get-attribute tag :aliasclass))
 957
 958 (define-overloadable-function semantic-tag-alias-definition (tag)
 959   "Return the definition TAG is an alias.
 960 The returned value is a tag of the class that
 961 `semantic-tag-alias-class' returns for TAG.
 962 The default is to return the value of the :definition attribute.
 963 Return nil if TAG is not of class 'alias."
 964   (when (semantic-tag-of-class-p tag 'alias)
 965     (:override
 966      (semantic-tag-get-attribute tag :definition))))
 967
 968 ;;; Language Specific Tag access via overload
 969 ;;
 970 ;;;###autoload
 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 belonging 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 (defsubst semantic--tag-unlink-list-from-buffer (tags)
1122   "Convert TAGS from using an overlay to using an overlay proxy.
1123 This function is for internal use only."
1124   (mapcar 'semantic--tag-unlink-from-buffer tags))
1125
1126 (defun semantic--tag-unlink-from-buffer (tag)
1127   "Convert TAG from using an overlay to using an overlay proxy.
1128 This function is for internal use only."
1129   (when (semantic-tag-p tag)
1130     (let ((o (semantic-tag-overlay tag)))
1131       (when (semantic-overlay-p o)
1132         (semantic--tag-set-overlay
1133          tag (vector (semantic-overlay-start o)
1134                      (semantic-overlay-end o)))
1135         (semantic-overlay-delete o))
1136       ;; Look for a link hook on TAG.
1137       (semantic--tag-run-hooks tag 'unlink-hook)
1138       ;; Fix the sub-tags which contain overlays.
1139       (semantic--tag-unlink-list-from-buffer
1140        (semantic-tag-components-with-overlays tag)))))
1141
1142 (defsubst semantic--tag-link-list-to-buffer (tags)
1143   "Convert TAGS from using an overlay proxy to using an overlay.
1144 This function is for internal use only."
1145   (mapc 'semantic--tag-link-to-buffer tags))
1146
1147 (defun semantic--tag-link-to-buffer (tag)
1148   "Convert TAG from using an overlay proxy to using an overlay.
1149 This function is for internal use only."
1150   (when (semantic-tag-p tag)
1151     (let ((o (semantic-tag-overlay tag)))
1152       (when (and (vectorp o) (= (length o) 2))
1153         (setq o (semantic-make-overlay (aref o 0) (aref o 1)
1154                                        (current-buffer)))
1155         (semantic--tag-set-overlay tag o)
1156         (semantic-overlay-put o 'semantic tag)
1157         ;; Clear the :filename property
1158         (semantic--tag-put-property tag :filename nil))
1159       ;; Look for a link hook on TAG.
1160       (semantic--tag-run-hooks tag 'link-hook)
1161       ;; Fix the sub-tags which contain overlays.
1162       (semantic--tag-link-list-to-buffer
1163        (semantic-tag-components-with-overlays tag)))))
1164
1165 (defun semantic--tag-unlink-cache-from-buffer ()
1166   "Convert all tags in the current cache to use overlay proxys.
1167 This function is for internal use only."
1168   (require 'semantic)
1169   (semantic--tag-unlink-list-from-buffer
1170    ;; @todo- use fetch-tags-fast?
1171    (semantic-fetch-tags)))
1172
1173 (defvar semantic--buffer-cache)
1174
1175 (defun semantic--tag-link-cache-to-buffer ()
1176   "Convert all tags in the current cache to use overlays.
1177 This function is for internal use only."
1178   (require 'semantic)
1179   (condition-case nil
1180       ;; In this unique case, we cannot call the usual toplevel fn.
1181       ;; because we don't want a reparse, we want the old overlays.
1182       (semantic--tag-link-list-to-buffer
1183        semantic--buffer-cache)
1184     ;; Recover when there is an error restoring the cache.
1185     (error (message "Error recovering tag list")
1186            (semantic-clear-toplevel-cache)
1187            nil)))
1188 \f
1189 ;;; Tag Cooking
1190 ;;
1191 ;; Raw tags from a parser follow a different positional format than
1192 ;; those used in the buffer cache.  Raw tags need to be cooked into
1193 ;; semantic cache friendly tags for use by the masses.
1194 ;;
1195 (defsubst semantic--tag-expanded-p (tag)
1196   "Return non-nil if TAG is expanded.
1197 This function is for internal use only.
1198 See also the function `semantic--expand-tag'."
1199   ;; In fact a cooked tag is actually a list of cooked tags
1200   ;; because a raw tag can be expanded in several cooked ones!
1201   (when (consp tag)
1202     (while (and (semantic-tag-p (car tag))
1203                 (vectorp (semantic-tag-overlay (car tag))))
1204       (setq tag (cdr tag)))
1205     (null tag)))
1206
1207 (defvar semantic-tag-expand-function nil
1208   "Function used to expand a tag.
1209 It is passed each tag production, and must return a list of tags
1210 derived from it, or nil if it does not need to be expanded.
1211
1212 Languages with compound definitions should use this function to expand
1213 from one compound symbol into several.  For example, in C or Java the
1214 following definition is easily parsed into one tag:
1215
1216   int a, b;
1217
1218 This function should take this compound tag and turn it into two tags,
1219 one for A, and the other for B.")
1220 (make-variable-buffer-local 'semantic-tag-expand-function)
1221
1222 (defun semantic--tag-expand (tag)
1223   "Convert TAG from a raw state to a cooked state, and expand it.
1224 Returns a list of cooked tags.
1225
1226   The parser returns raw tags with positional data START END at the
1227 end of the tag data structure (a list for now).  We convert it from
1228 that to a cooked state that uses an overlay proxy, that is, a vector
1229 \[START END].
1230
1231   The raw tag is changed with side effects and maybe expanded in
1232 several derived tags when the variable `semantic-tag-expand-function'
1233 is set.
1234
1235 This function is for internal use only."
1236   (if (semantic--tag-expanded-p tag)
1237       ;; Just return TAG if it is already expanded (by a grammar
1238       ;; semantic action), or if it isn't recognized as a valid
1239       ;; semantic tag.
1240       tag
1241
1242     ;; Try to cook the tag.  This code will be removed when tag will
1243     ;; be directly created with the right format.
1244     (condition-case nil
1245         (let ((ocdr (semantic--tag-overlay-cdr tag)))
1246           ;; OCDR contains the sub-list of TAG whose car is the
1247           ;; OVERLAY part of TAG. That is, a list (OVERLAY START END).
1248           ;; Convert it into an overlay proxy ([START END]).
1249           (semantic--tag-set-overlay
1250            tag (vector (nth 1 ocdr) (nth 2 ocdr)))
1251           ;; Remove START END positions at end of tag.
1252           (setcdr ocdr nil)
1253           ;; At this point (length TAG) must be 5!
1254           ;;(unless (= (length tag) 5)
1255           ;;  (error "Tag expansion failed"))
1256           )
1257       (error
1258        (message "A Rule must return a single tag-line list!")
1259        (debug tag)
1260        nil))
1261     ;; Expand based on local configuration
1262     (if semantic-tag-expand-function
1263         (or (funcall semantic-tag-expand-function tag)
1264             (list tag))
1265       (list tag))))
1266 \f
1267 ;; Foreign tags
1268 ;;
1269 (defmacro semantic-foreign-tag-invalid (tag)
1270   "Signal that TAG is an invalid foreign tag."
1271   `(signal 'wrong-type-argument '(semantic-foreign-tag-p ,tag)))
1272
1273 (defsubst semantic-foreign-tag-p (tag)
1274   "Return non-nil if TAG is a foreign tag.
1275 That is, a tag unlinked from the originating buffer, which carries the
1276 originating buffer file name, and major mode."
1277   (and (semantic-tag-p tag)
1278        (semantic--tag-get-property tag :foreign-flag)))
1279
1280 (defsubst semantic-foreign-tag-check (tag)
1281   "Check that TAG is a valid foreign tag.
1282 Signal an error if not."
1283   (or (semantic-foreign-tag-p tag)
1284       (semantic-foreign-tag-invalid tag)))
1285
1286 (defun semantic-foreign-tag (&optional tag)
1287   "Return a copy of TAG as a foreign tag, or nil if it can't be done.
1288 TAG defaults to the tag at point in current buffer.
1289 See also `semantic-foreign-tag-p'."
1290   (or tag (setq tag (semantic-current-tag)))
1291   (when (semantic-tag-p tag)
1292     (let ((ftag (semantic-tag-copy tag nil t))
1293           ;; Do extra work for the doc strings, since this is a
1294           ;; common use case.
1295           (doc (condition-case nil
1296                    (semantic-documentation-for-tag tag)
1297                  (error nil))))
1298       ;; A foreign tag must carry its originating buffer file name!
1299       (when (semantic--tag-get-property ftag :filename)
1300         (semantic--tag-put-property ftag :mode (semantic-tag-mode tag))
1301         (semantic--tag-put-property ftag :documentation doc)
1302         (semantic--tag-put-property ftag :foreign-flag t)
1303         ftag))))
1304
1305 ;; High level obtain/insert foreign tag overloads
1306 (define-overloadable-function semantic-obtain-foreign-tag (&optional tag)
1307   "Obtain a foreign tag from TAG.
1308 TAG defaults to the tag at point in current buffer.
1309 Return the obtained foreign tag or nil if failed."
1310   (semantic-foreign-tag tag))
1311
1312 (defun semantic-insert-foreign-tag-default (foreign-tag)
1313   "Insert FOREIGN-TAG into the current buffer.
1314 The default behavior assumes the current buffer is a language file,
1315 and attempts to insert a prototype/function call."
1316   ;; Long term goal: Have a mechanism for a tempo-like template insert
1317   ;; for the given tag.
1318   (insert (semantic-format-tag-prototype foreign-tag)))
1319
1320 (define-overloadable-function semantic-insert-foreign-tag (foreign-tag)
1321   "Insert FOREIGN-TAG into the current buffer.
1322 Signal an error if FOREIGN-TAG is not a valid foreign tag.
1323 This function is overridable with the symbol `insert-foreign-tag'."
1324   (semantic-foreign-tag-check foreign-tag)
1325   (:override)
1326   (message (semantic-format-tag-summarize foreign-tag)))
1327
1328 ;;; Support log modes here
1329 (define-mode-local-override semantic-insert-foreign-tag
1330   log-edit-mode (foreign-tag)
1331   "Insert foreign tags into log-edit mode."
1332   (insert (concat "(" (semantic-format-tag-name foreign-tag) "): ")))
1333
1334 (define-mode-local-override semantic-insert-foreign-tag
1335   change-log-mode (foreign-tag)
1336   "Insert foreign tags into log-edit mode."
1337   (insert (concat "(" (semantic-format-tag-name foreign-tag) "): ")))
1338 \f
1339 ;;; Compatibility
1340 ;;
1341 (defconst semantic-token-version
1342   semantic-tag-version)
1343 (defconst semantic-token-incompatible-version
1344   semantic-tag-incompatible-version)
1345
1346 (defsubst semantic-token-type-parent (tag)
1347   "Return the parent of the type that TAG describes.
1348 The return value is a list.  A value of nil means no parents.
1349 The `car' of the list is either the parent class, or a list
1350 of parent classes.  The `cdr' of the list is the list of
1351 interfaces, or abstract classes which are parents of TAG."
1352   (cons (semantic-tag-get-attribute tag :superclasses)
1353         (semantic-tag-type-interfaces tag)))
1354 (make-obsolete 'semantic-token-type-parent
1355                "\
1356 use `semantic-tag-type-superclass' \
1357 and `semantic-tag-type-interfaces' instead" "23.2")
1358
1359 (semantic-alias-obsolete 'semantic-tag-make-assoc-list
1360                          'semantic-tag-make-plist "23.2")
1361
1362 (semantic-varalias-obsolete 'semantic-expand-nonterminal
1363                             'semantic-tag-expand-function "23.2")
1364
1365 (provide 'semantic/tag)
1366
1367 ;; Local variables:
1368 ;; generated-autoload-file: "loaddefs.el"
1369 ;; generated-autoload-load-name: "semantic/tag"
1370 ;; End:
1371
1372 ;; arch-tag: f7813634-c4f0-4817-a487-cbaa84333353
1373 ;;; semantic/tag.el ends here