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

   1 ;;; ecb-semantic-wrapper.el -- define wrappers for all semantic funcs/vars
   2
   3 ;; Copyright (C) 2000 - 2003 Jesper Nordenberg,
   4 ;;                           Klaus Berndl,
   5 ;;                           Free Software Foundation, Inc.
   6
   7 ;; Author: Klaus Berndl <klaus.berndl@sdm.de>
   8 ;; Maintainer: Klaus Berndl <klaus.berndl@sdm.de>
   9 ;;             Kevin A. Burton <burton@openprivacy.org>
  10 ;; Keywords: browser, code, programming, tools
  11 ;; Created: 2003
  12
  13 ;; This program is free software; you can redistribute it and/or modify it under
  14 ;; the terms of the GNU General Public License as published by the Free Software
  15 ;; Foundation; either version 2, or (at your option) any later version.
  16
  17 ;; This program is distributed in the hope that it will be useful, but WITHOUT
  18 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  19 ;; FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  20 ;; details.
  21
  22 ;; You should have received a copy of the GNU General Public License along with
  23 ;; GNU Emacs; see the file COPYING.  If not, write to the Free Software
  24 ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  25
  26 ;; $Id: ecb-semantic-wrapper.el,v 1.8 2004-12-10 16:34:17 berndl Exp $
  27
  28 ;;; Commentary:
  29
  30 ;; This file contains wrappers for every semantic-function and -variable used
  31 ;; by ECB independent which semantic version is used. So the ECB-code is
  32 ;; independent from the fact, if semantic 2.0 offers backward-compatibility or
  33 ;; not. This library offers for each variable V of semantic a getter-function
  34 ;; named "ecb--V" and for each function F an alias named "ecb--F". V and F
  35 ;; follow the naming conventiones of semantic 2.0 but the resulting functions
  36 ;; always point to the correct variable or function of semantic independent
  37 ;; which semantic version is loaded. ECB only uses the functions exported from
  38 ;; ecb-semantic-wrapper.el!
  39
  40
  41 (require 'semantic)
  42
  43 (defconst ecb-semantic-2-loaded (string-match "^2" semantic-version))
  44 (defconst ecb-semantic-2-beta-nr (if (and ecb-semantic-2-loaded
  45                                           (string-match "beta\\([1-9]\\).*"
  46                                                         semantic-version))
  47                                      (string-to-number
  48                                       (match-string 1 semantic-version))
  49                                    -1))
  50
  51 (eval-when-compile
  52   (require 'silentcomp))
  53
  54 ;; semantic 1.X does not have this
  55 (silentcomp-defvar semanticdb-search-system-databases)
  56 (silentcomp-defvar semantic-format-use-images-flag)
  57 (silentcomp-defvar ezimage-use-images)
  58
  59 ;; -- getter functions for all variables of semantic currently used by ECB ---
  60
  61 (defsubst ecb--semantic-symbol->name-assoc-list ()
  62   "Return the value of `semantic-symbol->name-assoc-list'."
  63   (symbol-value 'semantic-symbol->name-assoc-list))
  64
  65 (defsubst ecb--semantic-symbol->name-assoc-list-for-type-parts ()
  66   "Return the value of `semantic-symbol->name-assoc-list-for-type-parts'."
  67   (symbol-value 'semantic-symbol->name-assoc-list-for-type-parts))
  68
  69 (defsubst ecb--semantic-format-tag-functions ()
  70   "Return either the value of `semantic-format-tag-functions' or
  71 `semantic-token->text-functions' depending which semantic version is loaded."
  72   (if (boundp 'semantic-format-tag-functions)
  73       (symbol-value 'semantic-format-tag-functions)
  74     (symbol-value 'semantic-token->text-functions)))
  75
  76 (defsubst ecb--semantic-orphaned-member-metaparent-type ()
  77   "Return the value of `semantic-orphaned-member-metaparent-type'."
  78   (symbol-value 'semantic-orphaned-member-metaparent-type))
  79
  80 (defsubst ecb--semantic-uml-colon-string ()
  81   "Return the value of `semantic-uml-colon-string'."
  82   (symbol-value 'semantic-uml-colon-string))
  83
  84 (defsubst ecb--semantic-format-face-alist ()
  85   "Return either the value of `semantic-format-face-alist' or
  86 `semantic-face-alist' depending which semantic version is loaded."
  87   (if (boundp 'semantic-format-face-alist)
  88       (symbol-value 'semantic-format-face-alist)
  89     (symbol-value 'semantic-face-alist)))
  90
  91 (defsubst ecb--semantic-after-toplevel-cache-change-hook ()
  92   "Return the hook-symbol `semantic-after-toplevel-cache-change-hook'."
  93   'semantic-after-toplevel-cache-change-hook)
  94
  95 (defsubst ecb--semantic-after-partial-cache-change-hook ()
  96   "Return the hook-symbol `semantic-after-partial-cache-change-hook'."
  97   'semantic-after-partial-cache-change-hook)
  98
  99 (defsubst ecb--ezimage-use-images ()
 100   (if (boundp 'ezimage-use-images)
 101       ezimage-use-images))
 102
 103 (defsubst ecb--semantic-format-use-images-flag ()
 104   (if (boundp 'semantic-format-use-images-flag)
 105       semantic-format-use-images-flag))
 106
 107 ;; -- an alias for all functions of semantic currently used by ECB ---
 108
 109 (defconst ecb--semantic-function-alist
 110   '((semantic-active-p                        . semantic-active-p)
 111     (semantic-token-function-args             . semantic-tag-function-arguments)
 112     (semantic-token-type-parts                . semantic-tag-type-members)
 113     (semantic-something-to-stream             . semantic-something-to-tag-table)
 114     (semantic-find-nonterminal-by-overlay     . semantic-find-tag-by-overlay)
 115     ;; here both functions return a list of tags!
 116     (semantic-find-nonterminal-by-token       . semantic-find-tags-by-class)
 117     (semantic-find-nonterminal-by-name        . semantic-brute-find-first-tag-by-name)
 118     (semantic-current-nonterminal-parent      . semantic-current-tag-parent)
 119     (semantic-adopt-external-members          . semantic-adopt-external-members)
 120     (semantic-bucketize                       . semantic-bucketize)
 121     (semantic-clear-toplevel-cache            . semantic-clear-toplevel-cache)
 122     (semantic-colorize-text                   . semantic--format-colorize-text)
 123     (semantic-current-nonterminal             . semantic-current-tag)
 124     (semantic-equivalent-tokens-p             . semantic-equivalent-tag-p)
 125     (semantic-find-dependency                 . semantic-dependency-tag-file)
 126     (semantic-find-documentation              . semantic-documentation-for-tag)
 127     (semantic-flex-start                      . semantic-lex-token-start)
 128     (semantic-nonterminal-children            . semantic-tag-children-compatibility)
 129     (semantic-nonterminal-protection          . semantic-tag-protection)
 130     (semantic-overlay-live-p                  . semantic-overlay-live-p)
 131     (semantic-overlay-p                       . semantic-overlay-p)
 132     (semantic-token-buffer                    . semantic-tag-buffer)
 133     (semantic-token-end                       . semantic-tag-end)
 134     (semantic-token-extra-spec                . semantic-tag-get-attribute)
 135     (semantic-token-function-parent           . semantic-tag-function-parent)
 136     (semantic-token-get                       . semantic--tag-get-property)
 137     (semantic-token-name                      . semantic-tag-name)
 138     (semantic-token-overlay                   . semantic-tag-overlay)
 139     (semantic-token-overlay-cdr               . semantic--tag-overlay-cdr)
 140     (semantic-token-p                         . semantic-tag-p)
 141     (semantic-token-put                       . semantic--tag-put-property)
 142     (semantic-token-start                     . semantic-tag-start)
 143     (semantic-token-token                     . semantic-tag-class)
 144     (semantic-token-type                      . semantic-tag-type)
 145     (semantic-token-type-parent-superclass    . semantic-tag-type-superclass)
 146     (semantic-token-type-parent-implement     . semantic-tag-type-interfaces)
 147     (semantic-token-with-position-p           . semantic-tag-with-position-p))
 148   "Alist where the car is a function of semantic 1.X and the cdr is the
 149 equivalent new function of semantic 2.X. This alist should contain every
 150 function ECB uses from the semantic library.")
 151
 152 (defconst ecb--semantic-format-function-alist
 153   '((semantic-name-nonterminal                  . semantic-format-tag-name)
 154     (semantic-abbreviate-nonterminal            . semantic-format-tag-abbreviate)
 155     (semantic-summarize-nonterminal             . semantic-format-tag-summarize)
 156     (semantic-prototype-nonterminal             . semantic-format-tag-prototype)
 157     (semantic-concise-prototype-nonterminal     . semantic-format-tag-concise-prototype)
 158     (semantic-uml-abbreviate-nonterminal        . semantic-format-tag-uml-abbreviate)
 159     (semantic-uml-prototype-nonterminal         . semantic-format-tag-uml-prototype)
 160     (semantic-uml-concise-prototype-nonterminal . semantic-format-tag-uml-concise-prototype)
 161     (semantic-prin1-nonterminal                 . semantic-format-tag-prin1))
 162 "Alist where the car is a function of semantic 1.X and the cdr is the
 163 equivalent new function of semantic 2.X. This alist should contain every
 164 function of `semantic-token->text-functions' (rsp. for semantic 2.X
 165 `semantic-format-tag-functions'.")
 166
 167 (defconst ecb--semanticdb-function-alist
 168   '((semanticdb-minor-mode-p             . semanticdb-minor-mode-p)
 169     ;; This is not a full compatible alias. Only the first two parameters can
 170     ;; be used with this alias!
 171     (semanticdb-find-nonterminal-by-name . semanticdb-find-tags-by-name)
 172     (semanticdb-full-filename            . semanticdb-full-filename))
 173   "Alist where the car is a function of semanticdb 1.X and the cdr is the
 174 equivalent new function of semanticdb 2.X. This alist should contain every
 175 function ECB uses from the semanticdb library.")
 176
 177 ;; new let us create the aliase. Each alias has the name "ecb--"<function of
 178 ;; semantic 2.0>.
 179 (dolist (f-elem (append ecb--semantic-function-alist
 180                         ecb--semantic-format-function-alist
 181                         ecb--semanticdb-function-alist))
 182   (defalias (intern (concat "ecb--" (symbol-name (cdr f-elem))))
 183     (if (fboundp (cdr f-elem))
 184         (cdr f-elem)
 185       (car f-elem))))
 186
 187
 188 (defsubst ecb--semantic-tag (name class &rest ignore)
 189   "Create a new semantic tag with name NAME and tag-class CLASS."
 190   (if (fboundp 'semantic-tag)
 191       (apply 'semantic-tag name class ignore)
 192     (list name class nil nil nil nil)))
 193
 194 (defsubst ecb--semantic--tag-set-overlay (tag overlay)
 195   "Set the overlay part of TAG with OVERLAY. OVERLAY can be an overlay or an
 196 unloaded buffer representation."
 197   (let ((o-cdr (ecb--semantic--tag-overlay-cdr tag)))
 198     (setcar o-cdr overlay)))
 199
 200 (defsubst ecb--semantic-tag-calculate-parent (tag)
 201   "Attempt to calculate the parent-tag of TAG."
 202   (if (fboundp 'semantic-tag-calculate-parent)
 203       (apply 'semantic-tag-calculate-parent (list tag))
 204     (save-excursion
 205       (set-buffer (ecb--semantic-tag-buffer tag))
 206       (goto-char (ecb--semantic-tag-start tag))
 207       (ecb--semantic-current-tag-parent))))
 208
 209 (cond ((fboundp 'semantic-tag-static-p)
 210        (defalias 'ecb--semantic-tag-static-p 'semantic-tag-static-p))
 211       ((fboundp 'semantic-tag-static)
 212        (defalias 'ecb--semantic-tag-static-p 'semantic-tag-static))
 213       ((fboundp 'semantic-nonterminal-static)
 214        (defalias 'ecb--semantic-tag-static-p 'semantic-nonterminal-static))
 215       (t
 216        (defsubst ecb--semantic-tag-static-p (tag &optional parent)
 217          nil)))
 218
 219 (cond ((fboundp 'semantic-tag-abstract-p)
 220        (defalias 'ecb--semantic-tag-abstract-p 'semantic-tag-abstract-p))
 221       ((fboundp 'semantic-tag-abstract)
 222        (defalias 'ecb--semantic-tag-abstract-p 'semantic-tag-abstract))
 223       ((fboundp 'semantic-nonterminal-abstract)
 224        (defalias 'ecb--semantic-tag-abstract-p 'semantic-nonterminal-abstract))
 225       (t
 226        (defsubst ecb--semantic-tag-abstract-p (tag &optional parent)
 227          nil)))
 228
 229 (defsubst ecb--semantic-tag-prototype-p (tag)
 230   (ecb--semantic-tag-get-attribute tag (if (> ecb-semantic-2-beta-nr 1)
 231                                            :prototype-flag
 232                                          'prototype)))
 233
 234 (if (fboundp 'semantic-tag-function-constructor-p)
 235     (defalias 'ecb--semantic-tag-function-constructor-p
 236       'semantic-tag-function-constructor-p)
 237   (defsubst ecb--semantic-tag-function-constructor-p (tag)
 238     (ecb--semantic-tag-get-attribute tag (if (> ecb-semantic-2-beta-nr 1)
 239                                              :constructor-flag
 240                                            'constructor))))
 241
 242 (if (fboundp 'semantic-tag-function-destructor-p)
 243     (defalias 'ecb--semantic-tag-function-destructor-p
 244       'semantic-tag-function-destructor-p)
 245   (defsubst ecb--semantic-tag-function-destructor-p (tag)
 246     (ecb--semantic-tag-get-attribute tag (if (> ecb-semantic-2-beta-nr 1)
 247                                              :destructor-flag
 248                                            'destructor))))
 249
 250
 251 (defsubst ecb--semantic-fetch-tags (&optional check-cache)
 252   (if (fboundp 'semantic-fetch-tags)
 253       (apply 'semantic-fetch-tags nil)
 254     (apply 'semantic-bovinate-toplevel (list check-cache))))
 255
 256
 257 (if (fboundp 'semantic-tag-components)
 258     (defalias 'ecb--semantic-tag-components
 259       'semantic-tag-components)
 260   (defun ecb--semantic-tag-components (tag)
 261     (cond ((equal (ecb--semantic-tag-class tag) 'type)
 262            (ecb--semantic-tag-type-members tag))
 263           ((equal (ecb--semantic-tag-class tag) 'function)
 264            (ecb--semantic-tag-function-arguments tag))
 265           (t nil))))
 266
 267 (if (fboundp 'semantic-flatten-tags-table)
 268     (defalias 'ecb--semantic-flatten-tags-table
 269       'semantic-flatten-tags-table)
 270   (defun ecb--semantic-flatten-tags-table (&optional table)
 271     "Flatten the tags table TABLE.
 272 All tags in TABLE, and all components of top level tags
 273 in TABLE will appear at the top level of list.
 274 Tags promoted to the top of the list will still appear
 275 unmodified as components of their parent tags."
 276     (let* ((table (ecb--semantic-something-to-tag-table table))
 277            ;; Initialize the starting list with our table.
 278            (lists (list table)))
 279       (mapc (lambda (tag)
 280               (let ((components (ecb--semantic-tag-components tag)))
 281                 (if (and components
 282                          ;; unpositined tags can be hazardous to
 283                          ;; completion.  Do we need any type of tag
 284                          ;; here? - EL
 285                          (ecb--semantic-tag-with-position-p (car components)))
 286                     (setq lists (cons
 287                                  (ecb--semantic-flatten-tags-table components)
 288                                  lists)))))
 289             table)
 290       (apply 'append (nreverse lists))
 291       )))
 292
 293 ;; Klaus Berndl <klaus.berndl@sdm.de>: Here we must make a list of tags by
 294 ;; hand for semantic 1.4!!
 295 (if (fboundp 'semantic-find-tags-by-name)
 296     (defalias 'ecb--semantic-find-tags-by-name
 297       'semantic-find-tags-by-name)
 298   (defsubst ecb--semantic-find-tags-by-name (name &optional table)
 299     (list (ecb--semantic-brute-find-first-tag-by-name name table))))
 300
 301 ;;; semanticdb-API Functions
 302 ;;
 303 ;; Once you have a search result, use these routines to operate
 304 ;; on the search results at a higher level
 305
 306
 307 (if (fboundp 'semanticdb-strip-find-results)
 308     (defalias 'ecb--semanticdb-strip-find-results
 309       'semanticdb-strip-find-results)
 310   (defun ecb--semanticdb-strip-find-results (results)
 311     "Strip a semanticdb search RESULTS to exclude objects.
 312 This makes it appear more like the results of a `semantic-find-' call."
 313     (apply #'append (mapcar #'cdr results))))
 314
 315 (if (fboundp 'semanticdb-find-result-length)
 316     (defalias 'ecb--semanticdb-find-result-length
 317       'semanticdb-find-result-length)
 318   (defun ecb--semanticdb-find-result-length (result)
 319     "Number of tags found in RESULT."
 320     (let ((count 0))
 321       (mapc (lambda (onetable)
 322               (setq count (+ count (1- (length onetable)))))
 323             result)
 324       count)))
 325
 326 (defun ecb--semanticdb-find-result-nth (result n)
 327   "In RESULT, return the Nth search result.
 328 Like `semanticdb-find-result-nth', except that only the TAG
 329 is returned, and the buffer it is found it will be made current.
 330 If the result tag has no position information, the originating buffer
 331 is still made current."
 332   (if (fboundp 'semanticdb-find-result-nth)
 333       (apply 'semanticdb-find-result-nth (list result n))
 334     (let ((ans nil)
 335           (anstable nil))
 336       ;; Loop over each single table hit.
 337       (while (and (not ans) result)
 338         ;; For each table result, get local length, and modify
 339         ;; N to be that much less.
 340         (let ((ll (length (cdr (car result))))) ;; local length
 341           (if (> ll n)
 342               ;; We have a local match.
 343               (setq ans (nth n (cdr (car result)))
 344                     anstable (car (car result)))
 345             ;; More to go.  Decrement N.
 346             (setq n (- n ll))))
 347         ;; Keep moving.
 348         (setq result (cdr result)))
 349       (cons ans anstable))))
 350
 351 (defun ecb--semanticdb-find-result-nth-with-file (result n)
 352   "In RESULT, return the Nth search result.
 353 This is a 0 based search result, with the first match being element 0. Returns
 354 a cons cell with car is the searched and found tag and the cdr is the
 355 associated full filename of this tag. If the search result is not associated
 356 with a file, then the cdr of the result-cons is nil."
 357   (let ((result-nth (ecb--semanticdb-find-result-nth result n)))
 358     (if (and (car result-nth)
 359              (ecb--semantic-tag-with-position-p (car result-nth))
 360              (cdr result-nth))
 361         (cons (car result-nth)
 362               (ecb--semanticdb-full-filename (cdr result-nth)))
 363       (cons (car result-nth) nil))))
 364
 365 (silentcomp-provide 'ecb-semantic-wrapper)
 366
 367 ;;; ecb-semantic-wrapper.el end here