| 1 | ;;; sort.el --- Utilities for sorting and re-arranging tag tables. |
| 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 | ;; Keywords: syntax |
| 8 | |
| 9 | ;; This file is part of GNU Emacs. |
| 10 | |
| 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 12 | ;; it under the terms of the GNU General Public License as published by |
| 13 | ;; the Free Software Foundation, either version 3 of the License, or |
| 14 | ;; (at your option) any later version. |
| 15 | |
| 16 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 19 | ;; GNU General Public License for more details. |
| 20 | |
| 21 | ;; You should have received a copy of the GNU General Public License |
| 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 23 | |
| 24 | ;;; Commentary: |
| 25 | ;; |
| 26 | ;; Tag tables originate in the order they appear in a buffer, or source file. |
| 27 | ;; It is often useful to re-arrange them is some predictable way for browsing |
| 28 | ;; purposes. Re-organization may be alphabetical, or even a complete |
| 29 | ;; reorganization of parents and children. |
| 30 | ;; |
| 31 | ;; Originally written in semantic-util.el |
| 32 | ;; |
| 33 | |
| 34 | (require 'assoc) |
| 35 | (require 'semantic) |
| 36 | (require 'semantic/db) |
| 37 | (eval-when-compile |
| 38 | (require 'semantic/find)) |
| 39 | |
| 40 | (declare-function semanticdb-find-tags-external-children-of-type |
| 41 | "semantic/db-find") |
| 42 | |
| 43 | ;;; Alphanumeric sorting |
| 44 | ;; |
| 45 | ;; Takes a list of tags, and sorts them in a case-insensitive way |
| 46 | ;; at a single level. |
| 47 | |
| 48 | ;;; Code: |
| 49 | (defun semantic-string-lessp-ci (s1 s2) |
| 50 | "Case insensitive version of `string-lessp'. |
| 51 | Argument S1 and S2 are the strings to compare." |
| 52 | ;; Use downcase instead of upcase because an average name |
| 53 | ;; has more lower case characters. |
| 54 | (if (fboundp 'compare-strings) |
| 55 | (eq (compare-strings s1 0 nil s2 0 nil t) -1) |
| 56 | (string-lessp (downcase s1) (downcase s2)))) |
| 57 | |
| 58 | (defun semantic-sort-tag-type (tag) |
| 59 | "Return a type string for TAG guaranteed to be a string." |
| 60 | (let ((ty (semantic-tag-type tag))) |
| 61 | (cond ((stringp ty) |
| 62 | ty) |
| 63 | ((listp ty) |
| 64 | (or (car ty) "")) |
| 65 | (t "")))) |
| 66 | |
| 67 | (defun semantic-tag-lessp-name-then-type (A B) |
| 68 | "Return t if tag A is < tag B. |
| 69 | First sorts on name, then sorts on the name of the :type of |
| 70 | each tag." |
| 71 | (let ((na (semantic-tag-name A)) |
| 72 | (nb (semantic-tag-name B)) |
| 73 | ) |
| 74 | (if (string-lessp na nb) |
| 75 | t ; a sure thing. |
| 76 | (if (string= na nb) |
| 77 | ;; If equal, test the :type which might be different. |
| 78 | (let* ((ta (semantic-tag-type A)) |
| 79 | (tb (semantic-tag-type B)) |
| 80 | (tas (cond ((stringp ta) |
| 81 | ta) |
| 82 | ((semantic-tag-p ta) |
| 83 | (semantic-tag-name ta)) |
| 84 | (t nil))) |
| 85 | (tbs (cond ((stringp tb) |
| 86 | tb) |
| 87 | ((semantic-tag-p tb) |
| 88 | (semantic-tag-name tb)) |
| 89 | (t nil)))) |
| 90 | (if (and (stringp tas) (stringp tbs)) |
| 91 | (string< tas tbs) |
| 92 | ;; This is if A == B, and no types in A or B |
| 93 | nil)) |
| 94 | ;; This nil is if A > B, but not = |
| 95 | nil)))) |
| 96 | |
| 97 | (defun semantic-sort-tags-by-name-increasing (tags) |
| 98 | "Sort TAGS by name in increasing order with side effects. |
| 99 | Return the sorted list." |
| 100 | (sort tags (lambda (a b) |
| 101 | (string-lessp (semantic-tag-name a) |
| 102 | (semantic-tag-name b))))) |
| 103 | |
| 104 | (defun semantic-sort-tags-by-name-decreasing (tags) |
| 105 | "Sort TAGS by name in decreasing order with side effects. |
| 106 | Return the sorted list." |
| 107 | (sort tags (lambda (a b) |
| 108 | (string-lessp (semantic-tag-name b) |
| 109 | (semantic-tag-name a))))) |
| 110 | |
| 111 | (defun semantic-sort-tags-by-type-increasing (tags) |
| 112 | "Sort TAGS by type in increasing order with side effects. |
| 113 | Return the sorted list." |
| 114 | (sort tags (lambda (a b) |
| 115 | (string-lessp (semantic-sort-tag-type a) |
| 116 | (semantic-sort-tag-type b))))) |
| 117 | |
| 118 | (defun semantic-sort-tags-by-type-decreasing (tags) |
| 119 | "Sort TAGS by type in decreasing order with side effects. |
| 120 | Return the sorted list." |
| 121 | (sort tags (lambda (a b) |
| 122 | (string-lessp (semantic-sort-tag-type b) |
| 123 | (semantic-sort-tag-type a))))) |
| 124 | |
| 125 | (defun semantic-sort-tags-by-name-increasing-ci (tags) |
| 126 | "Sort TAGS by name in increasing order with side effects. |
| 127 | Return the sorted list." |
| 128 | (sort tags (lambda (a b) |
| 129 | (semantic-string-lessp-ci (semantic-tag-name a) |
| 130 | (semantic-tag-name b))))) |
| 131 | |
| 132 | (defun semantic-sort-tags-by-name-decreasing-ci (tags) |
| 133 | "Sort TAGS by name in decreasing order with side effects. |
| 134 | Return the sorted list." |
| 135 | (sort tags (lambda (a b) |
| 136 | (semantic-string-lessp-ci (semantic-tag-name b) |
| 137 | (semantic-tag-name a))))) |
| 138 | |
| 139 | (defun semantic-sort-tags-by-type-increasing-ci (tags) |
| 140 | "Sort TAGS by type in increasing order with side effects. |
| 141 | Return the sorted list." |
| 142 | (sort tags (lambda (a b) |
| 143 | (semantic-string-lessp-ci (semantic-sort-tag-type a) |
| 144 | (semantic-sort-tag-type b))))) |
| 145 | |
| 146 | (defun semantic-sort-tags-by-type-decreasing-ci (tags) |
| 147 | "Sort TAGS by type in decreasing order with side effects. |
| 148 | Return the sorted list." |
| 149 | (sort tags (lambda (a b) |
| 150 | (semantic-string-lessp-ci (semantic-sort-tag-type b) |
| 151 | (semantic-sort-tag-type a))))) |
| 152 | |
| 153 | (defun semantic-sort-tags-by-name-then-type-increasing (tags) |
| 154 | "Sort TAGS by name, then type in increasing order with side effects. |
| 155 | Return the sorted list." |
| 156 | (sort tags (lambda (a b) (semantic-tag-lessp-name-then-type a b)))) |
| 157 | |
| 158 | (defun semantic-sort-tags-by-name-then-type-decreasing (tags) |
| 159 | "Sort TAGS by name, then type in increasing order with side effects. |
| 160 | Return the sorted list." |
| 161 | (sort tags (lambda (a b) (semantic-tag-lessp-name-then-type b a)))) |
| 162 | |
| 163 | |
| 164 | (semantic-alias-obsolete 'semantic-sort-tokens-by-name-increasing |
| 165 | 'semantic-sort-tags-by-name-increasing) |
| 166 | (semantic-alias-obsolete 'semantic-sort-tokens-by-name-decreasing |
| 167 | 'semantic-sort-tags-by-name-decreasing) |
| 168 | (semantic-alias-obsolete 'semantic-sort-tokens-by-type-increasing |
| 169 | 'semantic-sort-tags-by-type-increasing) |
| 170 | (semantic-alias-obsolete 'semantic-sort-tokens-by-type-decreasing |
| 171 | 'semantic-sort-tags-by-type-decreasing) |
| 172 | (semantic-alias-obsolete 'semantic-sort-tokens-by-name-increasing-ci |
| 173 | 'semantic-sort-tags-by-name-increasing-ci) |
| 174 | (semantic-alias-obsolete 'semantic-sort-tokens-by-name-decreasing-ci |
| 175 | 'semantic-sort-tags-by-name-decreasing-ci) |
| 176 | (semantic-alias-obsolete 'semantic-sort-tokens-by-type-increasing-ci |
| 177 | 'semantic-sort-tags-by-type-increasing-ci) |
| 178 | (semantic-alias-obsolete 'semantic-sort-tokens-by-type-decreasing-ci |
| 179 | 'semantic-sort-tags-by-type-decreasing-ci) |
| 180 | |
| 181 | \f |
| 182 | ;;; Unique |
| 183 | ;; |
| 184 | ;; Scan a list of tags, removing duplicates. |
| 185 | ;; This must first sort the tags by name alphabetically ascending. |
| 186 | ;; |
| 187 | ;; Useful for completion lists, or other situations where the |
| 188 | ;; other data isn't as useful. |
| 189 | |
| 190 | (defun semantic-unique-tag-table-by-name (tags) |
| 191 | "Scan a list of TAGS, removing duplicate names. |
| 192 | This must first sort the tags by name alphabetically ascending. |
| 193 | For more complex uniqueness testing used by the semanticdb |
| 194 | typecaching system, see `semanticdb-typecache-merge-streams'." |
| 195 | (let ((sorted (semantic-sort-tags-by-name-increasing |
| 196 | (copy-sequence tags))) |
| 197 | (uniq nil)) |
| 198 | (while sorted |
| 199 | (if (or (not uniq) |
| 200 | (not (string= (semantic-tag-name (car sorted)) |
| 201 | (semantic-tag-name (car uniq))))) |
| 202 | (setq uniq (cons (car sorted) uniq))) |
| 203 | (setq sorted (cdr sorted)) |
| 204 | ) |
| 205 | (nreverse uniq))) |
| 206 | |
| 207 | (defun semantic-unique-tag-table (tags) |
| 208 | "Scan a list of TAGS, removing duplicates. |
| 209 | This must first sort the tags by position ascending. |
| 210 | TAGS are removed only if they are equivalent, as can happen when |
| 211 | multiple tag sources are scanned. |
| 212 | For more complex uniqueness testing used by the semanticdb |
| 213 | typecaching system, see `semanticdb-typecache-merge-streams'." |
| 214 | (let ((sorted (sort (copy-sequence tags) |
| 215 | (lambda (a b) |
| 216 | (cond ((not (semantic-tag-with-position-p a)) |
| 217 | t) |
| 218 | ((not (semantic-tag-with-position-p b)) |
| 219 | nil) |
| 220 | (t |
| 221 | (< (semantic-tag-start a) |
| 222 | (semantic-tag-start b))))))) |
| 223 | (uniq nil)) |
| 224 | (while sorted |
| 225 | (if (or (not uniq) |
| 226 | (not (semantic-equivalent-tag-p (car sorted) (car uniq)))) |
| 227 | (setq uniq (cons (car sorted) uniq))) |
| 228 | (setq sorted (cdr sorted)) |
| 229 | ) |
| 230 | (nreverse uniq))) |
| 231 | |
| 232 | \f |
| 233 | ;;; Tag Table Flattening |
| 234 | ;; |
| 235 | ;; In the 1.4 search API, there was a parameter "search-parts" which |
| 236 | ;; was used to find tags inside other tags. This was used |
| 237 | ;; infrequently, mostly for completion/jump routines. These types |
| 238 | ;; of commands would be better off with a flattened list, where all |
| 239 | ;; tags appear at the top level. |
| 240 | |
| 241 | ;;;###autoload |
| 242 | (defun semantic-flatten-tags-table (&optional table) |
| 243 | "Flatten the tags table TABLE. |
| 244 | All tags in TABLE, and all components of top level tags |
| 245 | in TABLE will appear at the top level of list. |
| 246 | Tags promoted to the top of the list will still appear |
| 247 | unmodified as components of their parent tags." |
| 248 | (let* ((table (semantic-something-to-tag-table table)) |
| 249 | ;; Initialize the starting list with our table. |
| 250 | (lists (list table))) |
| 251 | (mapc (lambda (tag) |
| 252 | (let ((components (semantic-tag-components tag))) |
| 253 | (if (and components |
| 254 | ;; unpositined tags can be hazardous to |
| 255 | ;; completion. Do we need any type of tag |
| 256 | ;; here? - EL |
| 257 | (semantic-tag-with-position-p (car components))) |
| 258 | (setq lists (cons |
| 259 | (semantic-flatten-tags-table components) |
| 260 | lists))))) |
| 261 | table) |
| 262 | (apply 'append (nreverse lists)) |
| 263 | )) |
| 264 | |
| 265 | \f |
| 266 | ;;; Buckets: |
| 267 | ;; |
| 268 | ;; A list of tags can be grouped into buckets based on the tag class. |
| 269 | ;; Bucketize means to take a list of tags at a given level in a tag |
| 270 | ;; table, and reorganize them into buckets based on class. |
| 271 | ;; |
| 272 | (defvar semantic-bucketize-tag-class |
| 273 | ;; Must use lambda because `semantic-tag-class' is a macro. |
| 274 | (lambda (tok) (semantic-tag-class tok)) |
| 275 | "Function used to get a symbol describing the class of a tag. |
| 276 | This function must take one argument of a semantic tag. |
| 277 | It should return a symbol found in `semantic-symbol->name-assoc-list' |
| 278 | which `semantic-bucketize' uses to bin up tokens. |
| 279 | To create new bins for an application augment |
| 280 | `semantic-symbol->name-assoc-list', and |
| 281 | `semantic-symbol->name-assoc-list-for-type-parts' in addition |
| 282 | to setting this variable (locally in your function).") |
| 283 | |
| 284 | (defun semantic-bucketize (tags &optional parent filter) |
| 285 | "Sort TAGS into a group of buckets based on tag class. |
| 286 | Unknown classes are placed in a Misc bucket. |
| 287 | Type bucket names are defined by either `semantic-symbol->name-assoc-list'. |
| 288 | If PARENT is specified, then TAGS belong to this PARENT in some way. |
| 289 | This will use `semantic-symbol->name-assoc-list-for-type-parts' to |
| 290 | generate bucket names. |
| 291 | Optional argument FILTER is a filter function to be applied to each bucket. |
| 292 | The filter function will take one argument, which is a list of tokens, and |
| 293 | may re-organize the list with side-effects." |
| 294 | (let* ((name-list (if parent |
| 295 | semantic-symbol->name-assoc-list-for-type-parts |
| 296 | semantic-symbol->name-assoc-list)) |
| 297 | (sn name-list) |
| 298 | (bins (make-vector (1+ (length sn)) nil)) |
| 299 | ask tagtype |
| 300 | (nsn nil) |
| 301 | (num 1) |
| 302 | (out nil)) |
| 303 | ;; Build up the bucket vector |
| 304 | (while sn |
| 305 | (setq nsn (cons (cons (car (car sn)) num) nsn) |
| 306 | sn (cdr sn) |
| 307 | num (1+ num))) |
| 308 | ;; Place into buckets |
| 309 | (while tags |
| 310 | (setq tagtype (funcall semantic-bucketize-tag-class (car tags)) |
| 311 | ask (assq tagtype nsn) |
| 312 | num (or (cdr ask) 0)) |
| 313 | (aset bins num (cons (car tags) (aref bins num))) |
| 314 | (setq tags (cdr tags))) |
| 315 | ;; Remove from buckets into a list. |
| 316 | (setq num 1) |
| 317 | (while (< num (length bins)) |
| 318 | (when (aref bins num) |
| 319 | (setq out |
| 320 | (cons (cons |
| 321 | (cdr (nth (1- num) name-list)) |
| 322 | ;; Filtering, First hacked by David Ponce david@dponce.com |
| 323 | (funcall (or filter 'nreverse) (aref bins num))) |
| 324 | out))) |
| 325 | (setq num (1+ num))) |
| 326 | (if (aref bins 0) |
| 327 | (setq out (cons (cons "Misc" |
| 328 | (funcall (or filter 'nreverse) (aref bins 0))) |
| 329 | out))) |
| 330 | (nreverse out))) |
| 331 | \f |
| 332 | ;;; Adoption |
| 333 | ;; |
| 334 | ;; Some languages allow children of a type to be defined outside |
| 335 | ;; the syntactic scope of that class. These routines will find those |
| 336 | ;; external members, and bring them together in a cloned copy of the |
| 337 | ;; class tag. |
| 338 | ;; |
| 339 | (defvar semantic-orphaned-member-metaparent-type "class" |
| 340 | "In `semantic-adopt-external-members', the type of 'type for metaparents. |
| 341 | A metaparent is a made-up type semantic token used to hold the child list |
| 342 | of orphaned members of a named type.") |
| 343 | (make-variable-buffer-local 'semantic-orphaned-member-metaparent-type) |
| 344 | |
| 345 | (defvar semantic-mark-external-member-function nil |
| 346 | "Function called when an externally defined orphan is found. |
| 347 | By default, the token is always marked with the `adopted' property. |
| 348 | This function should be locally bound by a program that needs |
| 349 | to add additional behaviors into the token list. |
| 350 | This function is called with two arguments. The first is TOKEN which is |
| 351 | a shallow copy of the token to be modified. The second is the PARENT |
| 352 | which is adopting TOKEN. This function should return TOKEN (or a copy of it) |
| 353 | which is then integrated into the revised token list.") |
| 354 | |
| 355 | (defun semantic-adopt-external-members (tags) |
| 356 | "Rebuild TAGS so that externally defined members are regrouped. |
| 357 | Some languages such as C++ and CLOS permit the declaration of member |
| 358 | functions outside the definition of the class. It is easier to study |
| 359 | the structure of a program when such methods are grouped together |
| 360 | more logically. |
| 361 | |
| 362 | This function uses `semantic-tag-external-member-p' to |
| 363 | determine when a potential child is an externally defined member. |
| 364 | |
| 365 | Note: Applications which use this function must account for token |
| 366 | types which do not have a position, but have children which *do* |
| 367 | have positions. |
| 368 | |
| 369 | Applications should use `semantic-mark-external-member-function' |
| 370 | to modify all tags which are found as externally defined to some |
| 371 | type. For example, changing the token type for generating extra |
| 372 | buckets with the bucket function." |
| 373 | (let ((parent-buckets nil) |
| 374 | (decent-list nil) |
| 375 | (out nil) |
| 376 | (tmp nil) |
| 377 | ) |
| 378 | ;; Rebuild the output list, stripping out all parented |
| 379 | ;; external entries |
| 380 | (while tags |
| 381 | (cond |
| 382 | ((setq tmp (semantic-tag-external-member-parent (car tags))) |
| 383 | (let ((tagcopy (semantic-tag-clone (car tags))) |
| 384 | (a (assoc tmp parent-buckets))) |
| 385 | (semantic--tag-put-property-no-side-effect tagcopy 'adopted t) |
| 386 | (if a |
| 387 | ;; If this parent is already in the list, append. |
| 388 | (setcdr (nthcdr (1- (length a)) a) (list tagcopy)) |
| 389 | ;; If not, prepend this new parent bucket into our list |
| 390 | (setq parent-buckets |
| 391 | (cons (cons tmp (list tagcopy)) parent-buckets))) |
| 392 | )) |
| 393 | ((eq (semantic-tag-class (car tags)) 'type) |
| 394 | ;; Types need to be rebuilt from scratch so we can add in new |
| 395 | ;; children to the child list. Only the top-level cons |
| 396 | ;; cells need to be duplicated so we can hack out the |
| 397 | ;; child list later. |
| 398 | (setq out (cons (semantic-tag-clone (car tags)) out)) |
| 399 | (setq decent-list (cons (car out) decent-list)) |
| 400 | ) |
| 401 | (t |
| 402 | ;; Otherwise, append this tag to our new output list. |
| 403 | (setq out (cons (car tags) out))) |
| 404 | ) |
| 405 | (setq tags (cdr tags))) |
| 406 | ;; Rescan out, by descending into all types and finding parents |
| 407 | ;; for all entries moved into the parent-buckets. |
| 408 | (while decent-list |
| 409 | (let* ((bucket (assoc (semantic-tag-name (car decent-list)) |
| 410 | parent-buckets)) |
| 411 | (bucketkids (cdr bucket))) |
| 412 | (when bucket |
| 413 | ;; Run our secondary marking function on the children |
| 414 | (if semantic-mark-external-member-function |
| 415 | (setq bucketkids |
| 416 | (mapcar (lambda (tok) |
| 417 | (funcall semantic-mark-external-member-function |
| 418 | tok (car decent-list))) |
| 419 | bucketkids))) |
| 420 | ;; We have some extra kids. Merge. |
| 421 | (semantic-tag-put-attribute |
| 422 | (car decent-list) :members |
| 423 | (append (semantic-tag-type-members (car decent-list)) |
| 424 | bucketkids)) |
| 425 | ;; Nuke the bucket label so it is not found again. |
| 426 | (setcar bucket nil)) |
| 427 | (setq decent-list |
| 428 | (append (cdr decent-list) |
| 429 | ;; get embedded types to scan and make copies |
| 430 | ;; of them. |
| 431 | (mapcar |
| 432 | (lambda (tok) (semantic-tag-clone tok)) |
| 433 | (semantic-find-tags-by-class 'type |
| 434 | (semantic-tag-type-members (car decent-list))))) |
| 435 | ))) |
| 436 | ;; Scan over all remaining lost external methods, and tack them |
| 437 | ;; onto the end. |
| 438 | (while parent-buckets |
| 439 | (if (car (car parent-buckets)) |
| 440 | (let* ((tmp (car parent-buckets)) |
| 441 | (fauxtag (semantic-tag-new-type |
| 442 | (car tmp) |
| 443 | semantic-orphaned-member-metaparent-type |
| 444 | nil ;; Part list |
| 445 | nil ;; parents (unknown) |
| 446 | )) |
| 447 | (bucketkids (cdr tmp))) |
| 448 | (semantic-tag-set-faux fauxtag) ;; properties |
| 449 | (if semantic-mark-external-member-function |
| 450 | (setq bucketkids |
| 451 | (mapcar (lambda (tok) |
| 452 | (funcall semantic-mark-external-member-function |
| 453 | tok fauxtag)) |
| 454 | bucketkids))) |
| 455 | (semantic-tag-put-attribute fauxtag :members bucketkids) |
| 456 | ;; We have a bunch of methods with no parent in this file. |
| 457 | ;; Create a meta-type to hold it. |
| 458 | (setq out (cons fauxtag out)) |
| 459 | )) |
| 460 | (setq parent-buckets (cdr parent-buckets))) |
| 461 | ;; Return the new list. |
| 462 | (nreverse out))) |
| 463 | |
| 464 | \f |
| 465 | ;;; External children |
| 466 | ;; |
| 467 | ;; In order to adopt external children, we need a few overload methods |
| 468 | ;; to enable the feature. |
| 469 | |
| 470 | ;;;###autoload |
| 471 | (define-overloadable-function semantic-tag-external-member-parent (tag) |
| 472 | "Return a parent for TAG when TAG is an external member. |
| 473 | TAG is an external member if it is defined at a toplevel and |
| 474 | has some sort of label defining a parent. The parent return will |
| 475 | be a string. |
| 476 | |
| 477 | The default behavior, if not overridden with |
| 478 | `tag-member-parent' gets the 'parent extra |
| 479 | specifier of TAG. |
| 480 | |
| 481 | If this function is overridden, use |
| 482 | `semantic-tag-external-member-parent-default' to also |
| 483 | include the default behavior, and merely extend your own." |
| 484 | ) |
| 485 | |
| 486 | (defun semantic-tag-external-member-parent-default (tag) |
| 487 | "Return the name of TAGs parent only if TAG is not defined in it's parent." |
| 488 | ;; Use only the extra spec because a type has a parent which |
| 489 | ;; means something completely different. |
| 490 | (let ((tp (semantic-tag-get-attribute tag :parent))) |
| 491 | (when (stringp tp) |
| 492 | tp) |
| 493 | )) |
| 494 | |
| 495 | (semantic-alias-obsolete 'semantic-nonterminal-external-member-parent |
| 496 | 'semantic-tag-external-member-parent) |
| 497 | |
| 498 | (define-overloadable-function semantic-tag-external-member-p (parent tag) |
| 499 | "Return non-nil if PARENT is the parent of TAG. |
| 500 | TAG is an external member of PARENT when it is somehow tagged |
| 501 | as having PARENT as it's parent. |
| 502 | PARENT and TAG must both be semantic tags. |
| 503 | |
| 504 | The default behavior, if not overridden with |
| 505 | `tag-external-member-p' is to match :parent attribute in |
| 506 | the name of TAG. |
| 507 | |
| 508 | If this function is overridden, use |
| 509 | `semantic-tag-external-member-children-p-default' to also |
| 510 | include the default behavior, and merely extend your own." |
| 511 | ) |
| 512 | |
| 513 | (defun semantic-tag-external-member-p-default (parent tag) |
| 514 | "Return non-nil if PARENT is the parent of TAG." |
| 515 | ;; Use only the extra spec because a type has a parent which |
| 516 | ;; means something completely different. |
| 517 | (let ((tp (semantic-tag-external-member-parent tag))) |
| 518 | (and (stringp tp) |
| 519 | (string= (semantic-tag-name parent) tp)) |
| 520 | )) |
| 521 | |
| 522 | (semantic-alias-obsolete 'semantic-nonterminal-external-member-p |
| 523 | 'semantic-tag-external-member-p) |
| 524 | |
| 525 | (define-overloadable-function semantic-tag-external-member-children (tag &optional usedb) |
| 526 | "Return the list of children which are not *in* TAG. |
| 527 | If optional argument USEDB is non-nil, then also search files in |
| 528 | the Semantic Database. If USEDB is a list of databases, search those |
| 529 | databases. |
| 530 | |
| 531 | Children in this case are functions or types which are members of |
| 532 | TAG, such as the parts of a type, but which are not defined inside |
| 533 | the class. C++ and CLOS both permit methods of a class to be defined |
| 534 | outside the bounds of the class' definition. |
| 535 | |
| 536 | The default behavior, if not overridden with |
| 537 | `tag-external-member-children' is to search using |
| 538 | `semantic-tag-external-member-p' in all top level definitions |
| 539 | with a parent of TAG. |
| 540 | |
| 541 | If this function is overridden, use |
| 542 | `semantic-tag-external-member-children-default' to also |
| 543 | include the default behavior, and merely extend your own." |
| 544 | ) |
| 545 | |
| 546 | (defun semantic-tag-external-member-children-default (tag &optional usedb) |
| 547 | "Return list of external children for TAG. |
| 548 | Optional argument USEDB specifies if the semantic database is used. |
| 549 | See `semantic-tag-external-member-children' for details." |
| 550 | (if (and usedb |
| 551 | (fboundp 'semanticdb-minor-mode-p) |
| 552 | (semanticdb-minor-mode-p) |
| 553 | (require 'semantic/db-find)) |
| 554 | (let ((m (semanticdb-find-tags-external-children-of-type |
| 555 | (semantic-tag-name tag)))) |
| 556 | (if m (apply #'append (mapcar #'cdr m)))) |
| 557 | (semantic--find-tags-by-function |
| 558 | `(lambda (tok) |
| 559 | ;; This bit of annoying backquote forces the contents of |
| 560 | ;; tag into the generated lambda. |
| 561 | (semantic-tag-external-member-p ',tag tok)) |
| 562 | (current-buffer)) |
| 563 | )) |
| 564 | |
| 565 | (define-overloadable-function semantic-tag-external-class (tag) |
| 566 | "Return a list of real tags that faux TAG might represent. |
| 567 | |
| 568 | In some languages, a method can be defined on an object which is |
| 569 | not in the same file. In this case, |
| 570 | `semantic-adopt-external-members' will create a faux-tag. If it |
| 571 | is necessary to get the tag from which for faux TAG was most |
| 572 | likely derived, then this function is needed." |
| 573 | (unless (semantic-tag-faux-p tag) |
| 574 | (signal 'wrong-type-argument (list tag 'semantic-tag-faux-p))) |
| 575 | (:override) |
| 576 | ) |
| 577 | |
| 578 | (defun semantic-tag-external-class-default (tag) |
| 579 | "Return a list of real tags that faux TAG might represent. |
| 580 | See `semantic-tag-external-class' for details." |
| 581 | (if (and (fboundp 'semanticdb-minor-mode-p) |
| 582 | (semanticdb-minor-mode-p)) |
| 583 | (let* ((semanticdb-search-system-databases nil) |
| 584 | (m (semanticdb-find-tags-by-class |
| 585 | (semantic-tag-class tag) |
| 586 | (semanticdb-find-tags-by-name (semantic-tag-name tag))))) |
| 587 | (semanticdb-strip-find-results m 'name)) |
| 588 | ;; Presumably, if the tag is faux, it is not local. |
| 589 | nil |
| 590 | )) |
| 591 | |
| 592 | (semantic-alias-obsolete 'semantic-nonterminal-external-member-children |
| 593 | 'semantic-tag-external-member-children) |
| 594 | |
| 595 | (provide 'semantic/sort) |
| 596 | |
| 597 | ;; Local variables: |
| 598 | ;; generated-autoload-file: "loaddefs.el" |
| 599 | ;; generated-autoload-feature: semantic/loaddefs |
| 600 | ;; generated-autoload-load-name: "semantic/sort" |
| 601 | ;; End: |
| 602 | |
| 603 | ;;; semantic-sort.el ends here |