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

   1 ;;; semantic-util.el --- Utilities for use with semantic 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 ;; Semantic utility API for use with semantic tag tables.
  27 ;;
  28
  29 (require 'assoc)
  30 (require 'semantic)
  31 (eval-when-compile
  32   ;; Emacs 21
  33   (condition-case nil
  34       (require 'newcomment)
  35     (error nil))
  36   ;; Semanticdb calls
  37   (require 'semantic/db)
  38   )
  39
  40 ;;; Code:
  41
  42 (defvar semantic-type-relation-separator-character '(".")
  43   "Character strings used to separate a parent/child relationship.
  44 This list of strings are used for displaying or finding separators
  45 in variable field dereferencing.  The first character will be used for
  46 display.  In C, a type field is separated like this: \"type.field\"
  47 thus, the character is a \".\".  In C, and additional value of \"->\"
  48 would be in the list, so that \"type->field\" could be found.")
  49 (make-variable-buffer-local 'semantic-type-relation-separator-character)
  50
  51 (defvar semantic-equivalent-major-modes nil
  52   "List of major modes which are considered equivalent.
  53 Equivalent modes share a parser, and a set of override methods.
  54 A value of nil means that the current major mode is the only one.")
  55 (make-variable-buffer-local 'semantic-equivalent-major-modes)
  56
  57 ;; These semanticdb calls will throw warnings in the byte compiler.
  58 ;; Doing the right thing to make them available at compile time
  59 ;; really messes up the compilation sequence.
  60 (defun semantic-file-tag-table (file)
  61   "Return a tag table for FILE.
  62 If it is loaded, return the stream after making sure it's ok.
  63 If FILE is not loaded, check to see if `semanticdb' feature exists,
  64    and use it to get tags from files not in memory.
  65 If FILE is not loaded, and semanticdb is not available, find the file
  66    and parse it."
  67   (if (find-buffer-visiting file)
  68       (save-excursion
  69         (set-buffer (find-buffer-visiting file))
  70         (semantic-fetch-tags))
  71     ;; File not loaded
  72     (if (and (fboundp 'semanticdb-minor-mode-p)
  73              (semanticdb-minor-mode-p))
  74         ;; semanticdb is around, use it.
  75         (semanticdb-file-stream file)
  76       ;; Get the stream ourselves.
  77       (save-excursion
  78         (set-buffer (find-file-noselect file))
  79         (semantic-fetch-tags)))))
  80
  81 (semantic-alias-obsolete 'semantic-file-token-stream
  82                          'semantic-file-tag-table)
  83
  84 (defun semantic-something-to-tag-table (something)
  85   "Convert SOMETHING into a semantic tag table.
  86 Something can be a tag with a valid BUFFER property, a tag table, a
  87 buffer, or a filename.  If SOMETHING is nil return nil."
  88   (cond
  89    ;; A list of tags
  90    ((and (listp something)
  91          (semantic-tag-p (car something)))
  92     something)
  93    ;; A buffer
  94    ((bufferp something)
  95     (save-excursion
  96       (set-buffer something)
  97       (semantic-fetch-tags)))
  98    ;; A Tag: Get that tag's buffer
  99    ((and (semantic-tag-with-position-p something)
 100          (semantic-tag-in-buffer-p something))
 101     (save-excursion
 102       (set-buffer (semantic-tag-buffer something))
 103       (semantic-fetch-tags)))
 104    ;; Tag with a file name in it
 105    ((and (semantic-tag-p something)
 106          (semantic-tag-file-name something)
 107          (file-exists-p (semantic-tag-file-name something)))
 108     (semantic-file-tag-table
 109      (semantic-tag-file-name something)))
 110    ;; A file name
 111    ((and (stringp something)
 112          (file-exists-p something))
 113     (semantic-file-tag-table something))
 114    ;; A Semanticdb table
 115    ((and (featurep 'semanticdb)
 116          (semanticdb-minor-mode-p)
 117          (semanticdb-abstract-table-child-p something))
 118     (semanticdb-refresh-table something)
 119     (semanticdb-get-tags something))
 120    ;; Semanticdb find-results
 121    ((and (featurep 'semanticdb)
 122          (semanticdb-minor-mode-p)
 123          (semanticdb-find-results-p something))
 124     (semanticdb-strip-find-results something))
 125    ;; NOTE: This commented out since if a search result returns
 126    ;;       empty, that empty would turn into everything on the next search.
 127    ;; Use the current buffer for nil
 128 ;;   ((null something)
 129 ;;    (semantic-fetch-tags))
 130    ;; don't know what it is
 131    (t nil)))
 132
 133 (semantic-alias-obsolete 'semantic-something-to-stream
 134                          'semantic-something-to-tag-table)
 135
 136 ;;; Recursive searching through dependency trees
 137 ;;
 138 ;; This will depend on the general searching APIS defined above.
 139 ;; but will add full recursion through the dependencies list per
 140 ;; stream.
 141 (defun semantic-recursive-find-nonterminal-by-name (name buffer)
 142   "Recursively find the first occurrence of NAME.
 143 Start search with BUFFER.  Recurse through all dependencies till found.
 144 The return item is of the form (BUFFER TOKEN) where BUFFER is the buffer
 145 in which TOKEN (the token found to match NAME) was found.
 146
 147 THIS ISN'T USED IN SEMANTIC.  DELETE ME SOON."
 148   (save-excursion
 149     (set-buffer buffer)
 150     (let* ((stream (semantic-fetch-tags))
 151            (includelist (or (semantic-find-tags-by-class 'include stream)
 152                             "empty.silly.thing"))
 153            (found (semantic-find-first-tag-by-name name stream))
 154            (unfound nil))
 155       (while (and (not found) includelist)
 156         (let ((fn (semantic-dependency-tag-file (car includelist))))
 157           (if (and fn (not (member fn unfound)))
 158               (save-excursion
 159                 (set-buffer (find-file-noselect fn))
 160                 (message "Scanning %s" (buffer-file-name))
 161                 (setq stream (semantic-fetch-tags))
 162                 (setq found (semantic-find-first-tag-by-name name stream))
 163                 (if found
 164                     (setq found (cons (current-buffer) (list found)))
 165                   (setq includelist
 166                         (append includelist
 167                                 (semantic-find-tags-by-class
 168                                  'include stream))))
 169                 (setq unfound (cons fn unfound)))))
 170         (setq includelist (cdr includelist)))
 171       found)))
 172 (make-obsolete 'semantic-recursive-find-nonterminal-by-name
 173                "Do not use this function.")
 174
 175 ;;; Completion APIs
 176 ;;
 177 ;; These functions provide minibuffer reading/completion for lists of
 178 ;; nonterminals.
 179 (defvar semantic-read-symbol-history nil
 180   "History for a symbol read.")
 181
 182 (defun semantic-read-symbol (prompt &optional default stream filter)
 183   "Read a symbol name from the user for the current buffer.
 184 PROMPT is the prompt to use.
 185 Optional arguments:
 186 DEFAULT is the default choice.  If no default is given, one is read
 187 from under point.
 188 STREAM is the list of tokens to complete from.
 189 FILTER is provides a filter on the types of things to complete.
 190 FILTER must be a function to call on each element."
 191   (if (not default) (setq default (thing-at-point 'symbol)))
 192   (if (not stream) (setq stream (semantic-fetch-tags)))
 193   (setq stream
 194         (if filter
 195             (semantic--find-tags-by-function filter stream)
 196           (semantic-brute-find-tag-standard stream)))
 197   (if (and default (string-match ":" prompt))
 198       (setq prompt
 199             (concat (substring prompt 0 (match-end 0))
 200                     " (default: " default ") ")))
 201   (completing-read prompt stream nil t ""
 202                    'semantic-read-symbol-history
 203                    default))
 204
 205 (defun semantic-read-variable (prompt &optional default stream)
 206   "Read a variable name from the user for the current buffer.
 207 PROMPT is the prompt to use.
 208 Optional arguments:
 209 DEFAULT is the default choice.  If no default is given, one is read
 210 from under point.
 211 STREAM is the list of tokens to complete from."
 212   (semantic-read-symbol
 213    prompt default
 214    (or (semantic-find-tags-by-class
 215         'variable (or stream (current-buffer)))
 216        (error "No local variables"))))
 217
 218 (defun semantic-read-function (prompt &optional default stream)
 219   "Read a function name from the user for the current buffer.
 220 PROMPT is the prompt to use.
 221 Optional arguments:
 222 DEFAULT is the default choice.  If no default is given, one is read
 223 from under point.
 224 STREAM is the list of tags to complete from."
 225   (semantic-read-symbol
 226    prompt default
 227    (or (semantic-find-tags-by-class
 228         'function (or stream (current-buffer)))
 229        (error "No local functions"))))
 230
 231 (defun semantic-read-type (prompt &optional default stream)
 232   "Read a type name from the user for the current buffer.
 233 PROMPT is the prompt to use.
 234 Optional arguments:
 235 DEFAULT is the default choice.  If no default is given, one is read
 236 from under point.
 237 STREAM is the list of tags to complete from."
 238   (semantic-read-symbol
 239    prompt default
 240    (or (semantic-find-tags-by-class
 241         'type (or stream (current-buffer)))
 242        (error "No local types"))))
 243
 244 \f
 245 ;;; Interactive Functions for
 246 ;;
 247 (defun semantic-describe-tag (&optional tag)
 248   "Describe TAG in the minibuffer.
 249 If TAG is nil, describe the tag under the cursor."
 250   (interactive)
 251   (if (not tag) (setq tag (semantic-current-tag)))
 252   (semantic-fetch-tags)
 253   (if tag (message (semantic-format-tag-summarize tag))))
 254
 255 \f
 256 ;;; Putting keys on tags.
 257 ;;
 258 (defun semantic-add-label (label value &optional tag)
 259   "Add a LABEL with VALUE on TAG.
 260 If TAG is not specified, use the tag at point."
 261   (interactive "sLabel: \nXValue (eval): ")
 262   (if (not tag)
 263       (progn
 264         (semantic-fetch-tags)
 265         (setq tag (semantic-current-tag))))
 266   (semantic--tag-put-property tag (intern label) value)
 267   (message "Added label %s with value %S" label value))
 268
 269 (defun semantic-show-label (label &optional tag)
 270   "Show the value of LABEL on TAG.
 271 If TAG is not specified, use the tag at point."
 272   (interactive "sLabel: ")
 273   (if (not tag)
 274       (progn
 275         (semantic-fetch-tags)
 276         (setq tag (semantic-current-tag))))
 277   (message "%s: %S" label (semantic--tag-get-property tag (intern label))))
 278
 279 \f
 280 ;;; Hacks
 281 ;;
 282 ;; Some hacks to help me test these functions
 283 (defun semantic-describe-buffer-var-helper (varsym buffer)
 284   "Display to standard out the value of VARSYM in BUFFER."
 285   (require 'data-debug)
 286   (let ((value (save-excursion
 287                  (set-buffer buffer)
 288                  (symbol-value varsym))))
 289     (cond
 290      ((and (consp value)
 291            (< (length value) 10))
 292       ;; Draw the list of things in the list.
 293       (princ (format "  %s:  #<list of %d items>\n"
 294                      varsym (length value)))
 295       (data-debug-insert-stuff-list
 296        value "    " )
 297       )
 298      (t
 299       ;; Else do a one-liner.
 300       (data-debug-insert-thing
 301        value " " (concat " " (symbol-name varsym) ": "))
 302       ))))
 303
 304 (defun semantic-describe-buffer ()
 305   "Describe the semantic environment for the current buffer."
 306   (interactive)
 307   (let ((buff (current-buffer))
 308         )
 309
 310     (with-output-to-temp-buffer (help-buffer)
 311       (help-setup-xref (list #'semantic-describe-buffer) (interactive-p))
 312       (with-current-buffer standard-output
 313         (princ "Semantic Configuration in ")
 314         (princ (buffer-name buff))
 315         (princ "\n\n")
 316
 317         (princ "Buffer specific configuration items:\n")
 318         (let ((vars '(major-mode
 319                       semantic-case-fold
 320                       semantic-expand-nonterminal
 321                       semantic-parser-name
 322                       semantic-parse-tree-state
 323                       semantic-lex-analyzer
 324                       semantic-lex-reset-hooks
 325                       )))
 326           (dolist (V vars)
 327             (semantic-describe-buffer-var-helper V buff)))
 328
 329         (princ "\nGeneral configuration items:\n")
 330         (let ((vars '(semantic-inhibit-functions
 331                       semantic-init-hooks
 332                       semantic-init-db-hooks
 333                       semantic-unmatched-syntax-hook
 334                       semantic--before-fetch-tags-hook
 335                       semantic-after-toplevel-bovinate-hook
 336                       semantic-after-toplevel-cache-change-hook
 337                       semantic-before-toplevel-cache-flush-hook
 338                       semantic-dump-parse
 339
 340                       )))
 341           (dolist (V vars)
 342             (semantic-describe-buffer-var-helper V buff)))
 343
 344         (princ "\n\n")
 345         (mode-local-describe-bindings-2 buff)
 346         )))
 347   )
 348
 349 (defun semantic-current-tag-interactive (p)
 350   "Display the current token.
 351 Argument P is the point to search from in the current buffer."
 352   (interactive "d")
 353   (let ((tok (semantic-brute-find-innermost-tag-by-position
 354               p (current-buffer))))
 355     (message (mapconcat 'semantic-abbreviate-nonterminal tok ","))
 356     (car tok))
 357   )
 358
 359 (defun semantic-hack-search ()
 360   "Display info about something under the cursor using generic methods."
 361   (interactive)
 362   (let (
 363         ;(name (thing-at-point 'symbol))
 364         (strm (cdr (semantic-fetch-tags)))
 365         (res nil))
 366 ;    (if name
 367         (setq res
 368 ;             (semantic-find-nonterminal-by-name name strm)
 369 ;             (semantic-find-nonterminal-by-type name strm)
 370 ;             (semantic-recursive-find-nonterminal-by-name name (current-buffer))
 371               (semantic-brute-find-tag-by-position (point) strm)
 372
 373               )
 374 ;       )
 375     (if res
 376         (progn
 377           (pop-to-buffer "*SEMANTIC HACK RESULTS*")
 378           (require 'pp)
 379           (erase-buffer)
 380           (insert (pp-to-string res) "\n")
 381           (goto-char (point-min))
 382           (shrink-window-if-larger-than-buffer))
 383       (message "nil"))))
 384
 385 (defun semantic-assert-valid-token (tok)
 386   "Assert that TOK is a valid token."
 387   (if (semantic-tag-p tok)
 388       (if (semantic-tag-with-position-p tok)
 389           (let ((o  (semantic-tag-overlay tok)))
 390             (if (and (semantic-overlay-p o)
 391                      (not (semantic-overlay-live-p o)))
 392                 (let ((debug-on-error t))
 393                   (error "Tag %s is invalid!" (semantic-tag-name tok)))
 394               ;; else, tag is OK.
 395               ))
 396         ;; Positionless tags are also ok.
 397         )
 398     (let ((debug-on-error t))
 399       (error "Not a semantic tag: %S" tok))))
 400
 401 (defun semantic-sanity-check (&optional cache over notfirst)
 402   "Perform a sanity check on the current buffer.
 403 The buffer's set of overlays, and those overlays found via the cache
 404 are verified against each other.
 405 CACHE, and OVER are the semantic cache, and the overlay list.
 406 NOTFIRST indicates that this was not the first call in the recursive use."
 407   (interactive)
 408   (if (and (not cache) (not over) (not notfirst))
 409       (setq cache semantic--buffer-cache
 410             over (semantic-overlays-in (point-min) (point-max))))
 411   (while cache
 412     (let ((chil (semantic-tag-components-with-overlays (car cache))))
 413       (if (not (memq (semantic-tag-overlay (car cache)) over))
 414           (message "Tag %s not in buffer overlay list."
 415                    (semantic-format-tag-concise-prototype (car cache))))
 416       (setq over (delq (semantic-tag-overlay (car cache)) over))
 417       (setq over (semantic-sanity-check chil over t))
 418       (setq cache (cdr cache))))
 419   (if (not notfirst)
 420       ;; Strip out all overlays which aren't semantic overlays
 421       (let ((o nil))
 422         (while over
 423           (when (and (semantic-overlay-get (car over) 'semantic)
 424                      (not (eq (semantic-overlay-get (car over) 'semantic)
 425                               'unmatched)))
 426             (setq o (cons (car over) o)))
 427           (setq over (cdr over)))
 428         (message "Remaining overlays: %S" o)))
 429   over)
 430
 431 (provide 'semantic/util)
 432
 433 ;;; Minor modes
 434 ;;
 435 (require 'semantic/util-modes)
 436
 437 ;;; semantic-util.el ends here