1 ;;; semantic/util.el --- Utilities for use with semantic tag tables
3 ;;; Copyright (C) 1999-2005, 2007-2018 Free Software Foundation, Inc.
5 ;; Author: Eric M. Ludlam <zappo@gnu.org>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
25 ;; Semantic utility API for use with semantic tag tables.
31 (require 'semantic
/db-find
)
32 ;; For semantic-find-tags-by-class, semantic--find-tags-by-function,
33 ;; and semantic-brute-find-tag-standard:
34 (require 'semantic
/find
))
36 (declare-function data-debug-insert-stuff-list
"data-debug")
37 (declare-function data-debug-insert-thing
"data-debug")
38 (declare-function semantic-ctxt-current-symbol-and-bounds
"semantic/ctxt")
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
)
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
)
57 (declare-function semanticdb-file-stream
"semantic/db" (file))
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
70 (if (find-buffer-visiting file
)
71 (with-current-buffer (find-buffer-visiting file
)
72 (semantic-fetch-tags))
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 (with-current-buffer (find-file-noselect file
)
80 (semantic-fetch-tags))))))
82 (semantic-alias-obsolete 'semantic-file-token-stream
83 'semantic-file-tag-table
"23.2")
85 (declare-function semanticdb-abstract-table-child-p
"semantic/db" (obj) t
)
86 (declare-function semanticdb-refresh-table
"semantic/db")
87 (declare-function semanticdb-get-tags
"semantic/db" (arg &rest args
) t
)
88 (declare-function semanticdb-find-results-p
"semantic/db-find" (resultp))
90 (defun semantic-something-to-tag-table (something)
91 "Convert SOMETHING into a semantic tag table.
92 Something can be a tag with a valid BUFFER property, a tag table, a
93 buffer, or a filename. If SOMETHING is nil return nil."
96 ((and (listp something
)
97 (semantic-tag-p (car something
)))
101 (with-current-buffer something
102 (semantic-fetch-tags)))
103 ;; A Tag: Get that tag's buffer
104 ((and (semantic-tag-with-position-p something
)
105 (semantic-tag-in-buffer-p something
))
106 (with-current-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 (require 'semantic
/db-mode
)
121 (semanticdb-minor-mode-p)
122 (semanticdb-abstract-table-child-p something
))
123 (semanticdb-refresh-table something
)
124 (semanticdb-get-tags something
))
125 ;; Semanticdb find-results
126 ((and (featurep 'semantic
/db
)
127 (require 'semantic
/db-mode
)
128 (semanticdb-minor-mode-p)
129 (require 'semantic
/db-find
)
130 (semanticdb-find-results-p something
))
131 (semanticdb-strip-find-results something
))
132 ;; NOTE: This commented out since if a search result returns
133 ;; empty, that empty would turn into everything on the next search.
134 ;; Use the current buffer for nil
136 ;; (semantic-fetch-tags))
137 ;; don't know what it is
140 (semantic-alias-obsolete 'semantic-something-to-stream
141 'semantic-something-to-tag-table
"23.2")
145 ;; These functions provide minibuffer reading/completion for lists of
147 (defvar semantic-read-symbol-history nil
148 "History for a symbol read.")
150 (declare-function semantic-brute-find-tag-by-function
152 (function streamorbuffer
153 &optional search-parts search-includes
))
155 (defun semantic-read-symbol (prompt &optional default stream filter
)
156 "Read a symbol name from the user for the current buffer.
157 PROMPT is the prompt to use.
159 DEFAULT is the default choice. If no default is given, one is read
161 STREAM is the list of tokens to complete from.
162 FILTER is provides a filter on the types of things to complete.
163 FILTER must be a function to call on each element."
164 (if (not default
) (setq default
(thing-at-point 'symbol
)))
165 (if (not stream
) (setq stream
(semantic-fetch-tags)))
168 (semantic--find-tags-by-function filter stream
)
169 (require 'semantic
/find
)
170 (semantic-brute-find-tag-standard stream
)))
171 (if (and default
(string-match ":" prompt
))
173 (concat (substring prompt
0 (match-end 0))
174 " (default: " default
") ")))
175 (completing-read prompt stream nil t
""
176 'semantic-read-symbol-history
179 (defun semantic-read-variable (prompt &optional default stream
)
180 "Read a variable name from the user for the current buffer.
181 PROMPT is the prompt to use.
183 DEFAULT is the default choice. If no default is given, one is read
185 STREAM is the list of tokens to complete from."
186 (semantic-read-symbol
188 (or (semantic-find-tags-by-class
189 'variable
(or stream
(current-buffer)))
190 (error "No local variables"))))
192 (defun semantic-read-function (prompt &optional default stream
)
193 "Read a function name from the user for the current buffer.
194 PROMPT is the prompt to use.
196 DEFAULT is the default choice. If no default is given, one is read
198 STREAM is the list of tags to complete from."
199 (semantic-read-symbol
201 (or (semantic-find-tags-by-class
202 'function
(or stream
(current-buffer)))
203 (error "No local functions"))))
205 (defun semantic-read-type (prompt &optional default stream
)
206 "Read a type name from the user for the current buffer.
207 PROMPT is the prompt to use.
209 DEFAULT is the default choice. If no default is given, one is read
211 STREAM is the list of tags to complete from."
212 (semantic-read-symbol
214 (or (semantic-find-tags-by-class
215 'type
(or stream
(current-buffer)))
216 (error "No local types"))))
219 ;;; Interactive Functions for
221 (defun semantic-describe-tag (&optional tag
)
222 "Describe TAG in the minibuffer.
223 If TAG is nil, describe the tag under the cursor."
225 (if (not tag
) (setq tag
(semantic-current-tag)))
226 (semantic-fetch-tags)
227 (if tag
(message (semantic-format-tag-summarize tag
))))
230 ;;; Putting keys on tags.
232 (defun semantic-add-label (label value
&optional tag
)
233 "Add a LABEL with VALUE on TAG.
234 If TAG is not specified, use the tag at point."
235 (interactive "sLabel: \nXValue (eval): ")
238 (semantic-fetch-tags)
239 (setq tag
(semantic-current-tag))))
240 (semantic--tag-put-property tag
(intern label
) value
)
241 (message "Added label %s with value %S" label value
))
243 (defun semantic-show-label (label &optional tag
)
244 "Show the value of LABEL on TAG.
245 If TAG is not specified, use the tag at point."
246 (interactive "sLabel: ")
249 (semantic-fetch-tags)
250 (setq tag
(semantic-current-tag))))
251 (message "%s: %S" label
(semantic--tag-get-property tag
(intern label
))))
256 ;; Some hacks to help me test these functions
257 (defun semantic-describe-buffer-var-helper (varsym buffer
)
258 "Display to standard out the value of VARSYM in BUFFER."
259 (require 'data-debug
)
260 (let ((value (with-current-buffer buffer
261 (symbol-value varsym
))))
264 (< (length value
) 10))
265 ;; Draw the list of things in the list.
266 (princ (format " %s: #<list of %d items>\n"
267 varsym
(length value
)))
268 (data-debug-insert-stuff-list
272 ;; Else do a one-liner.
273 (data-debug-insert-thing
274 value
" " (concat " " (symbol-name varsym
) ": "))
277 (defun semantic-describe-buffer ()
278 "Describe the semantic environment for the current buffer."
280 (let ((buff (current-buffer))
283 (with-output-to-temp-buffer (help-buffer)
284 (help-setup-xref (list #'semantic-describe-buffer
)
285 (called-interactively-p 'interactive
))
286 (with-current-buffer standard-output
287 (princ "Semantic Configuration in ")
288 (princ (buffer-name buff
))
291 (princ "Buffer specific configuration items:\n")
292 (let ((vars '(major-mode
294 semantic-tag-expand-function
296 semantic-parse-tree-state
297 semantic-lex-analyzer
298 semantic-lex-reset-functions
299 semantic-lex-syntax-modifications
302 (semantic-describe-buffer-var-helper V buff
)))
304 (princ "\nGeneral configuration items:\n")
305 (let ((vars '(semantic-inhibit-functions
307 semantic-init-db-hook
308 semantic-unmatched-syntax-hook
309 semantic--before-fetch-tags-hook
310 semantic-after-toplevel-bovinate-hook
311 semantic-after-toplevel-cache-change-hook
312 semantic-before-toplevel-cache-flush-hook
314 semantic-type-relation-separator-character
315 semantic-command-separation-character
316 semantic-new-buffer-fcn-was-run
319 (semantic-describe-buffer-var-helper V buff
)))
322 (mode-local-describe-bindings-2 buff
)
326 (defun semantic-assert-valid-token (tok)
327 "Assert that TOK is a valid token."
328 (if (semantic-tag-p tok
)
329 (if (semantic-tag-with-position-p tok
)
330 (let ((o (semantic-tag-overlay tok
)))
331 (if (and (semantic-overlay-p o
)
332 (not (semantic-overlay-live-p o
)))
333 (let ((debug-on-error t
))
334 (error "Tag %s is invalid!" (semantic-tag-name tok
)))
337 ;; Positionless tags are also ok.
339 (let ((debug-on-error t
))
340 (error "Not a semantic tag: %S" tok
))))
342 (defun semantic-sanity-check (&optional cache over notfirst
)
343 "Perform a sanity check on the current buffer.
344 The buffer's set of overlays, and those overlays found via the cache
345 are verified against each other.
346 CACHE, and OVER are the semantic cache, and the overlay list.
347 NOTFIRST indicates that this was not the first call in the recursive use."
349 (if (and (not cache
) (not over
) (not notfirst
))
350 (setq cache semantic--buffer-cache
351 over
(semantic-overlays-in (point-min) (point-max))))
353 (let ((chil (semantic-tag-components-with-overlays (car cache
))))
354 (if (not (memq (semantic-tag-overlay (car cache
)) over
))
355 (message "Tag %s not in buffer overlay list."
356 (semantic-format-tag-concise-prototype (car cache
))))
357 (setq over
(delq (semantic-tag-overlay (car cache
)) over
))
358 (setq over
(semantic-sanity-check chil over t
))
359 (setq cache
(cdr cache
))))
361 ;; Strip out all overlays which aren't semantic overlays
364 (when (and (semantic-overlay-get (car over
) 'semantic
)
365 (not (eq (semantic-overlay-get (car over
) 'semantic
)
367 (setq o
(cons (car over
) o
)))
368 (setq over
(cdr over
)))
369 (when (called-interactively-p 'any
)
370 (message "Remaining overlays: %S" o
))))
373 ;;; Interactive commands (from Senator).
375 ;; The Senator library from upstream CEDET is not included in the
376 ;; built-in version of Emacs. The plan is to fold it into the
377 ;; different parts of CEDET and Emacs, so that it works
378 ;; "transparently". Here are some interactive commands based on
383 (declare-function semanticdb-fast-strip-find-results
384 "semantic/db-find" (results))
385 (declare-function semanticdb-deep-find-tags-for-completion
386 "semantic/db-find" (prefix &optional path find-file-match
))
388 (defun semantic-find-tag-for-completion (prefix)
389 "Find all tags with name starting with PREFIX.
390 This uses `semanticdb' when available."
392 ;; Try the Semantic analyzer
394 (and (featurep 'semantic
/analyze
)
395 (setq ctxt
(semantic-analyze-current-context))
396 (setq result
(semantic-analyze-possible-completions ctxt
)))
399 ;; If the analyzer fails, then go into boring completion.
400 (if (and (featurep 'semantic
/db
)
401 (semanticdb-minor-mode-p)
402 (require 'semantic
/db-find
))
403 (semanticdb-fast-strip-find-results
404 (semanticdb-deep-find-tags-for-completion prefix
))
405 (semantic-deep-find-tags-for-completion prefix
(current-buffer))))))
407 (defun semantic-complete-symbol (&optional predicate
)
408 "Complete the symbol under point, using Semantic facilities.
409 When called from a program, optional arg PREDICATE is a predicate
410 determining which symbols are considered."
412 (require 'semantic
/ctxt
)
413 (let* ((start (car (nth 2 (semantic-ctxt-current-symbol-and-bounds
415 (pattern (regexp-quote (buffer-substring start
(point))))
416 collection completion
)
418 (if (and semantic--completion-cache
419 (eq (nth 0 semantic--completion-cache
) (current-buffer))
420 (= (nth 1 semantic--completion-cache
) start
)
423 (looking-at (nth 3 semantic--completion-cache
))))
425 (setq collection
(nthcdr 4 semantic--completion-cache
))
426 ;; Perform new query.
427 (setq collection
(semantic-find-tag-for-completion pattern
))
428 (setq semantic--completion-cache
429 (append (list (current-buffer) start
0 pattern
)
431 (if (null collection
)
432 (let ((str (if pattern
(format " for \"%s\"" pattern
) "")))
433 (if (window-minibuffer-p (selected-window))
434 (minibuffer-message (format " [No completions%s]" str
))
435 (message "Can't find completion%s" str
)))
436 (setq completion
(try-completion pattern collection predicate
))
437 (if (string= pattern completion
)
438 (let ((list (all-completions pattern collection predicate
)))
439 (setq list
(sort list
'string
<))
440 (if (> (length list
) 1)
441 (with-output-to-temp-buffer "*Completions*"
442 (display-completion-list
443 (completion-hilit-commonality list
(length pattern
) nil
)))
444 ;; Bury any out-of-date completions buffer.
445 (let ((win (get-buffer-window "*Completions*" 0)))
446 (if win
(with-selected-window win
(bury-buffer))))))
448 (delete-region start
(point))
450 ;; Bury any out-of-date completions buffer.
451 (let ((win (get-buffer-window "*Completions*" 0)))
452 (if win
(with-selected-window win
(bury-buffer))))))))
454 (provide 'semantic
/util
)
458 (require 'semantic
/util-modes
)
460 ;;; semantic/util.el ends here