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