1 ;;; semantic/util.el --- Utilities for use with semantic tag tables
3 ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
4 ;;; 2008, 2009 Free Software Foundation, Inc.
6 ;; Author: Eric M. Ludlam <zappo@gnu.org>
9 ;; This file is part of GNU Emacs.
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.
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.
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/>.
26 ;; Semantic utility API for use with semantic tag tables.
32 (declare-function data-debug-insert-stuff-list "data-debug")
33 (declare-function data-debug-insert-thing "data-debug")
34 (declare-function semanticdb-file-stream "semantic/db")
35 (declare-function semanticdb-abstract-table-child-p "semantic/db")
36 (declare-function semanticdb-refresh-table "semantic/db")
37 (declare-function semanticdb-get-tags "semantic/db")
38 (declare-function semanticdb-find-results-p "semantic/db-find")
40 ;; For semantic-find-tags-by-class, semantic--find-tags-by-function,
41 ;; and semantic-brute-find-tag-standard:
42 (eval-when-compile (require 'semantic/find))
46 (defvar semantic-type-relation-separator-character '(".")
47 "Character strings used to separate a parent/child relationship.
48 This list of strings are used for displaying or finding separators
49 in variable field dereferencing. The first character will be used for
50 display. In C, a type field is separated like this: \"type.field\"
51 thus, the character is a \".\". In C, and additional value of \"->\"
52 would be in the list, so that \"type->field\" could be found.")
53 (make-variable-buffer-local 'semantic-type-relation-separator-character)
55 (defvar semantic-equivalent-major-modes nil
56 "List of major modes which are considered equivalent.
57 Equivalent modes share a parser, and a set of override methods.
58 A value of nil means that the current major mode is the only one.")
59 (make-variable-buffer-local 'semantic-equivalent-major-modes)
61 ;; These semanticdb calls will throw warnings in the byte compiler.
62 ;; Doing the right thing to make them available at compile time
63 ;; really messes up the compilation sequence.
64 (defun semantic-file-tag-table (file)
65 "Return a tag table for FILE.
66 If it is loaded, return the stream after making sure it's ok.
67 If FILE is not loaded, check to see if `semanticdb' feature exists,
68 and use it to get tags from files not in memory.
69 If FILE is not loaded, and semanticdb is not available, find the file
71 (if (find-buffer-visiting file)
73 (set-buffer (find-buffer-visiting file))
74 (semantic-fetch-tags))
76 (if (and (require 'semantic/db-mode)
77 (semanticdb-minor-mode-p))
78 ;; semanticdb is around, use it.
79 (semanticdb-file-stream file)
80 ;; Get the stream ourselves.
82 (set-buffer (find-file-noselect file))
83 (semantic-fetch-tags)))))
85 (semantic-alias-obsolete 'semantic-file-token-stream
86 'semantic-file-tag-table)
88 (defun semantic-something-to-tag-table (something)
89 "Convert SOMETHING into a semantic tag table.
90 Something can be a tag with a valid BUFFER property, a tag table, a
91 buffer, or a filename. If SOMETHING is nil return nil."
94 ((and (listp something)
95 (semantic-tag-p (car something)))
100 (set-buffer something)
101 (semantic-fetch-tags)))
102 ;; A Tag: Get that tag's buffer
103 ((and (semantic-tag-with-position-p something)
104 (semantic-tag-in-buffer-p something))
106 (set-buffer (semantic-tag-buffer something))
107 (semantic-fetch-tags)))
108 ;; Tag with a file name in it
109 ((and (semantic-tag-p something)
110 (semantic-tag-file-name something)
111 (file-exists-p (semantic-tag-file-name something)))
112 (semantic-file-tag-table
113 (semantic-tag-file-name something)))
115 ((and (stringp something)
116 (file-exists-p something))
117 (semantic-file-tag-table something))
118 ;; A Semanticdb table
119 ((and (featurep 'semantic/db)
120 (semanticdb-minor-mode-p)
121 (semanticdb-abstract-table-child-p something))
122 (semanticdb-refresh-table something)
123 (semanticdb-get-tags something))
124 ;; Semanticdb find-results
125 ((and (featurep 'semantic/db)
126 (semanticdb-minor-mode-p)
127 (require 'semantic/db-find)
128 (semanticdb-find-results-p something))
129 (semanticdb-strip-find-results something))
130 ;; NOTE: This commented out since if a search result returns
131 ;; empty, that empty would turn into everything on the next search.
132 ;; Use the current buffer for nil
134 ;; (semantic-fetch-tags))
135 ;; don't know what it is
138 (semantic-alias-obsolete 'semantic-something-to-stream
139 'semantic-something-to-tag-table)
141 ;;; Recursive searching through dependency trees
143 ;; This will depend on the general searching APIS defined above.
144 ;; but will add full recursion through the dependencies list per
146 (defun semantic-recursive-find-nonterminal-by-name (name buffer)
147 "Recursively find the first occurrence of NAME.
148 Start search with BUFFER. Recurse through all dependencies till found.
149 The return item is of the form (BUFFER TOKEN) where BUFFER is the buffer
150 in which TOKEN (the token found to match NAME) was found.
152 THIS ISN'T USED IN SEMANTIC. DELETE ME SOON."
155 (let* ((stream (semantic-fetch-tags))
156 (includelist (or (semantic-find-tags-by-class 'include stream)
157 "empty.silly.thing"))
158 (found (semantic-find-first-tag-by-name name stream))
160 (while (and (not found) includelist)
161 (let ((fn (semantic-dependency-tag-file (car includelist))))
162 (if (and fn (not (member fn unfound)))
164 (set-buffer (find-file-noselect fn))
165 (message "Scanning %s" (buffer-file-name))
166 (setq stream (semantic-fetch-tags))
167 (setq found (semantic-find-first-tag-by-name name stream))
169 (setq found (cons (current-buffer) (list found)))
172 (semantic-find-tags-by-class
174 (setq unfound (cons fn unfound)))))
175 (setq includelist (cdr includelist)))
177 (make-obsolete 'semantic-recursive-find-nonterminal-by-name
178 "Do not use this function.")
182 ;; These functions provide minibuffer reading/completion for lists of
184 (defvar semantic-read-symbol-history nil
185 "History for a symbol read.")
187 (defun semantic-read-symbol (prompt &optional default stream filter)
188 "Read a symbol name from the user for the current buffer.
189 PROMPT is the prompt to use.
191 DEFAULT is the default choice. If no default is given, one is read
193 STREAM is the list of tokens to complete from.
194 FILTER is provides a filter on the types of things to complete.
195 FILTER must be a function to call on each element."
196 (if (not default) (setq default (thing-at-point 'symbol)))
197 (if (not stream) (setq stream (semantic-fetch-tags)))
200 (semantic--find-tags-by-function filter stream)
201 (semantic-brute-find-tag-standard stream)))
202 (if (and default (string-match ":" prompt))
204 (concat (substring prompt 0 (match-end 0))
205 " (default: " default ") ")))
206 (completing-read prompt stream nil t ""
207 'semantic-read-symbol-history
210 (defun semantic-read-variable (prompt &optional default stream)
211 "Read a variable name from the user for the current buffer.
212 PROMPT is the prompt to use.
214 DEFAULT is the default choice. If no default is given, one is read
216 STREAM is the list of tokens to complete from."
217 (semantic-read-symbol
219 (or (semantic-find-tags-by-class
220 'variable (or stream (current-buffer)))
221 (error "No local variables"))))
223 (defun semantic-read-function (prompt &optional default stream)
224 "Read a function name from the user for the current buffer.
225 PROMPT is the prompt to use.
227 DEFAULT is the default choice. If no default is given, one is read
229 STREAM is the list of tags to complete from."
230 (semantic-read-symbol
232 (or (semantic-find-tags-by-class
233 'function (or stream (current-buffer)))
234 (error "No local functions"))))
236 (defun semantic-read-type (prompt &optional default stream)
237 "Read a type name from the user for the current buffer.
238 PROMPT is the prompt to use.
240 DEFAULT is the default choice. If no default is given, one is read
242 STREAM is the list of tags to complete from."
243 (semantic-read-symbol
245 (or (semantic-find-tags-by-class
246 'type (or stream (current-buffer)))
247 (error "No local types"))))
250 ;;; Interactive Functions for
252 (defun semantic-describe-tag (&optional tag)
253 "Describe TAG in the minibuffer.
254 If TAG is nil, describe the tag under the cursor."
256 (if (not tag) (setq tag (semantic-current-tag)))
257 (semantic-fetch-tags)
258 (if tag (message (semantic-format-tag-summarize tag))))
261 ;;; Putting keys on tags.
263 (defun semantic-add-label (label value &optional tag)
264 "Add a LABEL with VALUE on TAG.
265 If TAG is not specified, use the tag at point."
266 (interactive "sLabel: \nXValue (eval): ")
269 (semantic-fetch-tags)
270 (setq tag (semantic-current-tag))))
271 (semantic--tag-put-property tag (intern label) value)
272 (message "Added label %s with value %S" label value))
274 (defun semantic-show-label (label &optional tag)
275 "Show the value of LABEL on TAG.
276 If TAG is not specified, use the tag at point."
277 (interactive "sLabel: ")
280 (semantic-fetch-tags)
281 (setq tag (semantic-current-tag))))
282 (message "%s: %S" label (semantic--tag-get-property tag (intern label))))
287 ;; Some hacks to help me test these functions
288 (defun semantic-describe-buffer-var-helper (varsym buffer)
289 "Display to standard out the value of VARSYM in BUFFER."
290 (require 'data-debug)
291 (let ((value (save-excursion
293 (symbol-value varsym))))
296 (< (length value) 10))
297 ;; Draw the list of things in the list.
298 (princ (format " %s: #<list of %d items>\n"
299 varsym (length value)))
300 (data-debug-insert-stuff-list
304 ;; Else do a one-liner.
305 (data-debug-insert-thing
306 value " " (concat " " (symbol-name varsym) ": "))
309 (defun semantic-describe-buffer ()
310 "Describe the semantic environment for the current buffer."
312 (let ((buff (current-buffer))
315 (with-output-to-temp-buffer (help-buffer)
316 (help-setup-xref (list #'semantic-describe-buffer) (interactive-p))
317 (with-current-buffer standard-output
318 (princ "Semantic Configuration in ")
319 (princ (buffer-name buff))
322 (princ "Buffer specific configuration items:\n")
323 (let ((vars '(major-mode
325 semantic-expand-nonterminal
327 semantic-parse-tree-state
328 semantic-lex-analyzer
329 semantic-lex-reset-hooks
332 (semantic-describe-buffer-var-helper V buff)))
334 (princ "\nGeneral configuration items:\n")
335 (let ((vars '(semantic-inhibit-functions
337 semantic-init-db-hooks
338 semantic-unmatched-syntax-hook
339 semantic--before-fetch-tags-hook
340 semantic-after-toplevel-bovinate-hook
341 semantic-after-toplevel-cache-change-hook
342 semantic-before-toplevel-cache-flush-hook
347 (semantic-describe-buffer-var-helper V buff)))
350 (mode-local-describe-bindings-2 buff)
354 (defun semantic-current-tag-interactive (p)
355 "Display the current token.
356 Argument P is the point to search from in the current buffer."
358 (require 'semantic/find)
359 (let ((tok (semantic-brute-find-innermost-tag-by-position
360 p (current-buffer))))
361 (message (mapconcat 'semantic-abbreviate-nonterminal tok ","))
365 (defun semantic-hack-search ()
366 "Display info about something under the cursor using generic methods."
368 (require 'semantic/find)
370 ;(name (thing-at-point 'symbol))
371 (strm (cdr (semantic-fetch-tags)))
375 ; (semantic-find-nonterminal-by-name name strm)
376 ; (semantic-find-nonterminal-by-type name strm)
377 ; (semantic-recursive-find-nonterminal-by-name name (current-buffer))
378 (semantic-brute-find-tag-by-position (point) strm)
384 (pop-to-buffer "*SEMANTIC HACK RESULTS*")
387 (insert (pp-to-string res) "\n")
388 (goto-char (point-min))
389 (shrink-window-if-larger-than-buffer))
392 (defun semantic-assert-valid-token (tok)
393 "Assert that TOK is a valid token."
394 (if (semantic-tag-p tok)
395 (if (semantic-tag-with-position-p tok)
396 (let ((o (semantic-tag-overlay tok)))
397 (if (and (semantic-overlay-p o)
398 (not (semantic-overlay-live-p o)))
399 (let ((debug-on-error t))
400 (error "Tag %s is invalid!" (semantic-tag-name tok)))
403 ;; Positionless tags are also ok.
405 (let ((debug-on-error t))
406 (error "Not a semantic tag: %S" tok))))
408 (defun semantic-sanity-check (&optional cache over notfirst)
409 "Perform a sanity check on the current buffer.
410 The buffer's set of overlays, and those overlays found via the cache
411 are verified against each other.
412 CACHE, and OVER are the semantic cache, and the overlay list.
413 NOTFIRST indicates that this was not the first call in the recursive use."
415 (if (and (not cache) (not over) (not notfirst))
416 (setq cache semantic--buffer-cache
417 over (semantic-overlays-in (point-min) (point-max))))
419 (let ((chil (semantic-tag-components-with-overlays (car cache))))
420 (if (not (memq (semantic-tag-overlay (car cache)) over))
421 (message "Tag %s not in buffer overlay list."
422 (semantic-format-tag-concise-prototype (car cache))))
423 (setq over (delq (semantic-tag-overlay (car cache)) over))
424 (setq over (semantic-sanity-check chil over t))
425 (setq cache (cdr cache))))
427 ;; Strip out all overlays which aren't semantic overlays
430 (when (and (semantic-overlay-get (car over) 'semantic)
431 (not (eq (semantic-overlay-get (car over) 'semantic)
433 (setq o (cons (car over) o)))
434 (setq over (cdr over)))
435 (message "Remaining overlays: %S" o)))
438 (provide 'semantic/util)
442 (require 'semantic/util-modes)
444 ;;; semantic/util.el ends here