Commit | Line | Data |
---|---|---|
55b522b2 | 1 | ;;; semantic/util.el --- Utilities for use with semantic tag tables |
a91e32bc CY |
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 'assoc) | |
30 | (require 'semantic) | |
31 | (eval-when-compile | |
32 | ;; Emacs 21 | |
33 | (condition-case nil | |
34 | (require 'newcomment) | |
35 | (error nil)) | |
36 | ;; Semanticdb calls | |
37 | (require 'semantic/db) | |
38 | ) | |
39 | ||
40 | ;;; Code: | |
41 | ||
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) | |
50 | ||
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) | |
56 | ||
57 | ;; These semanticdb calls will throw warnings in the byte compiler. | |
58 | ;; Doing the right thing to make them available at compile time | |
59 | ;; really messes up the compilation sequence. | |
60 | (defun semantic-file-tag-table (file) | |
61 | "Return a tag table for FILE. | |
62 | If it is loaded, return the stream after making sure it's ok. | |
63 | If FILE is not loaded, check to see if `semanticdb' feature exists, | |
64 | and use it to get tags from files not in memory. | |
65 | If FILE is not loaded, and semanticdb is not available, find the file | |
66 | and parse it." | |
67 | (if (find-buffer-visiting file) | |
68 | (save-excursion | |
69 | (set-buffer (find-buffer-visiting file)) | |
70 | (semantic-fetch-tags)) | |
71 | ;; File not loaded | |
72 | (if (and (fboundp 'semanticdb-minor-mode-p) | |
73 | (semanticdb-minor-mode-p)) | |
74 | ;; semanticdb is around, use it. | |
75 | (semanticdb-file-stream file) | |
76 | ;; Get the stream ourselves. | |
77 | (save-excursion | |
78 | (set-buffer (find-file-noselect file)) | |
79 | (semantic-fetch-tags))))) | |
80 | ||
81 | (semantic-alias-obsolete 'semantic-file-token-stream | |
82 | 'semantic-file-tag-table) | |
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 | (save-excursion | |
96 | (set-buffer something) | |
97 | (semantic-fetch-tags))) | |
98 | ;; A Tag: Get that tag's buffer | |
99 | ((and (semantic-tag-with-position-p something) | |
100 | (semantic-tag-in-buffer-p something)) | |
101 | (save-excursion | |
102 | (set-buffer (semantic-tag-buffer something)) | |
103 | (semantic-fetch-tags))) | |
104 | ;; Tag with a file name in it | |
105 | ((and (semantic-tag-p something) | |
106 | (semantic-tag-file-name something) | |
107 | (file-exists-p (semantic-tag-file-name something))) | |
108 | (semantic-file-tag-table | |
109 | (semantic-tag-file-name something))) | |
110 | ;; A file name | |
111 | ((and (stringp something) | |
112 | (file-exists-p something)) | |
113 | (semantic-file-tag-table something)) | |
114 | ;; A Semanticdb table | |
115 | ((and (featurep 'semanticdb) | |
116 | (semanticdb-minor-mode-p) | |
117 | (semanticdb-abstract-table-child-p something)) | |
118 | (semanticdb-refresh-table something) | |
119 | (semanticdb-get-tags something)) | |
120 | ;; Semanticdb find-results | |
121 | ((and (featurep 'semanticdb) | |
122 | (semanticdb-minor-mode-p) | |
123 | (semanticdb-find-results-p something)) | |
124 | (semanticdb-strip-find-results something)) | |
125 | ;; NOTE: This commented out since if a search result returns | |
126 | ;; empty, that empty would turn into everything on the next search. | |
127 | ;; Use the current buffer for nil | |
128 | ;; ((null something) | |
129 | ;; (semantic-fetch-tags)) | |
130 | ;; don't know what it is | |
131 | (t nil))) | |
132 | ||
133 | (semantic-alias-obsolete 'semantic-something-to-stream | |
134 | 'semantic-something-to-tag-table) | |
135 | ||
136 | ;;; Recursive searching through dependency trees | |
137 | ;; | |
138 | ;; This will depend on the general searching APIS defined above. | |
139 | ;; but will add full recursion through the dependencies list per | |
140 | ;; stream. | |
141 | (defun semantic-recursive-find-nonterminal-by-name (name buffer) | |
142 | "Recursively find the first occurrence of NAME. | |
143 | Start search with BUFFER. Recurse through all dependencies till found. | |
144 | The return item is of the form (BUFFER TOKEN) where BUFFER is the buffer | |
145 | in which TOKEN (the token found to match NAME) was found. | |
146 | ||
147 | THIS ISN'T USED IN SEMANTIC. DELETE ME SOON." | |
148 | (save-excursion | |
149 | (set-buffer buffer) | |
150 | (let* ((stream (semantic-fetch-tags)) | |
151 | (includelist (or (semantic-find-tags-by-class 'include stream) | |
152 | "empty.silly.thing")) | |
153 | (found (semantic-find-first-tag-by-name name stream)) | |
154 | (unfound nil)) | |
155 | (while (and (not found) includelist) | |
156 | (let ((fn (semantic-dependency-tag-file (car includelist)))) | |
157 | (if (and fn (not (member fn unfound))) | |
158 | (save-excursion | |
159 | (set-buffer (find-file-noselect fn)) | |
160 | (message "Scanning %s" (buffer-file-name)) | |
161 | (setq stream (semantic-fetch-tags)) | |
162 | (setq found (semantic-find-first-tag-by-name name stream)) | |
163 | (if found | |
164 | (setq found (cons (current-buffer) (list found))) | |
165 | (setq includelist | |
166 | (append includelist | |
167 | (semantic-find-tags-by-class | |
168 | 'include stream)))) | |
169 | (setq unfound (cons fn unfound))))) | |
170 | (setq includelist (cdr includelist))) | |
171 | found))) | |
172 | (make-obsolete 'semantic-recursive-find-nonterminal-by-name | |
173 | "Do not use this function.") | |
174 | ||
175 | ;;; Completion APIs | |
176 | ;; | |
177 | ;; These functions provide minibuffer reading/completion for lists of | |
178 | ;; nonterminals. | |
179 | (defvar semantic-read-symbol-history nil | |
180 | "History for a symbol read.") | |
181 | ||
182 | (defun semantic-read-symbol (prompt &optional default stream filter) | |
183 | "Read a symbol name from the user for the current buffer. | |
184 | PROMPT is the prompt to use. | |
185 | Optional arguments: | |
186 | DEFAULT is the default choice. If no default is given, one is read | |
187 | from under point. | |
188 | STREAM is the list of tokens to complete from. | |
189 | FILTER is provides a filter on the types of things to complete. | |
190 | FILTER must be a function to call on each element." | |
191 | (if (not default) (setq default (thing-at-point 'symbol))) | |
192 | (if (not stream) (setq stream (semantic-fetch-tags))) | |
193 | (setq stream | |
194 | (if filter | |
195 | (semantic--find-tags-by-function filter stream) | |
196 | (semantic-brute-find-tag-standard stream))) | |
197 | (if (and default (string-match ":" prompt)) | |
198 | (setq prompt | |
199 | (concat (substring prompt 0 (match-end 0)) | |
200 | " (default: " default ") "))) | |
201 | (completing-read prompt stream nil t "" | |
202 | 'semantic-read-symbol-history | |
203 | default)) | |
204 | ||
205 | (defun semantic-read-variable (prompt &optional default stream) | |
206 | "Read a variable name from the user for the current buffer. | |
207 | PROMPT is the prompt to use. | |
208 | Optional arguments: | |
209 | DEFAULT is the default choice. If no default is given, one is read | |
210 | from under point. | |
211 | STREAM is the list of tokens to complete from." | |
212 | (semantic-read-symbol | |
213 | prompt default | |
214 | (or (semantic-find-tags-by-class | |
215 | 'variable (or stream (current-buffer))) | |
216 | (error "No local variables")))) | |
217 | ||
218 | (defun semantic-read-function (prompt &optional default stream) | |
219 | "Read a function name from the user for the current buffer. | |
220 | PROMPT is the prompt to use. | |
221 | Optional arguments: | |
222 | DEFAULT is the default choice. If no default is given, one is read | |
223 | from under point. | |
224 | STREAM is the list of tags to complete from." | |
225 | (semantic-read-symbol | |
226 | prompt default | |
227 | (or (semantic-find-tags-by-class | |
228 | 'function (or stream (current-buffer))) | |
229 | (error "No local functions")))) | |
230 | ||
231 | (defun semantic-read-type (prompt &optional default stream) | |
232 | "Read a type name from the user for the current buffer. | |
233 | PROMPT is the prompt to use. | |
234 | Optional arguments: | |
235 | DEFAULT is the default choice. If no default is given, one is read | |
236 | from under point. | |
237 | STREAM is the list of tags to complete from." | |
238 | (semantic-read-symbol | |
239 | prompt default | |
240 | (or (semantic-find-tags-by-class | |
241 | 'type (or stream (current-buffer))) | |
242 | (error "No local types")))) | |
243 | ||
244 | \f | |
245 | ;;; Interactive Functions for | |
246 | ;; | |
247 | (defun semantic-describe-tag (&optional tag) | |
248 | "Describe TAG in the minibuffer. | |
249 | If TAG is nil, describe the tag under the cursor." | |
250 | (interactive) | |
251 | (if (not tag) (setq tag (semantic-current-tag))) | |
252 | (semantic-fetch-tags) | |
253 | (if tag (message (semantic-format-tag-summarize tag)))) | |
254 | ||
255 | \f | |
256 | ;;; Putting keys on tags. | |
257 | ;; | |
258 | (defun semantic-add-label (label value &optional tag) | |
259 | "Add a LABEL with VALUE on TAG. | |
260 | If TAG is not specified, use the tag at point." | |
261 | (interactive "sLabel: \nXValue (eval): ") | |
262 | (if (not tag) | |
263 | (progn | |
264 | (semantic-fetch-tags) | |
265 | (setq tag (semantic-current-tag)))) | |
266 | (semantic--tag-put-property tag (intern label) value) | |
267 | (message "Added label %s with value %S" label value)) | |
268 | ||
269 | (defun semantic-show-label (label &optional tag) | |
270 | "Show the value of LABEL on TAG. | |
271 | If TAG is not specified, use the tag at point." | |
272 | (interactive "sLabel: ") | |
273 | (if (not tag) | |
274 | (progn | |
275 | (semantic-fetch-tags) | |
276 | (setq tag (semantic-current-tag)))) | |
277 | (message "%s: %S" label (semantic--tag-get-property tag (intern label)))) | |
278 | ||
279 | \f | |
280 | ;;; Hacks | |
281 | ;; | |
282 | ;; Some hacks to help me test these functions | |
283 | (defun semantic-describe-buffer-var-helper (varsym buffer) | |
284 | "Display to standard out the value of VARSYM in BUFFER." | |
285 | (require 'data-debug) | |
286 | (let ((value (save-excursion | |
287 | (set-buffer buffer) | |
288 | (symbol-value varsym)))) | |
289 | (cond | |
290 | ((and (consp value) | |
291 | (< (length value) 10)) | |
292 | ;; Draw the list of things in the list. | |
293 | (princ (format " %s: #<list of %d items>\n" | |
294 | varsym (length value))) | |
295 | (data-debug-insert-stuff-list | |
296 | value " " ) | |
297 | ) | |
298 | (t | |
299 | ;; Else do a one-liner. | |
300 | (data-debug-insert-thing | |
301 | value " " (concat " " (symbol-name varsym) ": ")) | |
302 | )))) | |
303 | ||
304 | (defun semantic-describe-buffer () | |
305 | "Describe the semantic environment for the current buffer." | |
306 | (interactive) | |
307 | (let ((buff (current-buffer)) | |
308 | ) | |
309 | ||
310 | (with-output-to-temp-buffer (help-buffer) | |
311 | (help-setup-xref (list #'semantic-describe-buffer) (interactive-p)) | |
312 | (with-current-buffer standard-output | |
313 | (princ "Semantic Configuration in ") | |
314 | (princ (buffer-name buff)) | |
315 | (princ "\n\n") | |
316 | ||
317 | (princ "Buffer specific configuration items:\n") | |
318 | (let ((vars '(major-mode | |
319 | semantic-case-fold | |
320 | semantic-expand-nonterminal | |
321 | semantic-parser-name | |
322 | semantic-parse-tree-state | |
323 | semantic-lex-analyzer | |
324 | semantic-lex-reset-hooks | |
325 | ))) | |
326 | (dolist (V vars) | |
327 | (semantic-describe-buffer-var-helper V buff))) | |
328 | ||
329 | (princ "\nGeneral configuration items:\n") | |
330 | (let ((vars '(semantic-inhibit-functions | |
331 | semantic-init-hooks | |
332 | semantic-init-db-hooks | |
333 | semantic-unmatched-syntax-hook | |
334 | semantic--before-fetch-tags-hook | |
335 | semantic-after-toplevel-bovinate-hook | |
336 | semantic-after-toplevel-cache-change-hook | |
337 | semantic-before-toplevel-cache-flush-hook | |
338 | semantic-dump-parse | |
339 | ||
340 | ))) | |
341 | (dolist (V vars) | |
342 | (semantic-describe-buffer-var-helper V buff))) | |
343 | ||
344 | (princ "\n\n") | |
345 | (mode-local-describe-bindings-2 buff) | |
346 | ))) | |
347 | ) | |
348 | ||
349 | (defun semantic-current-tag-interactive (p) | |
350 | "Display the current token. | |
351 | Argument P is the point to search from in the current buffer." | |
352 | (interactive "d") | |
353 | (let ((tok (semantic-brute-find-innermost-tag-by-position | |
354 | p (current-buffer)))) | |
355 | (message (mapconcat 'semantic-abbreviate-nonterminal tok ",")) | |
356 | (car tok)) | |
357 | ) | |
358 | ||
359 | (defun semantic-hack-search () | |
360 | "Display info about something under the cursor using generic methods." | |
361 | (interactive) | |
362 | (let ( | |
363 | ;(name (thing-at-point 'symbol)) | |
364 | (strm (cdr (semantic-fetch-tags))) | |
365 | (res nil)) | |
366 | ; (if name | |
367 | (setq res | |
368 | ; (semantic-find-nonterminal-by-name name strm) | |
369 | ; (semantic-find-nonterminal-by-type name strm) | |
370 | ; (semantic-recursive-find-nonterminal-by-name name (current-buffer)) | |
371 | (semantic-brute-find-tag-by-position (point) strm) | |
372 | ||
373 | ) | |
374 | ; ) | |
375 | (if res | |
376 | (progn | |
377 | (pop-to-buffer "*SEMANTIC HACK RESULTS*") | |
378 | (require 'pp) | |
379 | (erase-buffer) | |
380 | (insert (pp-to-string res) "\n") | |
381 | (goto-char (point-min)) | |
382 | (shrink-window-if-larger-than-buffer)) | |
383 | (message "nil")))) | |
384 | ||
385 | (defun semantic-assert-valid-token (tok) | |
386 | "Assert that TOK is a valid token." | |
387 | (if (semantic-tag-p tok) | |
388 | (if (semantic-tag-with-position-p tok) | |
389 | (let ((o (semantic-tag-overlay tok))) | |
390 | (if (and (semantic-overlay-p o) | |
391 | (not (semantic-overlay-live-p o))) | |
392 | (let ((debug-on-error t)) | |
393 | (error "Tag %s is invalid!" (semantic-tag-name tok))) | |
394 | ;; else, tag is OK. | |
395 | )) | |
396 | ;; Positionless tags are also ok. | |
397 | ) | |
398 | (let ((debug-on-error t)) | |
399 | (error "Not a semantic tag: %S" tok)))) | |
400 | ||
401 | (defun semantic-sanity-check (&optional cache over notfirst) | |
402 | "Perform a sanity check on the current buffer. | |
403 | The buffer's set of overlays, and those overlays found via the cache | |
404 | are verified against each other. | |
405 | CACHE, and OVER are the semantic cache, and the overlay list. | |
406 | NOTFIRST indicates that this was not the first call in the recursive use." | |
407 | (interactive) | |
408 | (if (and (not cache) (not over) (not notfirst)) | |
409 | (setq cache semantic--buffer-cache | |
410 | over (semantic-overlays-in (point-min) (point-max)))) | |
411 | (while cache | |
412 | (let ((chil (semantic-tag-components-with-overlays (car cache)))) | |
413 | (if (not (memq (semantic-tag-overlay (car cache)) over)) | |
414 | (message "Tag %s not in buffer overlay list." | |
415 | (semantic-format-tag-concise-prototype (car cache)))) | |
416 | (setq over (delq (semantic-tag-overlay (car cache)) over)) | |
417 | (setq over (semantic-sanity-check chil over t)) | |
418 | (setq cache (cdr cache)))) | |
419 | (if (not notfirst) | |
420 | ;; Strip out all overlays which aren't semantic overlays | |
421 | (let ((o nil)) | |
422 | (while over | |
423 | (when (and (semantic-overlay-get (car over) 'semantic) | |
424 | (not (eq (semantic-overlay-get (car over) 'semantic) | |
425 | 'unmatched))) | |
426 | (setq o (cons (car over) o))) | |
427 | (setq over (cdr over))) | |
428 | (message "Remaining overlays: %S" o))) | |
429 | over) | |
430 | ||
431 | (provide 'semantic/util) | |
432 | ||
433 | ;;; Minor modes | |
434 | ;; | |
435 | (require 'semantic/util-modes) | |
436 | ||
55b522b2 | 437 | ;;; semantic/util.el ends here |