lisp/cedet/semantic/tag-ls.el

   1 ;;; semantic/tag-ls.el --- Language Specific override functions for tags
   2
   3 ;; Copyright (C) 1999-2004, 2006-2014 Free Software Foundation, Inc.
   4
   5 ;; Author: Eric M. Ludlam <zappo@gnu.org>
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23 ;;
  24 ;; There are some features of tags that are too language dependent to
  25 ;; put in the core `semantic-tag' functionality.  For instance, the
  26 ;; protection of a tag (as specified by UML) could be almost anything.
  27 ;; In Java, it is a type specifier.  In C, there is a label.  This
  28 ;; information can be derived, and thus should not be stored in the tag
  29 ;; itself.  These are the functions that languages can use to derive
  30 ;; the information.
  31
  32 (require 'semantic)
  33 (require 'semantic/find)
  34
  35 ;;; Code:
  36
  37 ;;; TAG SIMILARITY:
  38 ;;
  39 ;; Two tags that represent the same thing are "similar", but not the "same".
  40 ;; Similar tags might have the same name, but one is a :prototype, while
  41 ;; the other is an implementation.
  42 ;;
  43 ;; Each language will have different things that can be ignored
  44 ;; between two "similar" tags, so similarity checks involve a series
  45 ;; of mode overridable features.  Some are "internal" features.
  46 (defvar semantic-tag-similar-ignorable-attributes '(:prototype-flag)
  47   "The tag attributes that can be ignored during a similarity test.")
  48
  49 (define-overloadable-function semantic--tag-similar-names-p (tag1 tag2 blankok)
  50   "Compare the names of TAG1 and TAG2.
  51 If BLANKOK is false, then the names must exactly match.
  52 If BLANKOK is true, then if either of TAG1 or TAG2 has blank
  53 names, then that is ok, and this returns true, but if they both
  54 have values, they must still match.")
  55
  56 (defun semantic--tag-similar-names-p-default (tag1 tag2 blankok)
  57   "Compare the names of TAG1 and TAG2.
  58 If BLANKOK is false, then the names must exactly match.
  59 If BLANKOK is true, then if either of TAG1 or TAG2 has blank
  60 names, then that is ok, and this returns true, but if they both
  61 have values, they must still match."
  62   (let ((n1 (semantic-tag-name tag1))
  63         (n2 (semantic-tag-name tag2)))
  64     (or (and blankok (or (null n1) (null n2) (string= n1 "") (string= n2 "")))
  65         (string= n1 n2))))
  66
  67 (define-overloadable-function semantic--tag-similar-types-p (tag1 tag2)
  68   "Compare the types of TAG1 and TAG2.
  69 This function can be overridden, for example to compare a fully
  70 qualified with an unqualified type."
  71   (cond
  72    ((and (null (semantic-tag-type tag1))
  73          (null (semantic-tag-type tag2)))
  74     t)
  75    ((or (null (semantic-tag-type tag1))
  76         (null (semantic-tag-type tag2)))
  77     nil)
  78    (t
  79     (:override))))
  80
  81 (defun semantic--tag-similar-types-p-default (tag1 tag2)
  82   "Compare the types of TAG1 and TAG2.
  83 This function can be overridden, for example to compare a fully
  84 qualified with an unqualified type."
  85   (semantic-tag-of-type-p tag1 (semantic-tag-type tag2)))
  86
  87 (define-overloadable-function semantic--tag-attribute-similar-p (attr value1 value2 ignorable-attributes)
  88   "Test to see if attribute ATTR is similar for VALUE1 and VALUE2.
  89 IGNORABLE-ATTRIBUTES is described in `semantic-tag-similar-p'.
  90 This function is internal, but allows customization of `semantic-tag-similar-p'
  91 for a given mode at a more granular level.
  92
  93 Note that :type, :name, and anything in IGNORABLE-ATTRIBUTES will
  94 not be passed to this function.
  95
  96 Modes that override this function can call `semantic--tag-attribute-similar-p-default'
  97 to do the default equality tests if ATTR is not special for that mode.")
  98
  99 (defun semantic--tag-attribute-similar-p-default (attr value1 value2 ignorable-attributes)
 100   "For ATTR, VALUE1, VALUE2 and IGNORABLE-ATTRIBUTES, test for similarity."
 101   (cond
 102    ;; Tag sublists require special testing.
 103    ((and (listp value1) (semantic-tag-p (car value1))
 104          (listp value2) (semantic-tag-p (car value2)))
 105     (let ((ans t)
 106           (taglist1 value1)
 107           (taglist2 value2))
 108       (when (not (eq (length taglist1) (length taglist2)))
 109         (setq ans nil))
 110       (while (and ans taglist1 taglist2)
 111         (setq ans (apply 'semantic-tag-similar-p
 112                          (car taglist1) (car taglist2)
 113                          ignorable-attributes)
 114               taglist1 (cdr taglist1)
 115               taglist2 (cdr taglist2)))
 116       ans))
 117
 118    ;; The attributes are not the same?
 119    ((not (equal value1 value2))
 120     nil)
 121
 122    (t t))
 123   )
 124
 125 (define-overloadable-function semantic-tag-similar-p (tag1 tag2 &rest ignorable-attributes)
 126   "Test to see if TAG1 and TAG2 are similar.
 127 Two tags are similar if their name, datatype, and various attributes
 128 are the same.
 129
 130 Similar tags that have sub-tags such as arg lists or type members,
 131 are similar w/out checking the sub-list of tags.
 132 Optional argument IGNORABLE-ATTRIBUTES are attributes to ignore while comparing similarity.
 133 By default, `semantic-tag-similar-ignorable-attributes' is referenced for
 134 attributes, and IGNORABLE-ATTRIBUTES will augment this list.
 135
 136 Note that even though :name is not an attribute, it can be used to
 137 to indicate lax comparison of names via `semantic--tag-similar-names-p'")
 138
 139 ;; Note: optional thing is because overloadable fcns don't handle this
 140 ;; quite right.
 141 (defun semantic-tag-similar-p-default (tag1 tag2 &optional ignorable-attributes)
 142   "Test to see if TAG1 and TAG2 are similar.
 143 Two tags are similar if their name, datatype, and various attributes
 144 are the same.
 145
 146 IGNORABLE-ATTRIBUTES are tag attributes that can be ignored.
 147
 148 See `semantic-tag-similar-p' for details."
 149   (or
 150    ;; Tags are similar if they have the exact same lisp object
 151    ;; Added for performance when testing a relatively common case in some uses
 152    ;; of this code.
 153    (eq tag1 tag2)
 154    ;; More complex similarity test.
 155    (let* ((ignore (append ignorable-attributes semantic-tag-similar-ignorable-attributes))
 156           (A1 (and (semantic--tag-similar-names-p tag1 tag2 (memq :name ignore))
 157                    (semantic--tag-similar-types-p tag1 tag2)
 158                    (semantic-tag-of-class-p tag1 (semantic-tag-class tag2))))
 159           (attr1 (semantic-tag-attributes tag1))
 160           (attr2 (semantic-tag-attributes tag2))
 161           (A2 t)
 162           (A3 t)
 163           )
 164      ;; Test if there are non-ignorable attributes in A2 which are not present in A1
 165      (while (and A2 attr2)
 166        (let ((a (car attr2)))
 167          (unless (or (eq a :type) (memq a ignore))
 168            (setq A2 (semantic-tag-get-attribute tag1 a)))
 169          (setq attr2 (cdr (cdr attr2)))))
 170      (while (and A2 attr1 A3)
 171        (let ((a (car attr1)))
 172
 173          (cond ((or (eq a :type)        ;; already tested above.
 174                     (memq a ignore))    ;; Ignore them...
 175                 nil)
 176
 177                (t
 178                 (setq A3
 179                       (semantic--tag-attribute-similar-p
 180                        a (car (cdr attr1)) (semantic-tag-get-attribute tag2 a)
 181                        ignorable-attributes)))
 182                ))
 183        (setq attr1 (cdr (cdr attr1))))
 184      (and A1 A2 A3))))
 185
 186 ;;; FULL NAMES
 187 ;;
 188 ;; For programmer convenience, a full name is not specified in source
 189 ;; code.  Instead some abbreviation is made, and the local environment
 190 ;; will contain the info needed to determine the full name.
 191 (define-overloadable-function semantic-tag-full-package (tag &optional stream-or-buffer)
 192   "Return the fully qualified package name of TAG in a package hierarchy.
 193 STREAM-OR-BUFFER can be anything convertible by `semantic-something-to-stream',
 194 but must be a toplevel semantic tag stream that contains TAG.
 195 A Package Hierarchy is defined in UML by the way classes and methods
 196 are organized on disk.  Some languages use this concept such that a
 197 class can be accessed via it's fully qualified name, (such as Java.)
 198 Other languages qualify names within a Namespace (such as C++) which
 199 result in a different package like structure.
 200
 201 Languages which do not override this function will just search the
 202 stream for a tag of class 'package, and return that."
 203   (let ((stream (semantic-something-to-tag-table
 204                  (or stream-or-buffer tag))))
 205     (:override-with-args (tag stream))))
 206
 207 (defun semantic-tag-full-package-default (tag stream)
 208   "Default method for `semantic-tag-full-package' for TAG.
 209 Return the name of the first tag of class `package' in STREAM."
 210   (let ((pack (car-safe (semantic-find-tags-by-class 'package stream))))
 211     (when (and pack (semantic-tag-p pack))
 212       (semantic-tag-name pack))))
 213
 214 (define-overloadable-function semantic-tag-full-name (tag &optional stream-or-buffer)
 215   "Return the fully qualified name of TAG in the package hierarchy.
 216 STREAM-OR-BUFFER can be anything convertible by `semantic-something-to-stream',
 217 but must be a toplevel semantic tag stream that contains TAG.
 218 A Package Hierarchy is defined in UML by the way classes and methods
 219 are organized on disk.  Some languages use this concept such that a
 220 class can be accessed via it's fully qualified name, (such as Java.)
 221 Other languages qualify names within a Namespace (such as C++) which
 222 result in a different package like structure.
 223
 224 Languages which do not override this function with
 225 `tag-full-name' will combine `semantic-tag-full-package' and
 226 `semantic-tag-name', separated with language separator character.
 227 Override functions only need to handle STREAM-OR-BUFFER with a
 228 tag stream value, or nil.
 229
 230 TODO - this function should probably also take a PARENT to TAG to
 231 resolve issues where a method in a class in a package is present."
 232   (let ((stream (semantic-something-to-tag-table
 233                  (or stream-or-buffer tag))))
 234     (:override-with-args (tag stream))))
 235
 236 (make-obsolete-overload 'semantic-nonterminal-full-name
 237                         'semantic-tag-full-name "23.2")
 238
 239 (defun semantic-tag-full-name-default (tag stream)
 240   "Default method for `semantic-tag-full-name'.
 241 Return the name of TAG found in the toplevel STREAM."
 242   (let ((pack (semantic-tag-full-package tag stream))
 243         (name (semantic-tag-name tag)))
 244     (if pack
 245         (concat pack
 246                 (car semantic-type-relation-separator-character)
 247                 name)
 248       name)))
 249
 250 ;;; UML features:
 251 ;;
 252 ;; UML can represent several types of features of a tag
 253 ;; such as the `protection' of a symbol, or if it is abstract,
 254 ;; leaf, etc.  Learn about UML to catch onto the lingo.
 255
 256 (define-overloadable-function semantic-tag-calculate-parent (tag)
 257   "Attempt to calculate the parent of TAG.
 258 The default behavior (if not overridden with `tag-calculate-parent')
 259 is to search a buffer found with TAG, and if externally defined,
 260 search locally, then semanticdb for that tag (when enabled.)")
 261
 262 (defun semantic-tag-calculate-parent-default (tag)
 263   "Attempt to calculate the parent of TAG."
 264   (when (semantic-tag-in-buffer-p tag)
 265     (with-current-buffer (semantic-tag-buffer tag)
 266       (save-excursion
 267         (goto-char (semantic-tag-start tag))
 268         (semantic-current-tag-parent))
 269       )))
 270
 271 (define-overloadable-function semantic-tag-protection (tag &optional parent)
 272   "Return protection information about TAG with optional PARENT.
 273 This function returns on of the following symbols:
 274    nil        - No special protection.  Language dependent.
 275    'public    - Anyone can access this TAG.
 276    'private   - Only methods in the local scope can access TAG.
 277    'protected - Like private for outside scopes, like public for child
 278                 classes.
 279 Some languages may choose to provide additional return symbols specific
 280 to themselves.  Use of this function should allow for this.
 281
 282 The default behavior (if not overridden with `tag-protection'
 283 is to return a symbol based on type modifiers."
 284   (and (not parent)
 285        (semantic-tag-overlay tag)
 286        (semantic-tag-in-buffer-p tag)
 287        (setq parent (semantic-tag-calculate-parent tag)))
 288   (:override))
 289
 290 (make-obsolete-overload 'semantic-nonterminal-protection
 291                         'semantic-tag-protection "23.2")
 292
 293 (defun semantic-tag-protection-default (tag &optional parent)
 294   "Return the protection of TAG as a child of PARENT default action.
 295 See `semantic-tag-protection'."
 296   (let ((mods (semantic-tag-modifiers tag))
 297         (prot nil))
 298     (while (and (not prot) mods)
 299       (if (stringp (car mods))
 300           (let ((s (car mods)))
 301             (setq prot
 302                   ;; A few silly defaults to get things started.
 303                   (cond ((or (string= s "public")
 304                              (string= s "extern")
 305                              (string= s "export"))
 306                          'public)
 307                         ((string= s "private")
 308                          'private)
 309                         ((string= s "protected")
 310                          'protected)
 311                         ((string= s "package")
 312                          'package)
 313                         ))))
 314       (setq mods (cdr mods)))
 315     prot))
 316
 317 (defun semantic-tag-package-protected-p (tag &optional parent currentpackage)
 318   "Non-nil if TAG is not available via package access control.
 319 For languages (such as Java) where a method is package protected,
 320 this method will return nil if TAG, as found in PARENT is available
 321 for access from a file in CURRENTPACKAGE.
 322 If TAG is not protected by PACKAGE, also return t.  Use
 323 `semantic-tag-protected-p' instead.
 324 If PARENT is not provided, it will be derived when passed to
 325 `semantic-tag-protection'.
 326 If CURRENTPACKAGE is not provided, it will be derived from the current
 327 buffer."
 328   (let ((tagpro (semantic-tag-protection tag parent)))
 329     (if (not (eq tagpro 'package))
 330         t ;; protected
 331
 332       ;; package protection, so check currentpackage.
 333       ;; Deriving the package is better from the parent, as TAG is
 334       ;; probably a field or method.
 335       (if (not currentpackage)
 336           (setq currentpackage (semantic-tag-full-package nil (current-buffer))))
 337       (let ((tagpack (semantic-tag-full-package (or parent tag))))
 338         (if (string= currentpackage tagpack)
 339             nil
 340           t)) )))
 341
 342 (defun semantic-tag-protected-p (tag protection &optional parent)
 343   "Non-nil if TAG is protected.
 344 PROTECTION is a symbol which can be returned by the method
 345 `semantic-tag-protection'.
 346 PARENT is the parent data type which contains TAG.
 347
 348 For these PROTECTIONs, true is returned if TAG is:
 349 @table @asis
 350 @item nil
 351   Always true.
 352 @item  private
 353   True if nil.
 354 @item protected
 355   True if private or nil.
 356 @item public
 357   True if private, protected, or nil.
 358 @end table"
 359   (if (null protection)
 360       t
 361     (let ((tagpro (semantic-tag-protection tag parent)))
 362       (or (and (eq protection 'private)
 363                (null tagpro))
 364           (and (eq protection 'protected)
 365                (or (null tagpro)
 366                    (eq tagpro 'private)))
 367           (and (eq protection 'public)
 368                (not (eq tagpro 'public)))))
 369     ))
 370
 371 (define-overloadable-function semantic-tag-abstract-p (tag &optional parent)
 372   "Return non nil if TAG is abstract.
 373 Optional PARENT is the parent tag of TAG.
 374 In UML, abstract methods and classes have special meaning and behavior
 375 in how methods are overridden.  In UML, abstract methods are italicized.
 376
 377 The default behavior (if not overridden with `tag-abstract-p'
 378 is to return true if `abstract' is in the type modifiers.")
 379
 380 (make-obsolete-overload 'semantic-nonterminal-abstract
 381                         'semantic-tag-abstract-p "23.2")
 382
 383 (defun semantic-tag-abstract-p-default (tag &optional parent)
 384   "Return non-nil if TAG is abstract as a child of PARENT default action.
 385 See `semantic-tag-abstract-p'."
 386   (let ((mods (semantic-tag-modifiers tag))
 387         (abs nil))
 388     (while (and (not abs) mods)
 389       (if (stringp (car mods))
 390           (setq abs (or (string= (car mods) "abstract")
 391                         (string= (car mods) "virtual"))))
 392       (setq mods (cdr mods)))
 393     abs))
 394
 395 (define-overloadable-function semantic-tag-leaf-p (tag &optional parent)
 396   "Return non nil if TAG is leaf.
 397 Optional PARENT is the parent tag of TAG.
 398 In UML, leaf methods and classes have special meaning and behavior.
 399
 400 The default behavior (if not overridden with `tag-leaf-p'
 401 is to return true if `leaf' is in the type modifiers.")
 402
 403 (make-obsolete-overload 'semantic-nonterminal-leaf
 404                         'semantic-tag-leaf-p "23.2")
 405
 406 (defun semantic-tag-leaf-p-default (tag &optional parent)
 407   "Return non-nil if TAG is leaf as a child of PARENT default action.
 408 See `semantic-tag-leaf-p'."
 409   (let ((mods (semantic-tag-modifiers tag))
 410         (leaf nil))
 411     (while (and (not leaf) mods)
 412       (if (stringp (car mods))
 413           ;; Use java FINAL as example default.  There is none
 414           ;; for C/C++
 415           (setq leaf (string= (car mods) "final")))
 416       (setq mods (cdr mods)))
 417     leaf))
 418
 419 (define-overloadable-function semantic-tag-static-p (tag &optional parent)
 420   "Return non nil if TAG is static.
 421 Optional PARENT is the parent tag of TAG.
 422 In UML, static methods and attributes mean that they are allocated
 423 in the parent class, and are not instance specific.
 424 UML notation specifies that STATIC entries are underlined.")
 425
 426 (defun semantic-tag-static-p-default (tag &optional parent)
 427   "Return non-nil if TAG is static as a child of PARENT default action.
 428 See `semantic-tag-static-p'."
 429   (let ((mods (semantic-tag-modifiers tag))
 430         (static nil))
 431     (while (and (not static) mods)
 432       (if (stringp (car mods))
 433           (setq static (string= (car mods) "static")))
 434       (setq mods (cdr mods)))
 435     static))
 436
 437 ;;;###autoload
 438 (define-overloadable-function semantic-tag-prototype-p (tag)
 439   "Return non nil if TAG is a prototype.
 440 For some languages, such as C, a prototype is a declaration of
 441 something without an implementation."
 442   )
 443
 444 (defun semantic-tag-prototype-p-default (tag)
 445   "Non-nil if TAG is a prototype."
 446   (let ((p (semantic-tag-get-attribute tag :prototype-flag)))
 447     (cond
 448      ;; Trust the parser author.
 449      (p p)
 450      ;; Empty types might be a prototype.
 451      ;; @todo - make this better.
 452      ((eq (semantic-tag-class tag) 'type)
 453       (not (semantic-tag-type-members tag)))
 454      ;; No other heuristics.
 455      (t nil))
 456     ))
 457
 458 (provide 'semantic/tag-ls)
 459
 460 ;; Local variables:
 461 ;; generated-autoload-file: "loaddefs.el"
 462 ;; generated-autoload-load-name: "semantic/tag-ls"
 463 ;; End:
 464
 465 ;;; semantic/tag-ls.el ends here