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