cgit.sxemacs.org Git - packages/blob - xemacs-packages/semantic/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 Eric M. Ludlam
   4
   5 ;; Author: Eric M. Ludlam <zappo@gnu.org>
   6 ;; Keywords: syntax
   7 ;; X-RCS: $Id: semantic-util.el,v 1.131 2007/02/19 02:54:03 zappo Exp $
   8
   9 ;; This file is not part of GNU Emacs.
  10
  11 ;; Semantic 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 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; This software 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; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27 ;;
  28 ;; Semantic utility API for use with semantic tag tables.
  29 ;;
  30
  31 (require 'assoc)
  32 (require 'semantic)
  33 (eval-when-compile
  34   ;; Emacs 21
  35   (condition-case nil
  36       (require 'newcomment)
  37     (error nil))
  38   ;; Semanticdb calls
  39   (require 'semanticdb)
  40   )
  41
  42 ;;; Code:
  43
  44 (defvar semantic-type-relation-separator-character '(".")
  45   "Character strings used to separate a parent/child relationship.
  46 This list of strings are used for displaying or finding separators
  47 in variable field dereferencing.  The first character will be used for
  48 display.  In C, a type field is separated like this: \"type.field\"
  49 thus, the character is a \".\".  In C, and additional value of \"->\"
  50 would be in the list, so that \"type->field\" could be found.")
  51 (make-variable-buffer-local 'semantic-type-relation-separator-character)
  52
  53 (defvar semantic-equivalent-major-modes nil
  54   "List of major modes which are considered equivalent.
  55 Equivalent modes share a parser, and a set of override methods.
  56 A value of nil means that the current major mode is the only one.")
  57 (make-variable-buffer-local 'semantic-equivalent-major-modes)
  58
  59 ;; These semanticdb calls will throw warnings in the byte compiler.
  60 ;; Doing the right thing to make them available at compile time
  61 ;; really messes up the compilation sequence.
  62 (defun semantic-file-tag-table (file)
  63   "Return a tag table for FILE.
  64 If it is loaded, return the stream after making sure it's ok.
  65 If FILE is not loaded, check to see if `semanticdb' feature exists,
  66    and use it to get tags from files not in memory.
  67 If FILE is not loaded, and semanticdb is not available, find the file
  68    and parse it."
  69   (if (get-file-buffer file)
  70       (save-excursion
  71         (set-buffer (get-file-buffer file))
  72         (semantic-fetch-tags))
  73     ;; File not loaded
  74     (if (and (fboundp 'semanticdb-minor-mode-p)
  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-buffer 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 'semanticdb)
 118          (semanticdb-minor-mode-p)
 119          (semanticdb-abstract-table-p something))
 120     (semanticdb-get-tags something something))
 121    ;; Use the current buffer for nil
 122 ;;   ((null something)
 123 ;;    (semantic-fetch-tags))
 124    ;; don't know what it is
 125    (t nil)))
 126
 127 (semantic-alias-obsolete 'semantic-something-to-stream
 128                          'semantic-something-to-tag-table)
 129
 130 ;;; Recursive searching through dependency trees
 131 ;;
 132 ;; This will depend on the general searching APIS defined above.
 133 ;; but will add full recursion through the dependencies list per
 134 ;; stream.
 135 (defun semantic-recursive-find-nonterminal-by-name (name buffer)
 136   "Recursively find the first occurrence of NAME.
 137 Start search with BUFFER.  Recurse through all dependencies till found.
 138 The return item is of the form (BUFFER TOKEN) where BUFFER is the buffer
 139 in which TOKEN (the token found to match NAME) was found.
 140
 141 THIS ISN'T USED IN SEMANTIC.  DELETE ME SOON."
 142   (save-excursion
 143     (set-buffer buffer)
 144     (let* ((stream (semantic-fetch-tags))
 145            (includelist (or (semantic-find-tags-by-class 'include stream)
 146                             "empty.silly.thing"))
 147            (found (semantic-find-first-tag-by-name name stream))
 148            (unfound nil))
 149       (while (and (not found) includelist)
 150         (let ((fn (semantic-dependency-tag-file (car includelist))))
 151           (if (and fn (not (member fn unfound)))
 152               (save-excursion
 153                 (set-buffer (find-file-noselect fn))
 154                 (message "Scanning %s" (buffer-file-name))
 155                 (setq stream (semantic-fetch-tags))
 156                 (setq found (semantic-find-first-tag-by-name name stream))
 157                 (if found
 158                     (setq found (cons (current-buffer) (list found)))
 159                   (setq includelist
 160                         (append includelist
 161                                 (semantic-find-tags-by-class
 162                                  'include stream))))
 163                 (setq unfound (cons fn unfound)))))
 164         (setq includelist (cdr includelist)))
 165       found)))
 166 (make-obsolete 'semantic-recursive-find-nonterminal-by-name
 167                "Do not use this function.")
 168
 169 ;;; Completion APIs
 170 ;;
 171 ;; These functions provide minibuffer reading/completion for lists of
 172 ;; nonterminals.
 173 (defvar semantic-read-symbol-history nil
 174   "History for a symbol read.")
 175
 176 (defun semantic-read-symbol (prompt &optional default stream filter)
 177   "Read a symbol name from the user for the current buffer.
 178 PROMPT is the prompt to use.
 179 Optional arguments:
 180 DEFAULT is the default choice.  If no default is given, one is read
 181 from under point.
 182 STREAM is the list of tokens to complete from.
 183 FILTER is provides a filter on the types of things to complete.
 184 FILTER must be a function to call on each element."
 185   (if (not default) (setq default (thing-at-point 'symbol)))
 186   (if (not stream) (setq stream (semantic-fetch-tags)))
 187   (setq stream
 188         (if filter
 189             (semantic--find-tags-by-function filter stream)
 190           (semantic-brute-find-tag-standard stream)))
 191   (if (and default (string-match ":" prompt))
 192       (setq prompt
 193             (concat (substring prompt 0 (match-end 0))
 194                     " (default: " default ") ")))
 195   (completing-read prompt stream nil t ""
 196                    'semantic-read-symbol-history
 197                    default))
 198
 199 (defun semantic-read-variable (prompt &optional default stream)
 200   "Read a variable name from the user for the current buffer.
 201 PROMPT is the prompt to use.
 202 Optional arguments:
 203 DEFAULT is the default choice.  If no default is given, one is read
 204 from under point.
 205 STREAM is the list of tokens to complete from."
 206   (semantic-read-symbol
 207    prompt default
 208    (or (semantic-find-tags-by-class
 209         'variable (or stream (current-buffer)))
 210        (error "No local variables"))))
 211
 212 (defun semantic-read-function (prompt &optional default stream)
 213   "Read a function name from the user for the current buffer.
 214 PROMPT is the prompt to use.
 215 Optional arguments:
 216 DEFAULT is the default choice.  If no default is given, one is read
 217 from under point.
 218 STREAM is the list of tags to complete from."
 219   (semantic-read-symbol
 220    prompt default
 221    (or (semantic-find-tags-by-class
 222         'function (or stream (current-buffer)))
 223        (error "No local functions"))))
 224
 225 (defun semantic-read-type (prompt &optional default stream)
 226   "Read a type name from the user for the current buffer.
 227 PROMPT is the prompt to use.
 228 Optional arguments:
 229 DEFAULT is the default choice.  If no default is given, one is read
 230 from under point.
 231 STREAM is the list of tags to complete from."
 232   (semantic-read-symbol
 233    prompt default
 234    (or (semantic-find-tags-by-class
 235         'type (or stream (current-buffer)))
 236        (error "No local types"))))
 237
 238 \f
 239 ;;;; Mode-specific Token information
 240 ;;
 241
 242
 243
 244 ;;; Interactive Functions for
 245 ;;
 246 (defun semantic-describe-tag (&optional tag)
 247   "Describe TAG in the minibuffer.
 248 If TAG is nil, describe the tag under the cursor."
 249   (interactive)
 250   (if (not tag) (setq tag (semantic-current-tag)))
 251   (semantic-fetch-tags)
 252   (if tag (message (semantic-format-tag-summarize tag))))
 253
 254 \f
 255 ;;; Putting keys on tokens.
 256 ;;
 257 (defun semantic-add-label (label value &optional tag)
 258   "Add a LABEL with VALUE on TAG.
 259 If TAG is not specified, use the tag at point."
 260   (interactive "sLabel: \nXValue (eval): ")
 261   (if (not tag)
 262       (progn
 263         (semantic-fetch-tags)
 264         (setq tag (semantic-current-tag))))
 265   (semantic--tag-put-property tag (intern label) value)
 266   (message "Added label %s with value %S" label value))
 267
 268 (defun semantic-show-label (label &optional tag)
 269   "Show the value of LABEL on TAG.
 270 If TAG is not specified, use the tag at point."
 271   (interactive "sLabel: ")
 272   (if (not tag)
 273       (progn
 274         (semantic-fetch-tags)
 275         (setq tag (semantic-current-tag))))
 276   (message "%s: %S" label (semantic--tag-get-property tag (intern label))))
 277
 278 \f
 279 ;;; Hacks
 280 ;;
 281 ;; Some hacks to help me test these functions
 282 (defun semantic-current-token (p)
 283   "Display the current token.
 284 Argument P is the point to search from in the current buffer."
 285   (interactive "d")
 286   (let ((tok (semantic-brute-find-innermost-tag-by-position
 287               p (current-buffer))))
 288     (message (mapconcat 'semantic-abbreviate-nonterminal tok ","))
 289     (car tok))
 290   )
 291
 292 (defun semantic-hack-search ()
 293   "Display info about something under the cursor using generic methods."
 294   (interactive)
 295   (let (
 296         ;(name (thing-at-point 'symbol))
 297         (strm (cdr (semantic-fetch-tags)))
 298         (res nil))
 299 ;    (if name
 300         (setq res
 301 ;             (semantic-find-nonterminal-by-name name strm)
 302 ;             (semantic-find-nonterminal-by-type name strm)
 303 ;             (semantic-recursive-find-nonterminal-by-name name (current-buffer))
 304               (semantic-brute-find-tag-by-position (point) strm)
 305
 306               )
 307 ;       )
 308     (if res
 309         (progn
 310           (pop-to-buffer "*SEMANTIC HACK RESULTS*")
 311           (require 'pp)
 312           (erase-buffer)
 313           (insert (pp-to-string res) "\n")
 314           (goto-char (point-min))
 315           (shrink-window-if-larger-than-buffer))
 316       (message "nil"))))
 317
 318 (defun semantic-assert-valid-token (tok)
 319   "Assert that TOK is a valid token."
 320   (if (semantic-tag-p tok)
 321       (if (semantic-tag-with-position-p tok)
 322           (let ((o  (semantic-tag-overlay tok)))
 323             (if (and (semantic-overlay-p o)
 324                      (not (semantic-overlay-live-p o)))
 325                 (let ((debug-on-error t))
 326                   (error "Tag %s is invalid!" (semantic-tag-name tok)))
 327               ;; else, tag is OK.
 328               ))
 329         ;; Positionless tags are also ok.
 330         )
 331     (let ((debug-on-error t))
 332       (error "Not a semantic tag: %S" tok))))
 333
 334 (defun semantic-sanity-check (&optional cache over notfirst)
 335   "Perform a sanity check on the current buffer.
 336 The buffer's set of overlays, and those overlays found via the cache
 337 are verified against each other.
 338 CACHE, and OVER are the semantic cache, and the overlay list.
 339 NOTFIRST indicates that this was not the first call in the recursive use."
 340   (interactive)
 341   (if (and (not cache) (not over) (not notfirst))
 342       (setq cache semantic--buffer-cache
 343             over (semantic-overlays-in (point-min) (point-max))))
 344   (while cache
 345     (let ((chil (semantic-tag-components-with-overlays (car cache))))
 346       (if (not (memq (semantic-tag-overlay (car cache)) over))
 347           (message "Tag %s not in buffer overlay list."
 348                    (semantic-format-tag-concise-prototype (car cache))))
 349       (setq over (delq (semantic-tag-overlay (car cache)) over))
 350       (setq over (semantic-sanity-check chil over t))
 351       (setq cache (cdr cache))))
 352   (if (not notfirst)
 353       ;; Strip out all overlays which aren't semantic overlays
 354       (let ((o nil))
 355         (while over
 356           (when (and (semantic-overlay-get (car over) 'semantic)
 357                      (not (eq (semantic-overlay-get (car over) 'semantic)
 358                               'unmatched)))
 359             (setq o (cons (car over) o)))
 360           (setq over (cdr over)))
 361         (message "Remaining overlays: %S" o)))
 362   over)
 363
 364 (provide 'semantic-util)
 365
 366 ;;; Minor modes
 367 ;;
 368 (require 'semantic-util-modes)
 369
 370 ;;; semantic-util.el ends here