aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorChong Yidong2009-08-28 19:18:35 +0000
committerChong Yidong2009-08-28 19:18:35 +0000
commit1bd955357097f15170e159d24b4e20b3173b8335 (patch)
tree78dad743284d2f2daee6a139196e32bc98180d5f
parent994e5ceab00ab6f3127ca3b2f5eef1dda375e1de (diff)
downloademacs-1bd955357097f15170e159d24b4e20b3173b8335.tar.gz
emacs-1bd955357097f15170e159d24b4e20b3173b8335.zip
cedet/semantic/ctxt.el, cedet/semantic/db-find.el,
cedet/semantic/db-ref.el, cedet/semantic/find.el, cedet/semantic/format.el, cedet/semantic/sort.el: New files.
-rw-r--r--lisp/cedet/semantic/ctxt.el613
-rw-r--r--lisp/cedet/semantic/db-find.el1353
-rw-r--r--lisp/cedet/semantic/db-ref.el161
-rw-r--r--lisp/cedet/semantic/find.el795
-rw-r--r--lisp/cedet/semantic/format.el774
-rw-r--r--lisp/cedet/semantic/sort.el592
6 files changed, 4288 insertions, 0 deletions
diff --git a/lisp/cedet/semantic/ctxt.el b/lisp/cedet/semantic/ctxt.el
new file mode 100644
index 00000000000..270b9964031
--- /dev/null
+++ b/lisp/cedet/semantic/ctxt.el
@@ -0,0 +1,613 @@
1;;; ctxt.el --- Context calculations for Semantic tools.
2
3;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
4;;; 2007, 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, as a tool, provides a nice list of searchable tags.
27;; That information can provide some very accurate answers if the current
28;; context of a position is known.
29;;
30;; This library provides the hooks needed for a language to specify how
31;; the current context is calculated.
32;;
33(require 'semantic)
34(eval-when-compile (require 'semantic/db))
35
36;;; Code:
37(defvar semantic-command-separation-character
38 ";"
39 "String which indicates the end of a command.
40Used for identifying the end of a single command.")
41(make-variable-buffer-local 'semantic-command-separation-character)
42
43(defvar semantic-function-argument-separation-character
44 ","
45 "String which indicates the end of an argument.
46Used for identifying arguments to functions.")
47(make-variable-buffer-local 'semantic-function-argument-separation-character)
48
49;;; Local Contexts
50;;
51;; These context are nested blocks of code, such as code in an
52;; if clause
53(define-overloadable-function semantic-up-context (&optional point bounds-type)
54 "Move point up one context from POINT.
55Return non-nil if there are no more context levels.
56Overloaded functions using `up-context' take no parameters.
57BOUNDS-TYPE is a symbol representing a tag class to restrict
58movement to. If this is nil, 'function is used.
59This will find the smallest tag of that class (function, variable,
60type, etc) and make sure non-nil is returned if you cannot
61go up past the bounds of that tag."
62 (if point (goto-char point))
63 (let ((nar (semantic-current-tag-of-class (or bounds-type 'function))))
64 (if nar
65 (semantic-with-buffer-narrowed-to-tag nar (:override-with-args ()))
66 (when bounds-type
67 (error "No context of type %s to advance in" bounds-type))
68 (:override-with-args ()))))
69
70(defun semantic-up-context-default ()
71 "Move the point up and out one context level.
72Works with languages that use parenthetical grouping."
73 ;; By default, assume that the language uses some form of parenthetical
74 ;; do dads for their context.
75 (condition-case nil
76 (progn
77 (up-list -1)
78 nil)
79 (error t)))
80
81(define-overloadable-function semantic-beginning-of-context (&optional point)
82 "Move POINT to the beginning of the current context.
83Return non-nil if there is no upper context.
84The default behavior uses `semantic-up-context'.")
85
86(defun semantic-beginning-of-context-default (&optional point)
87 "Move POINT to the beginning of the current context via parenthisis.
88Return non-nil if there is no upper context."
89 (if point (goto-char point))
90 (if (semantic-up-context)
91 t
92 (forward-char 1)
93 nil))
94
95(define-overloadable-function semantic-end-of-context (&optional point)
96 "Move POINT to the end of the current context.
97Return non-nil if there is no upper context.
98Be default, this uses `semantic-up-context', and assumes parenthetical
99block delimiters.")
100
101(defun semantic-end-of-context-default (&optional point)
102 "Move POINT to the end of the current context via parenthisis.
103Return non-nil if there is no upper context."
104 (if point (goto-char point))
105 (let ((start (point)))
106 (if (semantic-up-context)
107 t
108 ;; Go over the list, and back over the end parenthisis.
109 (condition-case nil
110 (progn
111 (forward-sexp 1)
112 (forward-char -1))
113 (error
114 ;; If an error occurs, get the current tag from the cache,
115 ;; and just go to the end of that. Make sure we end up at least
116 ;; where start was so parse-region type calls work.
117 (if (semantic-current-tag)
118 (progn
119 (goto-char (semantic-tag-end (semantic-current-tag)))
120 (when (< (point) start)
121 (goto-char start)))
122 (goto-char start))
123 t)))
124 nil))
125
126(defun semantic-narrow-to-context ()
127 "Narrow the buffer to the extent of the current context."
128 (let (b e)
129 (save-excursion
130 (if (semantic-beginning-of-context)
131 nil
132 (setq b (point))))
133 (save-excursion
134 (if (semantic-end-of-context)
135 nil
136 (setq e (point))))
137 (if (and b e) (narrow-to-region b e))))
138
139(defmacro semantic-with-buffer-narrowed-to-context (&rest body)
140 "Execute BODY with the buffer narrowed to the current context."
141 `(save-restriction
142 (semantic-narrow-to-context)
143 ,@body))
144(put 'semantic-with-buffer-narrowed-to-context 'lisp-indent-function 0)
145(add-hook 'edebug-setup-hook
146 (lambda ()
147 (def-edebug-spec semantic-with-buffer-narrowed-to-context
148 (def-body))))
149
150;;; Local Variables
151;;
152;;
153(define-overloadable-function semantic-get-local-variables (&optional point)
154 "Get the local variables based on POINT's context.
155Local variables are returned in Semantic tag format.
156This can be overriden with `get-local-variables'."
157 ;; The working status is to let the parser work properly
158 (working-status-forms
159 (semantic-parser-working-message "Local")
160 "done"
161 (save-excursion
162 (if point (goto-char point))
163 (let* ((semantic-working-type nil)
164 ;; Disable parsing messages
165 (working-status-dynamic-type nil)
166 (case-fold-search semantic-case-fold))
167 (:override-with-args ())))))
168
169(defun semantic-get-local-variables-default ()
170 "Get local values from a specific context.
171Uses the bovinator with the special top-symbol `bovine-inner-scope'
172to collect tags, such as local variables or prototypes."
173 ;; This assumes a bovine parser. Make sure we don't do
174 ;; anything in that case.
175 (when (and semantic--parse-table (not (eq semantic--parse-table t))
176 (not (semantic-parse-tree-unparseable-p)))
177 (let ((vars (semantic-get-cache-data 'get-local-variables)))
178 (if vars
179 (progn
180 ;;(message "Found cached vars.")
181 vars)
182 (let ((vars2 nil)
183 ;; We want nothing to do with funny syntaxing while doing this.
184 (semantic-unmatched-syntax-hook nil)
185 (start (point))
186 (firstusefulstart nil)
187 )
188 (while (not (semantic-up-context (point) 'function))
189 (when (not vars)
190 (setq firstusefulstart (point)))
191 (save-excursion
192 (forward-char 1)
193 (setq vars
194 ;; Note to self: semantic-parse-region returns cooked
195 ;; but unlinked tags. File information is lost here
196 ;; and is added next.
197 (append (semantic-parse-region
198 (point)
199 (save-excursion (semantic-end-of-context) (point))
200 'bovine-inner-scope
201 nil
202 t)
203 vars))))
204 ;; Modify the tags in place.
205 (setq vars2 vars)
206 (while vars2
207 (semantic--tag-put-property (car vars2) :filename (buffer-file-name))
208 (setq vars2 (cdr vars2)))
209 ;; Hash our value into the first context that produced useful results.
210 (when (and vars firstusefulstart)
211 (let ((end (save-excursion
212 (goto-char firstusefulstart)
213 (save-excursion
214 (unless (semantic-end-of-context)
215 (point))))))
216 ;;(message "Caching values %d->%d." firstusefulstart end)
217 (semantic-cache-data-to-buffer
218 (current-buffer) firstusefulstart
219 (or end
220 ;; If the end-of-context fails,
221 ;; just use our cursor starting
222 ;; position.
223 start)
224 vars 'get-local-variables 'exit-cache-zone))
225 )
226 ;; Return our list.
227 vars)))))
228
229(define-overloadable-function semantic-get-local-arguments (&optional point)
230 "Get arguments (variables) from the current context at POINT.
231Parameters are available if the point is in a function or method.
232Return a list of tags unlinked from the originating buffer.
233Arguments are obtained by overriding `get-local-arguments', or by the
234default function `semantic-get-local-arguments-default'. This, must
235return a list of tags, or a list of strings that will be converted to
236tags."
237 (save-excursion
238 (if point (goto-char point))
239 (let* ((case-fold-search semantic-case-fold)
240 (args (:override-with-args ()))
241 arg tags)
242 ;; Convert unsafe arguments to the right thing.
243 (while args
244 (setq arg (car args)
245 args (cdr args)
246 tags (cons (cond
247 ((semantic-tag-p arg)
248 ;; Return a copy of tag without overlay.
249 ;; The overlay is preserved.
250 (semantic-tag-copy arg nil t))
251 ((stringp arg)
252 (semantic--tag-put-property
253 (semantic-tag-new-variable arg nil nil)
254 :filename (buffer-file-name)))
255 (t
256 (error "Unknown parameter element %S" arg)))
257 tags)))
258 (nreverse tags))))
259
260(defun semantic-get-local-arguments-default ()
261 "Get arguments (variables) from the current context.
262Parameters are available if the point is in a function or method."
263 (let ((tag (semantic-current-tag)))
264 (if (and tag (semantic-tag-of-class-p tag 'function))
265 (semantic-tag-function-arguments tag))))
266
267(define-overloadable-function semantic-get-all-local-variables (&optional point)
268 "Get all local variables for this context, and parent contexts.
269Local variables are returned in Semantic tag format.
270Be default, this gets local variables, and local arguments.
271Optional argument POINT is the location to start getting the variables from.")
272
273(defun semantic-get-all-local-variables-default (&optional point)
274 "Get all local variables for this context.
275Optional argument POINT is the location to start getting the variables from.
276That is a cons (LOCAL-ARGUMENTS . LOCAL-VARIABLES) where:
277
278- LOCAL-ARGUMENTS is collected by `semantic-get-local-arguments'.
279- LOCAL-VARIABLES is collected by `semantic-get-local-variables'."
280 (save-excursion
281 (if point (goto-char point))
282 (let ((case-fold-search semantic-case-fold))
283 (append (semantic-get-local-arguments)
284 (semantic-get-local-variables)))))
285
286;;; Local context parsing
287;;
288;; Context parsing assumes a series of language independent commonalities.
289;; These terms are used to describe those contexts:
290;;
291;; command - One command in the language.
292;; symbol - The symbol the cursor is on.
293;; This would include a series of type/field when applicable.
294;; assignment - The variable currently being assigned to
295;; function - The function call the cursor is on/in
296;; argument - The index to the argument the cursor is on.
297;;
298;;
299(define-overloadable-function semantic-end-of-command ()
300 "Move to the end of the current command.
301Be default, uses `semantic-command-separation-character'.")
302
303(defun semantic-end-of-command-default ()
304 "Move to the end of the current command.
305Depends on `semantic-command-separation-character' to find the
306beginning and end of a command."
307 (semantic-with-buffer-narrowed-to-context
308 (let ((case-fold-search semantic-case-fold))
309 (with-syntax-table semantic-lex-syntax-table
310
311 (if (re-search-forward (regexp-quote semantic-command-separation-character)
312 nil t)
313 (forward-char -1)
314 ;; If there wasn't a command after this, we are the last
315 ;; command, and we are incomplete.
316 (goto-char (point-max)))))))
317
318(define-overloadable-function semantic-beginning-of-command ()
319 "Move to the beginning of the current command.
320Be default, uses `semantic-command-separation-character'.")
321
322(defun semantic-beginning-of-command-default ()
323 "Move to the beginning of the current command.
324Depends on `semantic-command-separation-character' to find the
325beginning and end of a command."
326 (semantic-with-buffer-narrowed-to-context
327 (with-syntax-table semantic-lex-syntax-table
328 (let ((case-fold-search semantic-case-fold))
329 (skip-chars-backward semantic-command-separation-character)
330 (if (re-search-backward (regexp-quote semantic-command-separation-character)
331 nil t)
332 (goto-char (match-end 0))
333 ;; If there wasn't a command after this, we are the last
334 ;; command, and we are incomplete.
335 (goto-char (point-min)))
336 (skip-chars-forward " \t\n")
337 ))))
338
339
340(defsubst semantic-point-at-beginning-of-command ()
341 "Return the point at the beginning of the current command."
342 (save-excursion (semantic-beginning-of-command) (point)))
343
344(defsubst semantic-point-at-end-of-command ()
345 "Return the point at the beginning of the current command."
346 (save-excursion (semantic-end-of-command) (point)))
347
348(defsubst semantic-narrow-to-command ()
349 "Narrow the current buffer to the current command."
350 (narrow-to-region (semantic-point-at-beginning-of-command)
351 (semantic-point-at-end-of-command)))
352
353(defmacro semantic-with-buffer-narrowed-to-command (&rest body)
354 "Execute BODY with the buffer narrowed to the current command."
355 `(save-restriction
356 (semantic-narrow-to-command)
357 ,@body))
358(put 'semantic-with-buffer-narrowed-to-command 'lisp-indent-function 0)
359(add-hook 'edebug-setup-hook
360 (lambda ()
361 (def-edebug-spec semantic-with-buffer-narrowed-to-command
362 (def-body))))
363
364
365(define-overloadable-function semantic-ctxt-current-symbol (&optional point)
366 "Return the current symbol the cursor is on at POINT in a list.
367The symbol includes all logical parts of a complex reference.
368For example, in C the statement:
369 this.that().entry
370
371Would be object `this' calling method `that' which returns some structure
372whose field `entry' is being reference. In this case, this function
373would return the list:
374 ( \"this\" \"that\" \"entry\" )")
375
376(defun semantic-ctxt-current-symbol-default (&optional point)
377 "Return the current symbol the cursor is on at POINT in a list.
378This will include a list of type/field names when applicable.
379Depends on `semantic-type-relation-separator-character'."
380 (save-excursion
381 (if point (goto-char point))
382 (let* ((fieldsep1 (mapconcat (lambda (a) (regexp-quote a))
383 semantic-type-relation-separator-character
384 "\\|"))
385 ;; NOTE: The [ \n] expression below should used \\s-, but that
386 ;; doesn't work in C since \n means end-of-comment, and isn't
387 ;; really whitespace.
388 (fieldsep (concat "[ \t\n\r]*\\(" fieldsep1 "\\)[ \t\n\r]*\\(\\w\\|\\s_\\)"))
389 (case-fold-search semantic-case-fold)
390 (symlist nil)
391 end)
392 (with-syntax-table semantic-lex-syntax-table
393 (save-excursion
394 (cond ((looking-at "\\w\\|\\s_")
395 ;; In the middle of a symbol, move to the end.
396 (forward-sexp 1))
397 ((looking-at fieldsep1)
398 ;; We are in a find spot.. do nothing.
399 nil
400 )
401 ((save-excursion
402 (and (condition-case nil
403 (progn (forward-sexp -1)
404 (forward-sexp 1)
405 t)
406 (error nil))
407 (looking-at fieldsep1)))
408 (setq symlist (list ""))
409 (forward-sexp -1)
410 ;; Skip array expressions.
411 (while (looking-at "\\s(") (forward-sexp -1))
412 (forward-sexp 1))
413 )
414 ;; Set our end point.
415 (setq end (point))
416
417 ;; Now that we have gotten started, lets do the rest.
418 (condition-case nil
419 (while (save-excursion
420 (forward-char -1)
421 (looking-at "\\w\\|\\s_"))
422 ;; We have a symbol.. Do symbol things
423 (forward-sexp -1)
424 (setq symlist (cons (buffer-substring-no-properties (point) end)
425 symlist))
426 ;; Skip the next syntactic expression backwards, then go forwards.
427 (let ((cp (point)))
428 (forward-sexp -1)
429 (forward-sexp 1)
430 ;; If we end up at the same place we started, we are at the
431 ;; beginning of a buffer, or narrowed to a command and
432 ;; have to stop.
433 (if (<= cp (point)) (error nil)))
434 (if (looking-at fieldsep)
435 (progn
436 (forward-sexp -1)
437 ;; Skip array expressions.
438 (while (and (looking-at "\\s(") (not (bobp)))
439 (forward-sexp -1))
440 (forward-sexp 1)
441 (setq end (point)))
442 (error nil))
443 )
444 (error nil)))
445 symlist))))
446
447
448(define-overloadable-function semantic-ctxt-current-symbol-and-bounds (&optional point)
449 "Return the current symbol and bounds the cursor is on at POINT.
450The symbol should be the same as returned by `semantic-ctxt-current-symbol'.
451Return (PREFIX ENDSYM BOUNDS).")
452
453(defun semantic-ctxt-current-symbol-and-bounds-default (&optional point)
454 "Return the current symbol and bounds the cursor is on at POINT.
455Uses `semantic-ctxt-current-symbol' to calculate the symbol.
456Return (PREFIX ENDSYM BOUNDS)."
457 (save-excursion
458 (when point (goto-char (point)))
459 (let* ((prefix (semantic-ctxt-current-symbol))
460 (endsym (car (reverse prefix)))
461 ;; @todo - Can we get this data direct from ctxt-current-symbol?
462 (bounds (save-excursion
463 (cond ((string= endsym "")
464 (cons (point) (point))
465 )
466 ((and prefix (looking-at endsym))
467 (cons (point) (progn
468 (condition-case nil
469 (forward-sexp 1)
470 (error nil))
471 (point))))
472 (prefix
473 (condition-case nil
474 (cons (progn (forward-sexp -1) (point))
475 (progn (forward-sexp 1) (point)))
476 (error nil)))
477 (t nil))))
478 )
479 (list prefix endsym bounds))))
480
481(define-overloadable-function semantic-ctxt-current-assignment (&optional point)
482 "Return the current assignment near the cursor at POINT.
483Return a list as per `semantic-ctxt-current-symbol'.
484Return nil if there is nothing relevant.")
485
486(defun semantic-ctxt-current-assignment-default (&optional point)
487 "Return the current assignment near the cursor at POINT.
488By default, assume that \"=\" indicates an assignment."
489 (if point (goto-char point))
490 (let ((case-fold-search semantic-case-fold))
491 (with-syntax-table semantic-lex-syntax-table
492 (condition-case nil
493 (semantic-with-buffer-narrowed-to-command
494 (save-excursion
495 (skip-chars-forward " \t=")
496 (condition-case nil (forward-char 1) (error nil))
497 (re-search-backward "[^=]=\\([^=]\\|$\\)")
498 ;; We are at an equals sign. Go backwards a sexp, and
499 ;; we'll have the variable. Otherwise we threw an error
500 (forward-sexp -1)
501 (semantic-ctxt-current-symbol)))
502 (error nil)))))
503
504(define-overloadable-function semantic-ctxt-current-function (&optional point)
505 "Return the current function call the cursor is in at POINT.
506The function returned is the one accepting the arguments that
507the cursor is currently in. It will not return function symbol if the
508cursor is on the text representing that function.")
509
510(defun semantic-ctxt-current-function-default (&optional point)
511 "Return the current function call the cursor is in at POINT.
512The call will be identifed for C like langauges with the form
513 NAME ( args ... )"
514 (if point (goto-char point))
515 (let ((case-fold-search semantic-case-fold))
516 (with-syntax-table semantic-lex-syntax-table
517 (save-excursion
518 (semantic-up-context)
519 (when (looking-at "(")
520 (semantic-ctxt-current-symbol))))
521 ))
522
523(define-overloadable-function semantic-ctxt-current-argument (&optional point)
524 "Return the index of the argument position the cursor is on at POINT.")
525
526(defun semantic-ctxt-current-argument-default (&optional point)
527 "Return the index of the argument the cursor is on at POINT.
528Depends on `semantic-function-argument-separation-character'."
529 (if point (goto-char point))
530 (let ((case-fold-search semantic-case-fold))
531 (with-syntax-table semantic-lex-syntax-table
532 (when (semantic-ctxt-current-function)
533 (save-excursion
534 ;; Only get the current arg index if we are in function args.
535 (let ((p (point))
536 (idx 1))
537 (semantic-up-context)
538 (while (re-search-forward
539 (regexp-quote semantic-function-argument-separation-character)
540 p t)
541 (setq idx (1+ idx)))
542 idx))))))
543
544(defun semantic-ctxt-current-thing ()
545 "Calculate a thing identified by the current cursor position.
546Calls previously defined `semantic-ctxt-current-...' calls until something
547gets a match. See `semantic-ctxt-current-symbol',
548`semantic-ctxt-current-function', and `semantic-ctxt-current-assignment'
549for details on the return value."
550 (or (semantic-ctxt-current-symbol)
551 (semantic-ctxt-current-function)
552 (semantic-ctxt-current-assignment)))
553
554(define-overloadable-function semantic-ctxt-current-class-list (&optional point)
555 "Return a list of tag classes that are allowed at POINT.
556If POINT is nil, the current buffer location is used.
557For example, in Emacs Lisp, the symbol after a ( is most likely
558a function. In a makefile, symbols after a : are rules, and symbols
559after a $( are variables.")
560
561(defun semantic-ctxt-current-class-list-default (&optional point)
562 "Return a list of tag classes that are allowed at POINT.
563Assume a functional typed language. Uses very simple rules."
564 (save-excursion
565 (if point (goto-char point))
566
567 (let ((tag (semantic-current-tag)))
568 (if tag
569 (cond ((semantic-tag-of-class-p tag 'function)
570 '(function variable type))
571 ((or (semantic-tag-of-class-p tag 'type)
572 (semantic-tag-of-class-p tag 'variable))
573 '(type))
574 (t nil))
575 '(type)
576 ))))
577
578(define-overloadable-function semantic-ctxt-current-mode (&optional point)
579 "Return the major mode active at POINT.
580POINT defaults to the value of point in current buffer.
581You should override this function in multiple mode buffers to
582determine which major mode apply at point.")
583
584(defun semantic-ctxt-current-mode-default (&optional point)
585 "Return the major mode active at POINT.
586POINT defaults to the value of point in current buffer.
587This default implementation returns the current major mode."
588 major-mode)
589
590;;; Scoped Types
591;;
592;; Scoped types are types that the current code would have access to.
593;; The come from the global namespace or from special commands such as "using"
594(define-overloadable-function semantic-ctxt-scoped-types (&optional point)
595 "Return a list of type names currently in scope at POINT.
596The return value can be a mixed list of either strings (names of
597types that are in scope) or actual tags (type declared locally
598that may or may not have a name.)")
599
600(defun semantic-ctxt-scoped-types-default (&optional point)
601 "Return a list of scoped types by name for the current context at POINT.
602This is very different for various languages, and does nothing unless
603overriden."
604 (if point (goto-char point))
605 (let ((case-fold-search semantic-case-fold))
606 ;; We need to look at TYPES within the bounds of locally parse arguments.
607 ;; C needs to find using statements and the like too. Bleh.
608 nil
609 ))
610
611(provide 'semantic/ctxt)
612
613;;; semantic-ctxt.el ends here
diff --git a/lisp/cedet/semantic/db-find.el b/lisp/cedet/semantic/db-find.el
new file mode 100644
index 00000000000..fb40d77d3ef
--- /dev/null
+++ b/lisp/cedet/semantic/db-find.el
@@ -0,0 +1,1353 @@
1;;; db-find.el --- Searching through semantic databases.
2
3;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
4;;; 2008, 2009 Free Software Foundation, Inc.
5
6;; Author: Eric M. Ludlam <zappo@gnu.org>
7;; Keywords: tags
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;; Databases of various forms can all be searched.
27;; There are a few types of searches that can be done:
28;;
29;; Basic Name Search:
30;; These searches scan a database table collection for tags based
31;; on name.
32;;
33;; Basic Attribute Search:
34;; These searches allow searching on specific attributes of tags,
35;; such as name, type, or other attribute.
36;;
37;; Advanced Search:
38;; These are searches that were needed to accomplish some
39;; specialized tasks as discovered in utilities. Advanced searches
40;; include matching methods defined outside some parent class.
41;;
42;; The reason for advanced searches are so that external
43;; repositories such as the Emacs obarray, or java .class files can
44;; quickly answer these needed questions without dumping the entire
45;; symbol list into Emacs for additional refinement searches via
46;; regular semanticdb search.
47;;
48;; How databases are decided upon is another important aspect of a
49;; database search. When it comes to searching for a name, there are
50;; these types of searches:
51;;
52;; Basic Search:
53;; Basic search means that tags looking for a given name start
54;; with a specific search path. Names are sought on that path
55;; until it is empty or items on the path can no longer be found.
56;; Use `semanticdb-dump-all-table-summary' to test this list.
57;; Use `semanticdb-find-throttle-custom-list' to refine this list.
58;;
59;; Deep Search:
60;; A deep search will search more than just the global namespace.
61;; It will recurse into tags that contain more tags, and search
62;; those too.
63;;
64;; Brute Search:
65;; Brute search means that all tables in all databases in a given
66;; project are searched. Brute searches are the search style as
67;; written for semantic version 1.x.
68;;
69;; How does the search path work?
70;;
71;; A basic search starts with three parameters:
72;;
73;; (FINDME &optional PATH FIND-FILE-MATCH)
74;;
75;; FINDME is key to be searched for dependent on the type of search.
76;; PATH is an indicator of which tables are to be searched.
77;; FIND-FILE-MATCH indicates that any time a match is found, the
78;; file associated with the tag should be read into a file.
79;;
80;; The PATH argument is then the most interesting argument. It can
81;; have these values:
82;;
83;; nil - Take the current buffer, and use it's include list
84;; buffer - Use that buffer's include list.
85;; filename - Use that file's include list. If the file is not
86;; in a buffer, see of there is a semanticdb table for it. If
87;; not, read that file into a buffer.
88;; tag - Get that tag's buffer of file file. See above.
89;; table - Search that table, and it's include list.
90;;
91;; Search Results:
92;;
93;; Semanticdb returns the results in a specific format. There are a
94;; series of routines for using those results, and results can be
95;; passed in as a search-path for refinement searches with
96;; semanticdb. Apropos for semanticdb.*find-result for more.
97;;
98;; Application:
99;;
100;; Here are applications where different searches are needed which
101;; exist as of semantic 1.4.x
102;;
103;; eldoc - popup help
104;; => Requires basic search using default path. (Header files ok)
105;; tag jump - jump to a named tag
106;; => Requires a brute search useing whole project. (Source files only)
107;; completion - Completing symbol names in a smart way
108;; => Basic search (headers ok)
109;; type analysis - finding type definitions for variables & fcns
110;; => Basic search (headers ok)
111;; Class browser - organize types into some structure
112;; => Brute search, or custom navigation.
113
114;; TODO:
115;; During a search, load any unloaded DB files based on paths in the
116;; current project.
117
118(require 'semantic/db)
119(require 'semantic/db-ref)
120(eval-when-compile
121 (require 'eieio)
122 )
123
124;;; Code:
125(defvar semanticdb-find-throttle-custom-list
126 '(repeat (radio (const 'local)
127 (const 'project)
128 (const 'unloaded)
129 (const 'system)
130 (const 'recursive)
131 (const 'omniscience)))
132 "Customization values for semanticdb find throttle.
133See `semanticdb-find-throttle' for details.")
134
135(defcustom semanticdb-find-default-throttle
136 '(local project unloaded system recursive)
137 "The default throttle for `semanticdb-find' routines.
138The throttle controls how detailed the list of database
139tables is for a symbol lookup. The value is a list with
140the following keys:
141 `file' - The file the search is being performed from.
142 This option is here for completeness only, and
143 is assumed to always be on.
144 `local' - Tables from the same local directory are included.
145 This includes files directly referenced by a file name
146 which might be in a different directory.
147 `project' - Tables from the same local project are included
148 If `project' is specified, then `local' is assumed.
149 `unloaded' - If a table is not in memory, load it. If it is not cached
150 on disk either, get the source, parse it, and create
151 the table.
152 `system' - Tables from system databases. These are specifically
153 tables from system header files, or language equivalent.
154 `recursive' - For include based searches, includes tables referenced
155 by included files.
156 `omniscience' - Included system databases which are omniscience, or
157 somehow know everything. Omniscience databases are found
158 in `semanticdb-project-system-databases'.
159 The Emacs Lisp system DB is an omniscience database."
160 :group 'semanticdb
161 :type semanticdb-find-throttle-custom-list)
162
163(defun semanticdb-find-throttle-active-p (access-type)
164 "Non-nil if ACCESS-TYPE is an active throttle type."
165 (or (memq access-type semanticdb-find-default-throttle)
166 (eq access-type 'file)
167 (and (eq access-type 'local)
168 (memq 'project semanticdb-find-default-throttle))
169 ))
170
171;;; Index Class
172;;
173;; The find routines spend a lot of time looking stuff up.
174;; Use this handy search index to cache data between searches.
175;; This should allow searches to start running faster.
176(defclass semanticdb-find-search-index (semanticdb-abstract-search-index)
177 ((include-path :initform nil
178 :documentation
179 "List of semanticdb tables from the include path.")
180 (type-cache :initform nil
181 :documentation
182 "Cache of all the data types accessible from this file.
183Includes all types from all included files, merged namespaces, and
184expunge duplicates.")
185 )
186 "Concrete search index for `semanticdb-find'.
187This class will cache data derived during various searches.")
188
189(defmethod semantic-reset ((idx semanticdb-find-search-index))
190 "Reset the object IDX."
191 ;; Clear the include path.
192 (oset idx include-path nil)
193 (when (oref idx type-cache)
194 (semantic-reset (oref idx type-cache)))
195 ;; Clear the scope. Scope doesn't have the data it needs to track
196 ;; it's own reset.
197 (semantic-scope-reset-cache)
198 )
199
200(defmethod semanticdb-synchronize ((idx semanticdb-find-search-index)
201 new-tags)
202 "Synchronize the search index IDX with some NEW-TAGS."
203 ;; Reset our parts.
204 (semantic-reset idx)
205 ;; Notify dependants by clearning their indicies.
206 (semanticdb-notify-references
207 (oref idx table)
208 (lambda (tab me)
209 (semantic-reset (semanticdb-get-table-index tab))))
210 )
211
212(defmethod semanticdb-partial-synchronize ((idx semanticdb-find-search-index)
213 new-tags)
214 "Synchronize the search index IDX with some changed NEW-TAGS."
215 ;; Only reset if include statements changed.
216 (if (semantic-find-tags-by-class 'include new-tags)
217 (progn
218 (semantic-reset idx)
219 ;; Notify dependants by clearning their indicies.
220 (semanticdb-notify-references
221 (oref idx table)
222 (lambda (tab me)
223 (semantic-reset (semanticdb-get-table-index tab))))
224 )
225 ;; Else, not an include, by just a type.
226 (when (oref idx type-cache)
227 (when (semanticdb-partial-synchronize (oref idx type-cache) new-tags)
228 ;; If the synchronize returns true, we need to notify.
229 ;; Notify dependants by clearning their indicies.
230 (semanticdb-notify-references
231 (oref idx table)
232 (lambda (tab me)
233 (let ((tab-idx (semanticdb-get-table-index tab)))
234 ;; Not a full reset?
235 (when (oref tab-idx type-cache)
236 (semanticdb-typecache-notify-reset
237 (oref tab-idx type-cache)))
238 )))
239 ))
240 ))
241
242
243;;; Path Translations
244;;
245;;; OVERLOAD Functions
246;;
247;; These routines needed to be overloaded by specific language modes.
248;; They are needed for translating an INCLUDE tag into a semanticdb
249;; TABLE object.
250(define-overloadable-function semanticdb-find-translate-path (path brutish)
251 "Translate PATH into a list of semantic tables.
252Path translation involves identifying the PATH input argument
253in one of the following ways:
254 nil - Take the current buffer, and use it's include list
255 buffer - Use that buffer's include list.
256 filename - Use that file's include list. If the file is not
257 in a buffer, see of there is a semanticdb table for it. If
258 not, read that file into a buffer.
259 tag - Get that tag's buffer of file file. See above.
260 table - Search that table, and it's include list.
261 find result - Search the results of a previous find.
262
263In addition, once the base path is found, there is the possibility of
264each added table adding yet more tables to the path, so this routine
265can return a lengthy list.
266
267If argument BRUTISH is non-nil, then instead of using the include
268list, use all tables found in the parent project of the table
269identified by translating PATH. Such searches use brute force to
270scan every available table.
271
272The return value is a list of objects of type `semanticdb-table' or
273it's children. In the case of passing in a find result, the result
274is returned unchanged.
275
276This routine uses `semanticdb-find-table-for-include' to translate
277specific include tags into a semanticdb table.
278
279Note: When searching using a non-brutish method, the list of
280included files will be cached between runs. Database-references
281are used to track which files need to have their include lists
282refreshed when things change. See `semanticdb-ref-test'.
283
284Note for overloading: If you opt to overload this function for your
285major mode, and your routine takes a long time, be sure to call
286
287 (semantic-throw-on-input 'your-symbol-here)
288
289so that it can be called from the idle work handler."
290 )
291
292(defun semanticdb-find-translate-path-default (path brutish)
293 "Translate PATH into a list of semantic tables.
294If BRUTISH is non nil, return all tables associated with PATH.
295Default action as described in `semanticdb-find-translate-path'."
296 (if (semanticdb-find-results-p path)
297 ;; nil means perform the search over these results.
298 nil
299 (if brutish
300 (semanticdb-find-translate-path-brutish-default path)
301 (semanticdb-find-translate-path-includes-default path))))
302
303(defun semanticdb-find-translate-path-brutish-default (path)
304 "Translate PATH into a list of semantic tables.
305Default action as described in `semanticdb-find-translate-path'."
306 (let ((basedb
307 (cond ((null path) semanticdb-current-database)
308 ((semanticdb-table-p path) (oref path parent-db))
309 (t (let ((tt (semantic-something-to-tag-table path)))
310 (save-excursion
311 ;; @todo - What does this DO ??!?!
312 (set-buffer (semantic-tag-buffer (car tt)))
313 semanticdb-current-database))))))
314 (apply
315 #'nconc
316 (mapcar
317 (lambda (db)
318 (let ((tabs (semanticdb-get-database-tables db))
319 (ret nil))
320 ;; Only return tables of the same language (major-mode)
321 ;; as the current search environment.
322 (while tabs
323
324 (semantic-throw-on-input 'translate-path-brutish)
325
326 (if (semanticdb-equivalent-mode-for-search (car tabs)
327 (current-buffer))
328 (setq ret (cons (car tabs) ret)))
329 (setq tabs (cdr tabs)))
330 ret))
331 ;; FIXME:
332 ;; This should scan the current project directory list for all
333 ;; semanticdb files, perhaps handling proxies for them.
334 (semanticdb-current-database-list
335 (if basedb (oref basedb reference-directory)
336 default-directory))))
337 ))
338
339(defun semanticdb-find-incomplete-cache-entries-p (cache)
340 "Are there any incomplete entries in CACHE?"
341 (let ((ans nil))
342 (dolist (tab cache)
343 (when (and (semanticdb-table-child-p tab)
344 (not (number-or-marker-p (oref tab pointmax))))
345 (setq ans t))
346 )
347 ans))
348
349(defun semanticdb-find-need-cache-update-p (table)
350 "Non nil if the semanticdb TABLE cache needs to be updated."
351 ;; If we were passed in something related to a TABLE,
352 ;; do a caching lookup.
353 (let* ((index (semanticdb-get-table-index table))
354 (cache (when index (oref index include-path)))
355 (incom (semanticdb-find-incomplete-cache-entries-p cache))
356 (unl (semanticdb-find-throttle-active-p 'unloaded))
357 )
358 (if (and
359 cache ;; Must have a cache
360 (or
361 ;; If all entries are "full", or if 'unloaded
362 ;; OR
363 ;; is not in the throttle, it is ok to use the cache.
364 (not incom) (not unl)
365 ))
366 nil
367 ;;cache
368 ;; ELSE
369 ;;
370 ;; We need an update.
371 t))
372 )
373
374(defun semanticdb-find-translate-path-includes-default (path)
375 "Translate PATH into a list of semantic tables.
376Default action as described in `semanticdb-find-translate-path'."
377 (let ((table (cond ((null path)
378 semanticdb-current-table)
379 ((bufferp path)
380 (semantic-buffer-local-value 'semanticdb-current-table path))
381 ((and (stringp path) (file-exists-p path))
382 (semanticdb-file-table-object path t))
383 ((semanticdb-abstract-table-child-p path)
384 path)
385 (t nil))))
386 (if table
387 ;; If we were passed in something related to a TABLE,
388 ;; do a caching lookup.
389 (let ((index (semanticdb-get-table-index table)))
390 (if (semanticdb-find-need-cache-update-p table)
391 ;; Lets go look up our indicies
392 (let ((ans (semanticdb-find-translate-path-includes--internal path)))
393 (oset index include-path ans)
394 ;; Once we have our new indicies set up, notify those
395 ;; who depend on us if we found something for them to
396 ;; depend on.
397 (when ans (semanticdb-refresh-references table))
398 ans)
399 ;; ELSE
400 ;;
401 ;; Just return the cache.
402 (oref index include-path)))
403 ;; If we were passed in something like a tag list, or other boring
404 ;; searchable item, then instead do the regular thing without caching.
405 (semanticdb-find-translate-path-includes--internal path))))
406
407(defvar semanticdb-find-lost-includes nil
408 "Include files that we cannot find associated with this buffer.")
409(make-variable-buffer-local 'semanticdb-find-lost-includes)
410
411(defvar semanticdb-find-scanned-include-tags nil
412 "All include tags scanned, plus action taken on the tag.
413Each entry is an alist:
414 (ACTION . TAG)
415where ACTION is one of 'scanned, 'duplicate, 'lost.
416and TAG is a clone of the include tag that was found.")
417(make-variable-buffer-local 'semanticdb-find-scanned-include-tags)
418
419(defvar semanticdb-implied-include-tags nil
420 "Include tags implied for all files of a given mode.
421Set this variable with `defvar-mode-local' for a particular mode so
422that any symbols that exist for all files for that mode are included.
423
424Note: This could be used as a way to write a file in a langauge
425to declare all the built-ins for that language.")
426
427(defun semanticdb-find-translate-path-includes--internal (path)
428 "Internal implementation of `semanticdb-find-translate-path-includes-default'.
429This routine does not depend on the cache, but will always derive
430a new path from the provided PATH."
431 (let ((includetags nil)
432 (curtable nil)
433 (matchedtables (list semanticdb-current-table))
434 (matchedincludes nil)
435 (lostincludes nil)
436 (scannedincludes nil)
437 (incfname nil)
438 nexttable)
439 (cond ((null path)
440 (semantic-refresh-tags-safe)
441 (setq includetags (append
442 (semantic-find-tags-included (current-buffer))
443 semanticdb-implied-include-tags)
444 curtable semanticdb-current-table
445 incfname (buffer-file-name))
446 )
447 ((semanticdb-table-p path)
448 (setq includetags (semantic-find-tags-included path)
449 curtable path
450 incfname (semanticdb-full-filename path))
451 )
452 ((bufferp path)
453 (save-excursion
454 (set-buffer path)
455 (semantic-refresh-tags-safe))
456 (setq includetags (semantic-find-tags-included path)
457 curtable (save-excursion (set-buffer path)
458 semanticdb-current-table)
459 incfname (buffer-file-name path)))
460 (t
461 (setq includetags (semantic-find-tags-included path))
462 (when includetags
463 ;; If we have some tags, derive a table from them.
464 ;; else we will do nothing, so the table is useless.
465
466 ;; @todo - derive some tables
467 (message "Need to derive tables for %S in translate-path-includes--default."
468 path)
469 )))
470
471 ;; Make sure each found include tag has an originating file name associated
472 ;; with it.
473 (when incfname
474 (dolist (it includetags)
475 (semantic--tag-put-property it :filename incfname)))
476
477 ;; Loop over all include tags adding to matchedtables
478 (while includetags
479 (semantic-throw-on-input 'semantic-find-translate-path-includes-default)
480
481 ;; If we've seen this include string before, lets skip it.
482 (if (member (semantic-tag-name (car includetags)) matchedincludes)
483 (progn
484 (setq nexttable nil)
485 (push (cons 'duplicate (semantic-tag-clone (car includetags)))
486 scannedincludes)
487 )
488 (setq nexttable (semanticdb-find-table-for-include (car includetags) curtable))
489 (when (not nexttable)
490 ;; Save the lost include.
491 (push (car includetags) lostincludes)
492 (push (cons 'lost (semantic-tag-clone (car includetags)))
493 scannedincludes)
494 )
495 )
496
497 ;; Push the include file, so if we can't find it, we only
498 ;; can't find it once.
499 (push (semantic-tag-name (car includetags)) matchedincludes)
500
501 ;; (message "Scanning %s" (semantic-tag-name (car includetags)))
502 (when (and nexttable
503 (not (memq nexttable matchedtables))
504 (semanticdb-equivalent-mode-for-search nexttable
505 (current-buffer))
506 )
507 ;; Add to list of tables
508 (push nexttable matchedtables)
509
510 ;; Queue new includes to list
511 (if (semanticdb-find-throttle-active-p 'recursive)
512 ;; @todo - recursive includes need to have the originating
513 ;; buffer's location added to the path.
514 (let ((newtags
515 (cond
516 ((semanticdb-table-p nexttable)
517 (semanticdb-refresh-table nexttable)
518 ;; Use the method directly, or we will recurse
519 ;; into ourselves here.
520 (semanticdb-find-tags-by-class-method
521 nexttable 'include))
522 (t ;; @todo - is this ever possible???
523 (message "semanticdb-ftp - how did you do that?")
524 (semantic-find-tags-included
525 (semanticdb-get-tags nexttable)))
526 ))
527 (newincfname (semanticdb-full-filename nexttable))
528 )
529
530 (push (cons 'scanned (semantic-tag-clone (car includetags)))
531 scannedincludes)
532
533 ;; Setup new tags so we know where they are.
534 (dolist (it newtags)
535 (semantic--tag-put-property it :filename
536 newincfname))
537
538 (setq includetags (nconc includetags newtags)))
539 ;; ELSE - not recursive throttle
540 (push (cons 'scanned-no-recurse
541 (semantic-tag-clone (car includetags)))
542 scannedincludes)
543 )
544 )
545 (setq includetags (cdr includetags)))
546
547 (setq semanticdb-find-lost-includes lostincludes)
548 (setq semanticdb-find-scanned-include-tags (reverse scannedincludes))
549
550 ;; Find all the omniscient databases for this major mode, and
551 ;; add them if needed
552 (when (and (semanticdb-find-throttle-active-p 'omniscience)
553 semanticdb-search-system-databases)
554 ;; We can append any mode-specific omniscience databases into
555 ;; our search list here.
556 (let ((systemdb semanticdb-project-system-databases)
557 (ans nil))
558 (while systemdb
559 (setq ans (semanticdb-file-table
560 (car systemdb)
561 ;; I would expect most omniscient to return the same
562 ;; thing reguardless of filename, but we may have
563 ;; one that can return a table of all things the
564 ;; current file needs.
565 (buffer-file-name (current-buffer))))
566 (when (not (memq ans matchedtables))
567 (setq matchedtables (cons ans matchedtables)))
568 (setq systemdb (cdr systemdb))))
569 )
570 (nreverse matchedtables)))
571
572(define-overloadable-function semanticdb-find-load-unloaded (filename)
573 "Create a database table for FILENAME if it hasn't been parsed yet.
574Assumes that FILENAME exists as a source file.
575Assumes that a preexisting table does not exist, even if it
576isn't in memory yet."
577 (if (semanticdb-find-throttle-active-p 'unloaded)
578 (:override)
579 (semanticdb-file-table-object filename t)))
580
581(defun semanticdb-find-load-unloaded-default (filename)
582 "Load an unloaded file in FILENAME using the default semanticdb loader."
583 (semanticdb-file-table-object filename))
584
585(define-overloadable-function semanticdb-find-table-for-include (includetag &optional table)
586 "For a single INCLUDETAG found in TABLE, find a `semanticdb-table' object
587INCLUDETAG is a semantic TAG of class 'include.
588TABLE is a semanticdb table that identifies where INCLUDETAG came from.
589TABLE is optional if INCLUDETAG has an overlay of :filename attribute."
590 )
591
592(defun semanticdb-find-table-for-include-default (includetag &optional table)
593 "Default implementation of `semanticdb-find-table-for-include'.
594Uses `semanticdb-current-database-list' as the search path.
595INCLUDETAG and TABLE are documented in `semanticdb-find-table-for-include'.
596Included databases are filtered based on `semanticdb-find-default-throttle'."
597 (if (not (eq (semantic-tag-class includetag) 'include))
598 (signal 'wrong-type-argument (list includetag 'include)))
599
600 (let ((name
601 ;; Note, some languages (like Emacs or Java) use include tag names
602 ;; that don't represent files! We want to have file names.
603 (semantic-tag-include-filename includetag))
604 (originfiledir nil)
605 (roots nil)
606 (tmp nil)
607 (ans nil))
608
609 ;; INCLUDETAG should have some way to reference where it came
610 ;; from! If not, TABLE should provide the way. Each time we
611 ;; look up a tag, we may need to find it in some relative way
612 ;; and must set our current buffer eto the origin of includetag
613 ;; or nothing may work.
614 (setq originfiledir
615 (cond ((semantic-tag-file-name includetag)
616 ;; A tag may have a buffer, or a :filename property.
617 (file-name-directory (semantic-tag-file-name includetag)))
618 (table
619 (file-name-directory (semanticdb-full-filename table)))
620 (t
621 ;; @todo - what to do here? Throw an error maybe
622 ;; and fix usage bugs?
623 default-directory)))
624
625 (cond
626 ;; Step 1: Relative path name
627 ;;
628 ;; If the name is relative, then it should be findable as relative
629 ;; to the source file that this tag originated in, and be fast.
630 ;;
631 ((and (semanticdb-find-throttle-active-p 'local)
632 (file-exists-p (expand-file-name name originfiledir)))
633
634 (setq ans (semanticdb-find-load-unloaded
635 (expand-file-name name originfiledir)))
636 )
637 ;; Step 2: System or Project level includes
638 ;;
639 ((or
640 ;; First, if it a system include, we can investigate that tags
641 ;; dependency file
642 (and (semanticdb-find-throttle-active-p 'system)
643
644 ;; Sadly, not all languages make this distinction.
645 ;;(semantic-tag-include-system-p includetag)
646
647 ;; Here, we get local and system files.
648 (setq tmp (semantic-dependency-tag-file includetag))
649 )
650 ;; Second, project files are active, we and we have EDE,
651 ;; we can find it using the same tool.
652 (and (semanticdb-find-throttle-active-p 'project)
653 ;; Make sure EDE is available, and we have a project
654 (featurep 'ede) (ede-current-project originfiledir)
655 ;; The EDE query is hidden in this call.
656 (setq tmp (semantic-dependency-tag-file includetag))
657 )
658 )
659 (setq ans (semanticdb-find-load-unloaded tmp))
660 )
661 ;; Somewhere in our project hierarchy
662 ;;
663 ;; Remember: Roots includes system databases which can create
664 ;; specialized tables we can search.
665 ;;
666 ;; NOTE: Not used if EDE is active!
667 ((and (semanticdb-find-throttle-active-p 'project)
668 ;; And dont do this if it is a system include. Not supported by all languages,
669 ;; but when it is, this is a nice fast way to skip this step.
670 (not (semantic-tag-include-system-p includetag))
671 ;; Don't do this if we have an EDE project.
672 (not (and (featurep 'ede)
673 ;; Note: We don't use originfiledir here because
674 ;; we want to know about the source file we are
675 ;; starting from.
676 (ede-current-project)))
677 )
678
679 (setq roots (semanticdb-current-database-list))
680
681 (while (and (not ans) roots)
682 (let* ((ref (if (slot-boundp (car roots) 'reference-directory)
683 (oref (car roots) reference-directory)))
684 (fname (cond ((null ref) nil)
685 ((file-exists-p (expand-file-name name ref))
686 (expand-file-name name ref))
687 ((file-exists-p (expand-file-name (file-name-nondirectory name) ref))
688 (expand-file-name (file-name-nondirectory name) ref)))))
689 (when (and ref fname)
690 ;; There is an actual file. Grab it.
691 (setq ans (semanticdb-find-load-unloaded fname)))
692
693 ;; ELSE
694 ;;
695 ;; NOTE: We used to look up omniscient databases here, but that
696 ;; is now handled one layer up.
697 ;;
698 ;; Missing: a database that knows where missing files are. Hmm.
699 ;; perhaps I need an override function for that?
700
701 )
702
703 (setq roots (cdr roots))))
704 )
705 ans))
706
707
708;;; Perform interactive tests on the path/search mechanisms.
709;;
710(defun semanticdb-find-test-translate-path (&optional arg)
711 "Call and output results of `semanticdb-find-translate-path'.
712With ARG non-nil, specify a BRUTISH translation.
713See `semanticdb-find-default-throttle' and `semanticdb-project-roots'
714for details on how this list is derived."
715 (interactive "P")
716 (semantic-fetch-tags)
717 (require 'data-debug)
718 (let ((start (current-time))
719 (p (semanticdb-find-translate-path nil arg))
720 (end (current-time))
721 )
722 (data-debug-new-buffer "*SEMANTICDB FTP ADEBUG*")
723 (message "Search of tags took %.2f seconds."
724 (semantic-elapsed-time start end))
725
726 (data-debug-insert-stuff-list p "*")))
727
728(defun semanticdb-find-test-translate-path-no-loading (&optional arg)
729 "Call and output results of `semanticdb-find-translate-path'.
730With ARG non-nil, specify a BRUTISH translation.
731See `semanticdb-find-default-throttle' and `semanticdb-project-roots'
732for details on how this list is derived."
733 (interactive "P")
734 (semantic-fetch-tags)
735 (require 'data-debug)
736 (let* ((semanticdb-find-default-throttle
737 (if (featurep 'semanticdb-find)
738 (remq 'unloaded semanticdb-find-default-throttle)
739 nil))
740 (start (current-time))
741 (p (semanticdb-find-translate-path nil arg))
742 (end (current-time))
743 )
744 (data-debug-new-buffer "*SEMANTICDB FTP ADEBUG*")
745 (message "Search of tags took %.2f seconds."
746 (semantic-elapsed-time start end))
747
748 (data-debug-insert-stuff-list p "*")))
749
750(defun semanticdb-find-adebug-lost-includes ()
751 "Translate the current path, then display the lost includes.
752Examines the variable `semanticdb-find-lost-includes'."
753 (interactive)
754 (require 'data-debug)
755 (semanticdb-find-translate-path nil nil)
756 (let ((lost semanticdb-find-lost-includes)
757 )
758
759 (if (not lost)
760 (message "There are no unknown includes for %s"
761 (buffer-name))
762
763 (data-debug-new-buffer "*SEMANTICDB lost-includes ADEBUG*")
764 (data-debug-insert-tag-list lost "*")
765 )))
766
767(defun semanticdb-find-adebug-insert-scanned-tag-cons (consdata prefix prebuttontext)
768 "Insert a button representing scanned include CONSDATA.
769PREFIX is the text that preceeds the button.
770PREBUTTONTEXT is some text between prefix and the overlay button."
771 (let* ((start (point))
772 (end nil)
773 (mode (car consdata))
774 (tag (cdr consdata))
775 (name (semantic-tag-name tag))
776 (file (semantic-tag-file-name tag))
777 (str1 (format "%S %s" mode name))
778 (str2 (format " : %s" file))
779 (tip nil))
780 (insert prefix prebuttontext str1)
781 (setq end (point))
782 (insert str2)
783 (put-text-property start end 'face
784 (cond ((eq mode 'scanned)
785 'font-lock-function-name-face)
786 ((eq mode 'duplicate)
787 'font-lock-comment-face)
788 ((eq mode 'lost)
789 'font-lock-variable-name-face)
790 ((eq mode 'scanned-no-recurse)
791 'font-lock-type-face)))
792 (put-text-property start end 'ddebug (cdr consdata))
793 (put-text-property start end 'ddebug-indent(length prefix))
794 (put-text-property start end 'ddebug-prefix prefix)
795 (put-text-property start end 'help-echo tip)
796 (put-text-property start end 'ddebug-function
797 'data-debug-insert-tag-parts-from-point)
798 (insert "\n")
799 )
800 )
801
802(defun semanticdb-find-adebug-scanned-includes ()
803 "Translate the current path, then display the lost includes.
804Examines the variable `semanticdb-find-lost-includes'."
805 (interactive)
806 (require 'data-debug)
807 (semanticdb-find-translate-path nil nil)
808 (let ((scanned semanticdb-find-scanned-include-tags)
809 (data-debug-thing-alist
810 (cons
811 '((lambda (thing) (and (consp thing)
812 (symbolp (car thing))
813 (memq (car thing)
814 '(scanned scanned-no-recurse
815 lost duplicate))))
816 . semanticdb-find-adebug-insert-scanned-tag-cons)
817 data-debug-thing-alist))
818 )
819
820 (if (not scanned)
821 (message "There are no includes scanned %s"
822 (buffer-name))
823
824 (data-debug-new-buffer "*SEMANTICDB scanned-includes ADEBUG*")
825 (data-debug-insert-stuff-list scanned "*")
826 )))
827
828;;; FIND results and edebug
829;;
830(eval-after-load "cedet-edebug"
831 '(progn
832 (cedet-edebug-add-print-override
833 '(semanticdb-find-results-p object)
834 '(semanticdb-find-result-prin1-to-string object) )
835 ))
836
837
838
839;;; API Functions
840;;
841;; Once you have a search result, use these routines to operate
842;; on the search results at a higher level
843
844(defun semanticdb-strip-find-results (results &optional find-file-match)
845 "Strip a semanticdb search RESULTS to exclude objects.
846This makes it appear more like the results of a `semantic-find-' call.
847Optional FIND-FILE-MATCH loads all files associated with RESULTS
848into buffers. This has the side effect of enabling `semantic-tag-buffer' to
849return a value.
850If FIND-FILE-MATCH is 'name, then only the filename is stored
851in each tag instead of loading each file into a buffer.
852If the input RESULTS are not going to be used again, and if
853FIND-FILE-MATCH is nil, you can use `semanticdb-fast-strip-find-results'
854instead."
855 (if find-file-match
856 ;; Load all files associated with RESULTS.
857 (let ((tmp results)
858 (output nil))
859 (while tmp
860 (let ((tab (car (car tmp)))
861 (tags (cdr (car tmp))))
862 (dolist (T tags)
863 ;; Normilzation gives specialty database tables a chance
864 ;; to convert into a more stable tag format.
865 (let* ((norm (semanticdb-normalize-one-tag tab T))
866 (ntab (car norm))
867 (ntag (cdr norm))
868 (nametable ntab))
869
870 ;; If it didn't normalize, use what we had.
871 (if (not norm)
872 (setq nametable tab)
873 (setq output (append output (list ntag))))
874
875 ;; Find-file-match allows a tool to make sure the tag is
876 ;; 'live', somewhere in a buffer.
877 (cond ((eq find-file-match 'name)
878 (let ((f (semanticdb-full-filename nametable)))
879 (semantic--tag-put-property ntag :filename f)))
880 ((and find-file-match ntab)
881 (semanticdb-get-buffer ntab))
882 )
883 ))
884 )
885 (setq tmp (cdr tmp)))
886 output)
887 ;; @todo - I could use nconc, but I don't know what the caller may do with
888 ;; RESULTS after this is called. Right now semantic-complete will
889 ;; recycling the input after calling this routine.
890 (apply #'append (mapcar #'cdr results))))
891
892(defun semanticdb-fast-strip-find-results (results)
893 "Destructively strip a semanticdb search RESULTS to exclude objects.
894This makes it appear more like the results of a `semantic-find-' call.
895This is like `semanticdb-strip-find-results', except the input list RESULTS
896will be changed."
897 (apply #'nconc (mapcar #'cdr results)))
898
899(defun semanticdb-find-results-p (resultp)
900 "Non-nil if RESULTP is in the form of a semanticdb search result.
901This query only really tests the first entry in the list that is RESULTP,
902but should be good enough for debugging assertions."
903 (and (listp resultp)
904 (listp (car resultp))
905 (semanticdb-abstract-table-child-p (car (car resultp)))
906 (or (semantic-tag-p (car (cdr (car resultp))))
907 (null (car (cdr (car resultp)))))))
908
909(defun semanticdb-find-result-prin1-to-string (result)
910 "Presuming RESULT satisfies `semanticdb-find-results-p', provide a short PRIN1 output."
911 (if (< (length result) 2)
912 (concat "#<FIND RESULT "
913 (mapconcat (lambda (a)
914 (concat "(" (object-name (car a) ) " . "
915 "#<TAG LIST " (number-to-string (length (cdr a))) ">)"))
916 result
917 " ")
918 ">")
919 ;; Longer results should have an abreviated form.
920 (format "#<FIND RESULT %d TAGS in %d FILES>"
921 (semanticdb-find-result-length result)
922 (length result))))
923
924(defun semanticdb-find-result-with-nil-p (resultp)
925 "Non-nil of RESULTP is in the form of a semanticdb search result.
926nil is a valid value where a TABLE usually is, but only if the TAG
927results include overlays.
928This query only really tests the first entry in the list that is RESULTP,
929but should be good enough for debugging assertions."
930 (and (listp resultp)
931 (listp (car resultp))
932 (let ((tag-to-test (car-safe (cdr (car resultp)))))
933 (or (and (semanticdb-abstract-table-child-p (car (car resultp)))
934 (or (semantic-tag-p tag-to-test)
935 (null tag-to-test)))
936 (and (null (car (car resultp)))
937 (or (semantic-tag-with-position-p tag-to-test)
938 (null tag-to-test))))
939 )))
940
941(defun semanticdb-find-result-length (result)
942 "Number of tags found in RESULT."
943 (let ((count 0))
944 (mapc (lambda (onetable)
945 (setq count (+ count (1- (length onetable)))))
946 result)
947 count))
948
949(defun semanticdb-find-result-nth (result n)
950 "In RESULT, return the Nth search result.
951This is a 0 based search result, with the first match being element 0.
952
953The returned value is a cons cell: (TAG . TABLE) where TAG
954is the tag at the Nth position. TABLE is the semanticdb table where
955the TAG was found. Sometimes TABLE can be nil."
956 (let ((ans nil)
957 (anstable nil))
958 ;; Loop over each single table hit.
959 (while (and (not ans) result)
960 ;; For each table result, get local length, and modify
961 ;; N to be that much less.
962 (let ((ll (length (cdr (car result))))) ;; local length
963 (if (> ll n)
964 ;; We have a local match.
965 (setq ans (nth n (cdr (car result)))
966 anstable (car (car result)))
967 ;; More to go. Decrement N.
968 (setq n (- n ll))))
969 ;; Keep moving.
970 (setq result (cdr result)))
971 (cons ans anstable)))
972
973(defun semanticdb-find-result-test (result)
974 "Test RESULT by accessing all the tags in the list."
975 (if (not (semanticdb-find-results-p result))
976 (error "Does not pass `semanticdb-find-results-p.\n"))
977 (let ((len (semanticdb-find-result-length result))
978 (i 0))
979 (while (< i len)
980 (let ((tag (semanticdb-find-result-nth result i)))
981 (if (not (semantic-tag-p (car tag)))
982 (error "%d entry is not a tag" i)))
983 (setq i (1+ i)))))
984
985(defun semanticdb-find-result-nth-in-buffer (result n)
986 "In RESULT, return the Nth search result.
987Like `semanticdb-find-result-nth', except that only the TAG
988is returned, and the buffer it is found it will be made current.
989If the result tag has no position information, the originating buffer
990is still made current."
991 (let* ((ret (semanticdb-find-result-nth result n))
992 (ans (car ret))
993 (anstable (cdr ret)))
994 ;; If we have a hit, double-check the find-file
995 ;; entry. If the file must be loaded, then gat that table's
996 ;; source file into a buffer.
997
998 (if anstable
999 (let ((norm (semanticdb-normalize-one-tag anstable ans)))
1000 (when norm
1001 ;; The normalized tags can now be found based on that
1002 ;; tags table.
1003 (semanticdb-set-buffer (car norm))
1004 ;; Now reset ans
1005 (setq ans (cdr norm))
1006 ))
1007 )
1008 ;; Return the tag.
1009 ans))
1010
1011(defun semanticdb-find-result-mapc (fcn result)
1012 "Apply FCN to each element of find RESULT for side-effects only.
1013FCN takes two arguments. The first is a TAG, and the
1014second is a DB from wence TAG originated.
1015Returns result."
1016 (mapc (lambda (sublst)
1017 (mapc (lambda (tag)
1018 (funcall fcn tag (car sublst)))
1019 (cdr sublst)))
1020 result)
1021 result)
1022
1023;;; Search Logging
1024;;
1025;; Basic logging to see what the search routines are doing.
1026(defvar semanticdb-find-log-flag nil
1027 "Non-nil means log the process of searches.")
1028
1029(defvar semanticdb-find-log-buffer-name "*SemanticDB Find Log*"
1030 "The name of the logging buffer.")
1031
1032(defun semanticdb-find-toggle-logging ()
1033 "Toggle sematnicdb logging."
1034 (interactive)
1035 (setq semanticdb-find-log-flag (null semanticdb-find-log-flag))
1036 (message "Semanticdb find logging is %sabled"
1037 (if semanticdb-find-log-flag "en" "dis")))
1038
1039(defun semanticdb-reset-log ()
1040 "Reset the log buffer."
1041 (interactive)
1042 (when semanticdb-find-log-flag
1043 (save-excursion
1044 (set-buffer (get-buffer-create semanticdb-find-log-buffer-name))
1045 (erase-buffer)
1046 )))
1047
1048(defun semanticdb-find-log-move-to-end ()
1049 "Move to the end of the semantic log."
1050 (let ((cb (current-buffer))
1051 (cw (selected-window)))
1052 (unwind-protect
1053 (progn
1054 (set-buffer semanticdb-find-log-buffer-name)
1055 (if (get-buffer-window (current-buffer) 'visible)
1056 (select-window (get-buffer-window (current-buffer) 'visible)))
1057 (goto-char (point-max)))
1058 (if cw (select-window cw))
1059 (set-buffer cb))))
1060
1061(defun semanticdb-find-log-new-search (forwhat)
1062 "Start a new search FORWHAT."
1063 (when semanticdb-find-log-flag
1064 (save-excursion
1065 (set-buffer (get-buffer-create semanticdb-find-log-buffer-name))
1066 (insert (format "New Search: %S\n" forwhat))
1067 )
1068 (semanticdb-find-log-move-to-end)))
1069
1070(defun semanticdb-find-log-activity (table result)
1071 "Log that TABLE has been searched and RESULT was found."
1072 (when semanticdb-find-log-flag
1073 (save-excursion
1074 (set-buffer semanticdb-find-log-buffer-name)
1075 (insert "Table: " (object-print table)
1076 " Result: " (int-to-string (length result)) " tags"
1077 "\n")
1078 )
1079 (semanticdb-find-log-move-to-end)))
1080
1081;;; Semanticdb find API functions
1082;;
1083;; These are the routines actually used to perform searches.
1084;;
1085(defun semanticdb-find-tags-collector (function &optional path find-file-match
1086 brutish)
1087 "Collect all tags returned by FUNCTION over PATH.
1088The FUNCTION must take two arguments. The first is TABLE,
1089which is a semanticdb table containing tags. The second argument
1090to FUNCTION is TAGS. TAGS may be a list of tags. If TAGS is non-nil, then
1091FUNCTION should search the TAG list, not through TABLE.
1092
1093See `semanticdb-find-translate-path' for details on PATH.
1094FIND-FILE-MATCH indicates that any time a match is found, the file
1095associated with that tag should be loaded into a buffer.
1096
1097Note: You should leave FIND-FILE-MATCH as nil. It is far more
1098efficient to take the results from any search and use
1099`semanticdb-strip-find-results' instead. This argument is here
1100for backward compatibility.
1101
1102If optional argument BRUTISH is non-nil, then ignore include statements,
1103and search all tables in this project tree."
1104 (let (found match)
1105 (save-excursion
1106 ;; If path is a buffer, set ourselves up in that buffer
1107 ;; so that the override methods work correctly.
1108 (when (bufferp path) (set-buffer path))
1109 (if (semanticdb-find-results-p path)
1110 ;; When we get find results, loop over that.
1111 (dolist (tableandtags path)
1112 (semantic-throw-on-input 'semantic-find-translate-path)
1113 ;; If FIND-FILE-MATCH is non-nil, skip tables of class
1114 ;; `semanticdb-search-results-table', since those are system
1115 ;; databases and not associated with a file.
1116 (unless (and find-file-match
1117 (obj-of-class-p
1118 (car tableandtags) semanticdb-search-results-table))
1119 (when (setq match (funcall function
1120 (car tableandtags) (cdr tableandtags)))
1121 (when find-file-match
1122 (save-excursion (semanticdb-set-buffer (car tableandtags))))
1123 (push (cons (car tableandtags) match) found)))
1124 )
1125 ;; Only log searches across data bases.
1126 (semanticdb-find-log-new-search nil)
1127 ;; If we get something else, scan the list of tables resulting
1128 ;; from translating it into a list of objects.
1129 (dolist (table (semanticdb-find-translate-path path brutish))
1130 (semantic-throw-on-input 'semantic-find-translate-path)
1131 ;; If FIND-FILE-MATCH is non-nil, skip tables of class
1132 ;; `semanticdb-search-results-table', since those are system
1133 ;; databases and not associated with a file.
1134 (unless (and find-file-match
1135 (obj-of-class-p table semanticdb-search-results-table))
1136 (when (and table (setq match (funcall function table nil)))
1137 (semanticdb-find-log-activity table match)
1138 (when find-file-match
1139 (save-excursion (semanticdb-set-buffer table)))
1140 (push (cons table match) found))))))
1141 ;; At this point, FOUND has had items pushed onto it.
1142 ;; This means items are being returned in REVERSE order
1143 ;; of the tables searched, so if you just get th CAR, then
1144 ;; too-bad, you may have some system-tag that has no
1145 ;; buffer associated with it.
1146
1147 ;; It must be reversed.
1148 (nreverse found)))
1149
1150(defun semanticdb-find-tags-by-name (name &optional path find-file-match)
1151 "Search for all tags matching NAME on PATH.
1152See `semanticdb-find-translate-path' for details on PATH.
1153FIND-FILE-MATCH indicates that any time a match is found, the file
1154associated with that tag should be loaded into a buffer."
1155 (semanticdb-find-tags-collector
1156 (lambda (table tags)
1157 (semanticdb-find-tags-by-name-method table name tags))
1158 path find-file-match))
1159
1160(defun semanticdb-find-tags-by-name-regexp (regexp &optional path find-file-match)
1161 "Search for all tags matching REGEXP on PATH.
1162See `semanticdb-find-translate-path' for details on PATH.
1163FIND-FILE-MATCH indicates that any time a match is found, the file
1164associated with that tag should be loaded into a buffer."
1165 (semanticdb-find-tags-collector
1166 (lambda (table tags)
1167 (semanticdb-find-tags-by-name-regexp-method table regexp tags))
1168 path find-file-match))
1169
1170(defun semanticdb-find-tags-for-completion (prefix &optional path find-file-match)
1171 "Search for all tags matching PREFIX on PATH.
1172See `semanticdb-find-translate-path' for details on PATH.
1173FIND-FILE-MATCH indicates that any time a match is found, the file
1174associated with that tag should be loaded into a buffer."
1175 (semanticdb-find-tags-collector
1176 (lambda (table tags)
1177 (semanticdb-find-tags-for-completion-method table prefix tags))
1178 path find-file-match))
1179
1180(defun semanticdb-find-tags-by-class (class &optional path find-file-match)
1181 "Search for all tags of CLASS on PATH.
1182See `semanticdb-find-translate-path' for details on PATH.
1183FIND-FILE-MATCH indicates that any time a match is found, the file
1184associated with that tag should be loaded into a buffer."
1185 (semanticdb-find-tags-collector
1186 (lambda (table tags)
1187 (semanticdb-find-tags-by-class-method table class tags))
1188 path find-file-match))
1189
1190;;; Deep Searches
1191(defun semanticdb-deep-find-tags-by-name (name &optional path find-file-match)
1192 "Search for all tags matching NAME on PATH.
1193Search also in all components of top level tags founds.
1194See `semanticdb-find-translate-path' for details on PATH.
1195FIND-FILE-MATCH indicates that any time a match is found, the file
1196associated with that tag should be loaded into a buffer."
1197 (semanticdb-find-tags-collector
1198 (lambda (table tags)
1199 (semanticdb-deep-find-tags-by-name-method table name tags))
1200 path find-file-match))
1201
1202(defun semanticdb-deep-find-tags-by-name-regexp (regexp &optional path find-file-match)
1203 "Search for all tags matching REGEXP on PATH.
1204Search also in all components of top level tags founds.
1205See `semanticdb-find-translate-path' for details on PATH.
1206FIND-FILE-MATCH indicates that any time a match is found, the file
1207associated with that tag should be loaded into a buffer."
1208 (semanticdb-find-tags-collector
1209 (lambda (table tags)
1210 (semanticdb-deep-find-tags-by-name-regexp-method table regexp tags))
1211 path find-file-match))
1212
1213(defun semanticdb-deep-find-tags-for-completion (prefix &optional path find-file-match)
1214 "Search for all tags matching PREFIX on PATH.
1215Search also in all components of top level tags founds.
1216See `semanticdb-find-translate-path' for details on PATH.
1217FIND-FILE-MATCH indicates that any time a match is found, the file
1218associated with that tag should be loaded into a buffer."
1219 (semanticdb-find-tags-collector
1220 (lambda (table tags)
1221 (semanticdb-deep-find-tags-for-completion-method table prefix tags))
1222 path find-file-match))
1223
1224;;; Brutish Search Routines
1225(defun semanticdb-brute-deep-find-tags-by-name (name &optional path find-file-match)
1226 "Search for all tags matching NAME on PATH.
1227See `semanticdb-find-translate-path' for details on PATH.
1228The argument BRUTISH will be set so that searching includes all tables
1229in the current project.
1230FIND-FILE-MATCH indicates that any time a matchi is found, the file
1231associated wit that tag should be loaded into a buffer."
1232 (semanticdb-find-tags-collector
1233 (lambda (table tags)
1234 (semanticdb-deep-find-tags-by-name-method table name tags))
1235 path find-file-match t))
1236
1237(defun semanticdb-brute-deep-find-tags-for-completion (prefix &optional path find-file-match)
1238 "Search for all tags matching PREFIX on PATH.
1239See `semanticdb-find-translate-path' for details on PATH.
1240The argument BRUTISH will be set so that searching includes all tables
1241in the current project.
1242FIND-FILE-MATCH indicates that any time a matchi is found, the file
1243associated wit that tag should be loaded into a buffer."
1244 (semanticdb-find-tags-collector
1245 (lambda (table tags)
1246 (semanticdb-deep-find-tags-for-completion-method table prefix tags))
1247 path find-file-match t))
1248
1249(defun semanticdb-brute-find-tags-by-class (class &optional path find-file-match)
1250 "Search for all tags of CLASS on PATH.
1251See `semanticdb-find-translate-path' for details on PATH.
1252The argument BRUTISH will be set so that searching includes all tables
1253in the current project.
1254FIND-FILE-MATCH indicates that any time a match is found, the file
1255associated with that tag should be loaded into a buffer."
1256 (semanticdb-find-tags-collector
1257 (lambda (table tags)
1258 (semanticdb-find-tags-by-class-method table class tags))
1259 path find-file-match t))
1260
1261;;; Specialty Search Routines
1262(defun semanticdb-find-tags-external-children-of-type
1263 (type &optional path find-file-match)
1264 "Search for all tags defined outside of TYPE w/ TYPE as a parent.
1265See `semanticdb-find-translate-path' for details on PATH.
1266FIND-FILE-MATCH indicates that any time a match is found, the file
1267associated with that tag should be loaded into a buffer."
1268 (semanticdb-find-tags-collector
1269 (lambda (table tags)
1270 (semanticdb-find-tags-external-children-of-type-method table type tags))
1271 path find-file-match))
1272
1273(defun semanticdb-find-tags-subclasses-of-type
1274 (type &optional path find-file-match)
1275 "Search for all tags of class type defined that subclass TYPE.
1276See `semanticdb-find-translate-path' for details on PATH.
1277FIND-FILE-MATCH indicates that any time a match is found, the file
1278associated with that tag should be loaded into a buffer."
1279 (semanticdb-find-tags-collector
1280 (lambda (table tags)
1281 (semanticdb-find-tags-subclasses-of-type-method table type tags))
1282 path find-file-match t))
1283
1284;;; METHODS
1285;;
1286;; Default methods for semanticdb database and table objects.
1287;; Override these with system databases to as new types of back ends.
1288
1289;;; Top level Searches
1290(defmethod semanticdb-find-tags-by-name-method ((table semanticdb-abstract-table) name &optional tags)
1291 "In TABLE, find all occurances of tags with NAME.
1292Optional argument TAGS is a list of tags to search.
1293Returns a table of all matching tags."
1294 (semantic-find-tags-by-name name (or tags (semanticdb-get-tags table))))
1295
1296(defmethod semanticdb-find-tags-by-name-regexp-method ((table semanticdb-abstract-table) regexp &optional tags)
1297 "In TABLE, find all occurances of tags matching REGEXP.
1298Optional argument TAGS is a list of tags to search.
1299Returns a table of all matching tags."
1300 (semantic-find-tags-by-name-regexp regexp (or tags (semanticdb-get-tags table))))
1301
1302(defmethod semanticdb-find-tags-for-completion-method ((table semanticdb-abstract-table) prefix &optional tags)
1303 "In TABLE, find all occurances of tags matching PREFIX.
1304Optional argument TAGS is a list of tags to search.
1305Returns a table of all matching tags."
1306 (semantic-find-tags-for-completion prefix (or tags (semanticdb-get-tags table))))
1307
1308(defmethod semanticdb-find-tags-by-class-method ((table semanticdb-abstract-table) class &optional tags)
1309 "In TABLE, find all occurances of tags of CLASS.
1310Optional argument TAGS is a list of tags to search.
1311Returns a table of all matching tags."
1312 (semantic-find-tags-by-class class (or tags (semanticdb-get-tags table))))
1313
1314(defmethod semanticdb-find-tags-external-children-of-type-method ((table semanticdb-abstract-table) parent &optional tags)
1315 "In TABLE, find all occurances of tags whose parent is the PARENT type.
1316Optional argument TAGS is a list of tags to search.
1317Returns a table of all matching tags."
1318 (semantic-find-tags-external-children-of-type parent (or tags (semanticdb-get-tags table))))
1319
1320(defmethod semanticdb-find-tags-subclasses-of-type-method ((table semanticdb-abstract-table) parent &optional tags)
1321 "In TABLE, find all occurances of tags whose parent is the PARENT type.
1322Optional argument TAGS is a list of tags to search.
1323Returns a table of all matching tags."
1324 (semantic-find-tags-subclasses-of-type parent (or tags (semanticdb-get-tags table))))
1325
1326;;; Deep Searches
1327(defmethod semanticdb-deep-find-tags-by-name-method ((table semanticdb-abstract-table) name &optional tags)
1328 "In TABLE, find all occurances of tags with NAME.
1329Search in all tags in TABLE, and all components of top level tags in
1330TABLE.
1331Optional argument TAGS is a list of tags to search.
1332Return a table of all matching tags."
1333 (semantic-find-tags-by-name name (semantic-flatten-tags-table (or tags (semanticdb-get-tags table)))))
1334
1335(defmethod semanticdb-deep-find-tags-by-name-regexp-method ((table semanticdb-abstract-table) regexp &optional tags)
1336 "In TABLE, find all occurances of tags matching REGEXP.
1337Search in all tags in TABLE, and all components of top level tags in
1338TABLE.
1339Optional argument TAGS is a list of tags to search.
1340Return a table of all matching tags."
1341 (semantic-find-tags-by-name-regexp regexp (semantic-flatten-tags-table (or tags (semanticdb-get-tags table)))))
1342
1343(defmethod semanticdb-deep-find-tags-for-completion-method ((table semanticdb-abstract-table) prefix &optional tags)
1344 "In TABLE, find all occurances of tags matching PREFIX.
1345Search in all tags in TABLE, and all components of top level tags in
1346TABLE.
1347Optional argument TAGS is a list of tags to search.
1348Return a table of all matching tags."
1349 (semantic-find-tags-for-completion prefix (semantic-flatten-tags-table (or tags (semanticdb-get-tags table)))))
1350
1351(provide 'semantic/db-find)
1352
1353;;; semanticdb-find.el ends here
diff --git a/lisp/cedet/semantic/db-ref.el b/lisp/cedet/semantic/db-ref.el
new file mode 100644
index 00000000000..62faf9933c2
--- /dev/null
+++ b/lisp/cedet/semantic/db-ref.el
@@ -0,0 +1,161 @@
1;;; db-ref.el --- Handle cross-db file references
2
3;;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <eric@siege-engine.com>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Handle cross-database file references.
25;;
26;; Any given database may be referred to by some other database. For
27;; example, if a .cpp file has a #include in a header, then that
28;; header file should have a reference to the .cpp file that included
29;; it.
30;;
31;; This is critical for purposes where a file (such as a .cpp file)
32;; needs to have its caches flushed because of changes in the
33;; header. Changing a header may cause a referring file to be
34;; reparsed due to account for changes in defined macros, or perhaps
35;; a change to files the header includes.
36
37
38;;; Code:
39(defmethod semanticdb-add-reference ((dbt semanticdb-abstract-table)
40 include-tag)
41 "Add a reference for the database table DBT based on INCLUDE-TAG.
42DBT is the database table that owns the INCLUDE-TAG. The reference
43will be added to the database that INCLUDE-TAG refers to."
44 ;; NOTE: I should add a check to make sure include-tag is in DB.
45 ;; but I'm too lazy.
46 (let* ((semanticdb-find-default-throttle
47 (if (featurep 'semanticdb-find)
48 (remq 'unloaded semanticdb-find-default-throttle)
49 nil))
50 (refdbt (semanticdb-find-table-for-include include-tag dbt))
51 ;;(fullfile (semanticdb-full-filename dbt))
52 )
53 (when refdbt
54 ;; Add our filename (full path)
55 ;; (object-add-to-list refdbt 'file-refs fullfile)
56
57 ;; Add our database.
58 (object-add-to-list refdbt 'db-refs dbt)
59 t)))
60
61(defmethod semanticdb-check-references ((dbt semanticdb-abstract-table))
62 "Check and cleanup references in the database DBT.
63Abstract tables would be difficult to reference."
64 ;; Not sure how an abstract table can have references.
65 nil)
66
67(defmethod semanticdb-includes-in-table ((dbt semanticdb-abstract-table))
68 "Return a list of direct includes in table DBT."
69 (semantic-find-tags-by-class 'include (semanticdb-get-tags dbt)))
70
71
72(defmethod semanticdb-check-references ((dbt semanticdb-table))
73 "Check and cleanup references in the database DBT.
74Any reference to a file that cannot be found, or whos file no longer
75refers to DBT will be removed."
76 (let ((refs (oref dbt db-refs))
77 (myexpr (concat "\\<" (oref dbt file)))
78 )
79 (while refs
80 (let* ((ok t)
81 (db (car refs))
82 (f (when (semanticdb-table-child-p db)
83 (semanticdb-full-filename db)))
84 )
85
86 ;; The file was deleted
87 (when (and f (not (file-exists-p f)))
88 (setq ok nil))
89
90 ;; The reference no longer includes the textual reference?
91 (let* ((refs (semanticdb-includes-in-table db))
92 (inc (semantic-find-tags-by-name-regexp
93 myexpr refs)))
94 (when (not inc)
95 (setq ok nil)))
96
97 ;; Remove not-ok databases from the list.
98 (when (not ok)
99 (object-remove-from-list dbt 'db-refs db)
100 ))
101 (setq refs (cdr refs)))))
102
103(defmethod semanticdb-refresh-references ((dbt semanticdb-abstract-table))
104 "Refresh references to DBT in other files."
105 ;; alternate tables can't be edited, so can't be changed.
106 nil
107 )
108
109(defmethod semanticdb-refresh-references ((dbt semanticdb-table))
110 "Refresh references to DBT in other files."
111 (let ((refs (semanticdb-includes-in-table dbt))
112 )
113 (while refs
114 (if (semanticdb-add-reference dbt (car refs))
115 nil
116 ;; If we succeeded, then do... nothing?
117 nil
118 )
119 (setq refs (cdr refs)))
120 ))
121
122(defmethod semanticdb-notify-references ((dbt semanticdb-table)
123 method)
124 "Notify all references of the table DBT using method.
125METHOD takes two arguments.
126 (METHOD TABLE-TO-NOTIFY DBT)
127TABLE-TO-NOTIFY is a semanticdb-table which is being notified.
128DBT, the second argument is DBT."
129 (mapc (lambda (R) (funcall method R dbt))
130 (oref dbt db-refs)))
131
132;;; DEBUG
133;;
134(defclass semanticdb-ref-adebug ()
135 ((i-depend-on :initarg :i-depend-on)
136 (local-table :initarg :local-table)
137 (i-include :initarg :i-include))
138 "Simple class to allow ADEBUG to show a nice list.")
139
140(defun semanticdb-ref-test (refresh)
141 "Dump out the list of references for the current buffer.
142If REFRESH is non-nil, cause the current table to have it's references
143refreshed before dumping the result."
144 (interactive "p")
145 ;; If we need to refresh... then do so.
146 (when refresh
147 (semanticdb-refresh-references semanticdb-current-table))
148 ;; Do the debug system
149 (let* ((tab semanticdb-current-table)
150 (myrefs (oref tab db-refs))
151 (myinc (semanticdb-includes-in-table tab))
152 (adbc (semanticdb-ref-adebug "DEBUG"
153 :i-depend-on myrefs
154 :local-table tab
155 :i-include myinc)))
156 (data-debug-new-buffer "*References ADEBUG*")
157 (data-debug-insert-object-slots adbc "!"))
158 )
159
160(provide 'semantic/db-ref)
161;;; semanticdb-ref.el ends here
diff --git a/lisp/cedet/semantic/find.el b/lisp/cedet/semantic/find.el
new file mode 100644
index 00000000000..a01b2ae2b22
--- /dev/null
+++ b/lisp/cedet/semantic/find.el
@@ -0,0 +1,795 @@
1;;; find.el --- Search routines for Semantic
2
3;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2008, 2009
4;;; 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;; Routines for searching through lists of tags.
27;; There are several groups of tag search routines:
28;;
29;; 1) semantic-brute-find-tag-by-*
30;; These routines use brute force hierarchical search to scan
31;; through lists of tags. They include some parameters
32;; used for compatibility with the semantic 1.x search routines.
33;;
34;; 1.5) semantic-brute-find-first-tag-by-*
35;; Like 1, except seraching stops on the first match for the given
36;; information.
37;;
38;; 2) semantic-find-tag-by-*
39;; These prefered search routines attempt to scan through lists
40;; in an intelligent way based on questions asked.
41;;
42;; 3) semantic-find-*-overlay
43;; These routines use overlays to return tags based on a buffer position.
44;;
45;; 4) ...
46
47(require 'semantic/tag)
48
49;;; Code:
50
51;;; Overlay Search Routines
52;;
53;; These routines provide fast access to tokens based on a buffer that
54;; has parsed tokens in it. Uses overlays to perform the hard work.
55(defun semantic-find-tag-by-overlay (&optional positionormarker buffer)
56 "Find all tags covering POSITIONORMARKER by using overlays.
57If POSITIONORMARKER is nil, use the current point.
58Optional BUFFER is used if POSITIONORMARKER is a number, otherwise the current
59buffer is used. This finds all tags covering the specified position
60by checking for all overlays covering the current spot. They are then sorted
61from largest to smallest via the start location."
62 (save-excursion
63 (when positionormarker
64 (if (markerp positionormarker)
65 (set-buffer (marker-buffer positionormarker))
66 (if (bufferp buffer)
67 (set-buffer buffer))))
68 (let ((ol (semantic-overlays-at (or positionormarker (point))))
69 (ret nil))
70 (while ol
71 (let ((tmp (semantic-overlay-get (car ol) 'semantic)))
72 (when (and tmp
73 ;; We don't need with-position because no tag w/out
74 ;; a position could exist in an overlay.
75 (semantic-tag-p tmp))
76 (setq ret (cons tmp ret))))
77 (setq ol (cdr ol)))
78 (sort ret (lambda (a b) (< (semantic-tag-start a)
79 (semantic-tag-start b)))))))
80
81(defun semantic-find-tag-by-overlay-in-region (start end &optional buffer)
82 "Find all tags which exist in whole or in part between START and END.
83Uses overlays to determine positin.
84Optional BUFFER argument specifies the buffer to use."
85 (save-excursion
86 (if buffer (set-buffer buffer))
87 (let ((ol (semantic-overlays-in start end))
88 (ret nil))
89 (while ol
90 (let ((tmp (semantic-overlay-get (car ol) 'semantic)))
91 (when (and tmp
92 ;; See above about position
93 (semantic-tag-p tmp))
94 (setq ret (cons tmp ret))))
95 (setq ol (cdr ol)))
96 (sort ret (lambda (a b) (< (semantic-tag-start a)
97 (semantic-tag-start b)))))))
98
99(defun semantic-find-tag-by-overlay-next (&optional start buffer)
100 "Find the next tag after START in BUFFER.
101If START is in an overlay, find the tag which starts next,
102not the current tag."
103 (save-excursion
104 (if buffer (set-buffer buffer))
105 (if (not start) (setq start (point)))
106 (let ((os start) (ol nil))
107 (while (and os (< os (point-max)) (not ol))
108 (setq os (semantic-overlay-next-change os))
109 (when os
110 ;; Get overlays at position
111 (setq ol (semantic-overlays-at os))
112 ;; find the overlay that belongs to semantic
113 ;; and starts at the found position.
114 (while (and ol (listp ol))
115 (if (and (semantic-overlay-get (car ol) 'semantic)
116 (semantic-tag-p
117 (semantic-overlay-get (car ol) 'semantic))
118 (= (semantic-overlay-start (car ol)) os))
119 (setq ol (car ol)))
120 (when (listp ol) (setq ol (cdr ol))))))
121 ;; convert ol to a tag
122 (when (and ol (semantic-tag-p (semantic-overlay-get ol 'semantic)))
123 (semantic-overlay-get ol 'semantic)))))
124
125(defun semantic-find-tag-by-overlay-prev (&optional start buffer)
126 "Find the next tag before START in BUFFER.
127If START is in an overlay, find the tag which starts next,
128not the current tag."
129 (save-excursion
130 (if buffer (set-buffer buffer))
131 (if (not start) (setq start (point)))
132 (let ((os start) (ol nil))
133 (while (and os (> os (point-min)) (not ol))
134 (setq os (semantic-overlay-previous-change os))
135 (when os
136 ;; Get overlays at position
137 (setq ol (semantic-overlays-at (1- os)))
138 ;; find the overlay that belongs to semantic
139 ;; and ENDS at the found position.
140 ;;
141 ;; Use end because we are going backward.
142 (while (and ol (listp ol))
143 (if (and (semantic-overlay-get (car ol) 'semantic)
144 (semantic-tag-p
145 (semantic-overlay-get (car ol) 'semantic))
146 (= (semantic-overlay-end (car ol)) os))
147 (setq ol (car ol)))
148 (when (listp ol) (setq ol (cdr ol))))))
149 ;; convert ol to a tag
150 (when (and ol
151 (semantic-tag-p (semantic-overlay-get ol 'semantic)))
152 (semantic-overlay-get ol 'semantic)))))
153
154(defun semantic-find-tag-parent-by-overlay (tag)
155 "Find the parent of TAG by overlays.
156Overlays are a fast way of finding this information for active buffers."
157 (let ((tag (nreverse (semantic-find-tag-by-overlay
158 (semantic-tag-start tag)))))
159 ;; This is a lot like `semantic-current-tag-parent', but
160 ;; it uses a position to do it's work. Assumes two tags don't share
161 ;; the same start unless they are siblings.
162 (car (cdr tag))))
163
164(defun semantic-current-tag ()
165 "Return the current tag in the current buffer.
166If there are more than one in the same location, return the
167smallest tag. Return nil if there is no tag here."
168 (car (nreverse (semantic-find-tag-by-overlay))))
169
170(defun semantic-current-tag-parent ()
171 "Return the current tags parent in the current buffer.
172A tag's parent would be a containing structure, such as a type
173containing a field. Return nil if there is no parent."
174 (car (cdr (nreverse (semantic-find-tag-by-overlay)))))
175
176(defun semantic-current-tag-of-class (class)
177 "Return the current (smallest) tags of CLASS in the current buffer.
178If the smallest tag is not of type CLASS, keep going upwards until one
179is found.
180Uses `semantic-tag-class' for classification."
181 (let ((tags (nreverse (semantic-find-tag-by-overlay))))
182 (while (and tags
183 (not (eq (semantic-tag-class (car tags)) class)))
184 (setq tags (cdr tags)))
185 (car tags)))
186
187;;; Search Routines
188;;
189;; These are routines that search a single tags table.
190;;
191;; The original API (see COMPATIBILITY section below) in semantic 1.4
192;; had these usage statistics:
193;;
194;; semantic-find-nonterminal-by-name 17
195;; semantic-find-nonterminal-by-name-regexp 8 - Most doing completion
196;; semantic-find-nonterminal-by-position 13
197;; semantic-find-nonterminal-by-token 21
198;; semantic-find-nonterminal-by-type 2
199;; semantic-find-nonterminal-standard 1
200;;
201;; semantic-find-nonterminal-by-function (not in other searches) 1
202;;
203;; New API: As above w/out `search-parts' or `search-includes' arguments.
204;; Extra fcn: Specific to completion which is what -name-regexp is
205;; mostly used for
206;;
207;; As for the sarguments "search-parts" and "search-includes" here
208;; are stats:
209;;
210;; search-parts: 4 - charting x2, find-doc, senator (sans db)
211;;
212;; Implement command to flatten a tag table. Call new API Fcn w/
213;; flattened table for same results.
214;;
215;; search-include: 2 - analyze x2 (sans db)
216;;
217;; Not used effectively. Not to be re-implemented here.
218
219(defsubst semantic--find-tags-by-function (predicate &optional table)
220 "Find tags for which PREDICATE is non-nil in TABLE.
221PREDICATE is a lambda expression which accepts on TAG.
222TABLE is a semantic tags table. See `semantic-something-to-tag-table'."
223 (let ((tags (semantic-something-to-tag-table table))
224 (result nil))
225; (mapc (lambda (tag) (and (funcall predicate tag)
226; (setq result (cons tag result))))
227; tags)
228 ;; A while loop is actually faster. Who knew
229 (while tags
230 (and (funcall predicate (car tags))
231 (setq result (cons (car tags) result)))
232 (setq tags (cdr tags)))
233 (nreverse result)))
234
235;; I can shave off some time by removing the funcall (see above)
236;; and having the question be inlined in the while loop.
237;; Strangely turning the upper level fcns into macros had a larger
238;; impact.
239(defmacro semantic--find-tags-by-macro (form &optional table)
240 "Find tags for which FORM is non-nil in TABLE.
241TABLE is a semantic tags table. See `semantic-something-to-tag-table'."
242 `(let ((tags (semantic-something-to-tag-table ,table))
243 (result nil))
244 (while tags
245 (and ,form
246 (setq result (cons (car tags) result)))
247 (setq tags (cdr tags)))
248 (nreverse result)))
249
250;;; Top level Searches
251;;
252(defsubst semantic-find-first-tag-by-name (name &optional table)
253 "Find the first tag with NAME in TABLE.
254NAME is a string.
255TABLE is a semantic tags table. See `semantic-something-to-tag-table'.
256This routine uses `assoc' to quickly find the first matching entry."
257 (funcall (if semantic-case-fold 'assoc-ignore-case 'assoc)
258 name (semantic-something-to-tag-table table)))
259
260(defmacro semantic-find-tags-by-name (name &optional table)
261 "Find all tags with NAME in TABLE.
262NAME is a string.
263TABLE is a tag table. See `semantic-something-to-tag-table'."
264 `(let ((case-fold-search semantic-case-fold))
265 (semantic--find-tags-by-macro
266 (string= ,name (semantic-tag-name (car tags)))
267 ,table)))
268
269(defmacro semantic-find-tags-for-completion (prefix &optional table)
270 "Find all tags whos name begins with PREFIX in TABLE.
271PREFIX is a string.
272TABLE is a tag table. See `semantic-something-to-tag-table'.
273While it would be nice to use `try-completion' or `all-completions',
274those functions do not return the tags, only a string.
275Uses `compare-strings' for fast comparison."
276 `(let ((l (length ,prefix)))
277 (semantic--find-tags-by-macro
278 (eq (compare-strings ,prefix 0 nil
279 (semantic-tag-name (car tags)) 0 l
280 semantic-case-fold)
281 t)
282 ,table)))
283
284(defmacro semantic-find-tags-by-name-regexp (regexp &optional table)
285 "Find all tags with name matching REGEXP in TABLE.
286REGEXP is a string containing a regular expression,
287TABLE is a tag table. See `semantic-something-to-tag-table'.
288Consider using `semantic-find-tags-for-completion' if you are
289attempting to do completions."
290 `(let ((case-fold-search semantic-case-fold))
291 (semantic--find-tags-by-macro
292 (string-match ,regexp (semantic-tag-name (car tags)))
293 ,table)))
294
295(defmacro semantic-find-tags-by-class (class &optional table)
296 "Find all tags of class CLASS in TABLE.
297CLASS is a symbol representing the class of the token, such as
298'variable, of 'function..
299TABLE is a tag table. See `semantic-something-to-tag-table'."
300 `(semantic--find-tags-by-macro
301 (eq ,class (semantic-tag-class (car tags)))
302 ,table))
303
304(defmacro semantic-find-tags-by-type (type &optional table)
305 "Find all tags of with a type TYPE in TABLE.
306TYPE is a string or tag representing a data type as defined in the
307language the tags were parsed from, such as \"int\", or perhaps
308a tag whose name is that of a struct or class.
309TABLE is a tag table. See `semantic-something-to-tag-table'."
310 `(semantic--find-tags-by-macro
311 (semantic-tag-of-type-p (car tags) ,type)
312 ,table))
313
314(defmacro semantic-find-tags-of-compound-type (&optional table)
315 "Find all tags which are a compound type in TABLE.
316Compound types are structures, or other data type which
317is not of a primitive nature, such as int or double.
318Used in completion."
319 `(semantic--find-tags-by-macro
320 (semantic-tag-type-compound-p (car tags))
321 ,table))
322
323(define-overloadable-function semantic-find-tags-by-scope-protection (scopeprotection parent &optional table)
324 "Find all tags accessable by SCOPEPROTECTION.
325SCOPEPROTECTION is a symbol which can be returned by the method
326`semantic-tag-protection'. A hard-coded order is used to determine a match.
327PARENT is a tag representing the PARENT slot needed for
328`semantic-tag-protection'.
329TABLE is a list of tags (a subset of PARENT members) to scan. If TABLE is nil,
330the type members of PARENT are used.
331See `semantic-tag-protected-p' for details on which tags are returned."
332 (if (not (eq (semantic-tag-class parent) 'type))
333 (signal 'wrong-type-argument '(semantic-find-tags-by-scope-protection
334 parent
335 semantic-tag-class type))
336 (:override)))
337
338(defun semantic-find-tags-by-scope-protection-default
339 (scopeprotection parent &optional table)
340 "Find all tags accessable by SCOPEPROTECTION.
341SCOPEPROTECTION is a symbol which can be returned by the method
342`semantic-tag-protection'. A hard-coded order is used to determine a match.
343PARENT is a tag representing the PARENT slot needed for
344`semantic-tag-protection'.
345TABLE is a list of tags (a subset of PARENT members) to scan. If TABLE is nil,
346the type members of PARENT are used.
347See `semantic-tag-protected-p' for details on which tags are returned."
348 (if (not table) (setq table (semantic-tag-type-members parent)))
349 (if (null scopeprotection)
350 table
351 (semantic--find-tags-by-macro
352 (not (semantic-tag-protected-p (car tags) scopeprotection parent))
353 table)))
354
355(defsubst semantic-find-tags-included (&optional table)
356 "Find all tags in TABLE that are of the 'include class.
357TABLE is a tag table. See `semantic-something-to-tag-table'."
358 (semantic-find-tags-by-class 'include table))
359
360;;; Deep Searches
361
362(defmacro semantic-deep-find-tags-by-name (name &optional table)
363 "Find all tags with NAME in TABLE.
364Search in top level tags, and their components, in TABLE.
365NAME is a string.
366TABLE is a tag table. See `semantic-flatten-tags-table'.
367See also `semantic-find-tags-by-name'."
368 `(semantic-find-tags-by-name
369 ,name (semantic-flatten-tags-table ,table)))
370
371(defmacro semantic-deep-find-tags-for-completion (prefix &optional table)
372 "Find all tags whos name begins with PREFIX in TABLE.
373Search in top level tags, and their components, in TABLE.
374TABLE is a tag table. See `semantic-flatten-tags-table'.
375See also `semantic-find-tags-for-completion'."
376 `(semantic-find-tags-for-completion
377 ,prefix (semantic-flatten-tags-table ,table)))
378
379(defmacro semantic-deep-find-tags-by-name-regexp (regexp &optional table)
380 "Find all tags with name matching REGEXP in TABLE.
381Search in top level tags, and their components, in TABLE.
382REGEXP is a string containing a regular expression,
383TABLE is a tag table. See `semantic-flatten-tags-table'.
384See also `semantic-find-tags-by-name-regexp'.
385Consider using `semantic-deep-find-tags-for-completion' if you are
386attempting to do completions."
387 `(semantic-find-tags-by-name-regexp
388 ,regexp (semantic-flatten-tags-table ,table)))
389
390;;; Specialty Searches
391;;
392(defun semantic-find-tags-external-children-of-type (type &optional table)
393 "Find all tags in whose parent is TYPE in TABLE.
394These tags are defined outside the scope of the original TYPE declaration.
395TABLE is a tag table. See `semantic-something-to-tag-table'."
396 (semantic--find-tags-by-macro
397 (equal (semantic-tag-external-member-parent (car tags))
398 type)
399 table))
400
401(defun semantic-find-tags-subclasses-of-type (type &optional table)
402 "Find all tags of class type in whose parent is TYPE in TABLE.
403These tags are defined outside the scope of the original TYPE declaration.
404TABLE is a tag table. See `semantic-something-to-tag-table'."
405 (semantic--find-tags-by-macro
406 (and (eq (semantic-tag-class (car tags)) 'type)
407 (or (member type (semantic-tag-type-superclasses (car tags)))
408 (member type (semantic-tag-type-interfaces (car tags)))))
409 table))
410
411;;
412;; ************************** Compatibility ***************************
413;;
414
415;;; Old Style Brute Force Search Routines
416;;
417;; These functions will search through tags lists explicity for
418;; desired information.
419
420;; The -by-name nonterminal search can use the built in fcn
421;; `assoc', which is faster than looping ourselves, so we will
422;; not use `semantic-brute-find-tag-by-function' to do this,
423;; instead erroring on the side of speed.
424
425(defun semantic-brute-find-first-tag-by-name
426 (name streamorbuffer &optional search-parts search-include)
427 "Find a tag NAME within STREAMORBUFFER. NAME is a string.
428If SEARCH-PARTS is non-nil, search children of tags.
429If SEARCH-INCLUDE was never implemented.
430
431Use `semantic-find-first-tag-by-name' instead."
432 (let* ((stream (semantic-something-to-tag-table streamorbuffer))
433 (assoc-fun (if semantic-case-fold
434 #'assoc-ignore-case
435 #'assoc))
436 (m (funcall assoc-fun name stream)))
437 (if m
438 m
439 (let ((toklst stream)
440 (children nil))
441 (while (and (not m) toklst)
442 (if search-parts
443 (progn
444 (setq children (semantic-tag-components-with-overlays
445 (car toklst)))
446 (if children
447 (setq m (semantic-brute-find-first-tag-by-name
448 name children search-parts search-include)))))
449 (setq toklst (cdr toklst)))
450 (if (not m)
451 ;; Go to dependencies, and search there.
452 nil)
453 m))))
454
455(defmacro semantic-brute-find-tag-by-class
456 (class streamorbuffer &optional search-parts search-includes)
457 "Find all tags with a class CLASS within STREAMORBUFFER.
458CLASS is a symbol representing the class of the tags to find.
459See `semantic-tag-class'.
460Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
461`semantic-brute-find-tag-by-function'.
462
463Use `semantic-find-tag-by-class' instead."
464 `(semantic-brute-find-tag-by-function
465 (lambda (tag) (eq ,class (semantic-tag-class tag)))
466 ,streamorbuffer ,search-parts ,search-includes))
467
468(defmacro semantic-brute-find-tag-standard
469 (streamorbuffer &optional search-parts search-includes)
470 "Find all tags in STREAMORBUFFER which define simple class types.
471See `semantic-tag-class'.
472Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
473`semantic-brute-find-tag-by-function'."
474 `(semantic-brute-find-tag-by-function
475 (lambda (tag) (member (semantic-tag-class tag)
476 '(function variable type)))
477 ,streamorbuffer ,search-parts ,search-includes))
478
479(defun semantic-brute-find-tag-by-type
480 (type streamorbuffer &optional search-parts search-includes)
481 "Find all tags with type TYPE within STREAMORBUFFER.
482TYPE is a string which is the name of the type of the tags returned.
483See `semantic-tag-type'.
484Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
485`semantic-brute-find-tag-by-function'."
486 (semantic-brute-find-tag-by-function
487 (lambda (tag)
488 (let ((ts (semantic-tag-type tag)))
489 (if (and (listp ts)
490 (or (= (length ts) 1)
491 (eq (semantic-tag-class ts) 'type)))
492 (setq ts (semantic-tag-name ts)))
493 (equal type ts)))
494 streamorbuffer search-parts search-includes))
495
496(defun semantic-brute-find-tag-by-type-regexp
497 (regexp streamorbuffer &optional search-parts search-includes)
498 "Find all tags with type matching REGEXP within STREAMORBUFFER.
499REGEXP is a regular expression which matches the name of the type of the
500tags returned. See `semantic-tag-type'.
501Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
502`semantic-brute-find-tag-by-function'."
503 (semantic-brute-find-tag-by-function
504 (lambda (tag)
505 (let ((ts (semantic-tag-type tag)))
506 (if (listp ts)
507 (setq ts
508 (if (eq (semantic-tag-class ts) 'type)
509 (semantic-tag-name ts)
510 (car ts))))
511 (and ts (string-match regexp ts))))
512 streamorbuffer search-parts search-includes))
513
514(defun semantic-brute-find-tag-by-name-regexp
515 (regex streamorbuffer &optional search-parts search-includes)
516 "Find all tags whose name match REGEX in STREAMORBUFFER.
517Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
518`semantic-brute-find-tag-by-function'."
519 (semantic-brute-find-tag-by-function
520 (lambda (tag) (string-match regex (semantic-tag-name tag)))
521 streamorbuffer search-parts search-includes)
522 )
523
524(defun semantic-brute-find-tag-by-property
525 (property value streamorbuffer &optional search-parts search-includes)
526 "Find all tags with PROPERTY equal to VALUE in STREAMORBUFFER.
527Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
528`semantic-brute-find-tag-by-function'."
529 (semantic-brute-find-tag-by-function
530 (lambda (tag) (equal (semantic--tag-get-property tag property) value))
531 streamorbuffer search-parts search-includes)
532 )
533
534(defun semantic-brute-find-tag-by-attribute
535 (attr streamorbuffer &optional search-parts search-includes)
536 "Find all tags with a given ATTR in STREAMORBUFFER.
537ATTR is a symbol key into the attributes list.
538Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
539`semantic-brute-find-tag-by-function'."
540 (semantic-brute-find-tag-by-function
541 (lambda (tag) (semantic-tag-get-attribute tag attr))
542 streamorbuffer search-parts search-includes)
543 )
544
545(defun semantic-brute-find-tag-by-attribute-value
546 (attr value streamorbuffer &optional search-parts search-includes)
547 "Find all tags with a given ATTR equal to VALUE in STREAMORBUFFER.
548ATTR is a symbol key into the attributes list.
549VALUE is the value that ATTR should match.
550Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
551`semantic-brute-find-tag-by-function'."
552 (semantic-brute-find-tag-by-function
553 (lambda (tag) (equal (semantic-tag-get-attribute tag attr) value))
554 streamorbuffer search-parts search-includes)
555 )
556
557(defun semantic-brute-find-tag-by-function
558 (function streamorbuffer &optional search-parts search-includes)
559 "Find all tags for which FUNCTION's value is non-nil within STREAMORBUFFER.
560FUNCTION must return non-nil if an element of STREAM will be included
561in the new list.
562
563If optional argument SEARCH-PARTS is non-nil, all sub-parts of tags
564are searched. The overloadable function `semantic-tag-componenets' is
565used for the searching child lists. If SEARCH-PARTS is the symbol
566'positiononly, then only children that have positional information are
567searched.
568
569If SEARCH-INCLUDES has not been implemented.
570This parameter hasn't be active for a while and is obsolete."
571 (let ((stream (semantic-something-to-tag-table streamorbuffer))
572 (sl nil) ;list of tag children
573 (nl nil) ;new list
574 (case-fold-search semantic-case-fold))
575 (dolist (tag stream)
576 (if (not (semantic-tag-p tag))
577 ;; `semantic-tag-components-with-overlays' can return invalid
578 ;; tags if search-parts is not equal to 'positiononly
579 nil ;; Ignore them!
580 (if (funcall function tag)
581 (setq nl (cons tag nl)))
582 (and search-parts
583 (setq sl (if (eq search-parts 'positiononly)
584 (semantic-tag-components-with-overlays tag)
585 (semantic-tag-components tag))
586 )
587 (setq nl (nconc nl
588 (semantic-brute-find-tag-by-function
589 function sl
590 search-parts))))))
591 (setq nl (nreverse nl))
592 nl))
593
594(defun semantic-brute-find-first-tag-by-function
595 (function streamorbuffer &optional search-parts search-includes)
596 "Find the first tag which FUNCTION match within STREAMORBUFFER.
597FUNCTION must return non-nil if an element of STREAM will be included
598in the new list.
599
600The following parameters were never implemented.
601
602If optional argument SEARCH-PARTS, all sub-parts of tags are searched.
603The overloadable function `semantic-tag-components' is used for
604searching.
605If SEARCH-INCLUDES is non-nil, then all include files are also
606searched for matches."
607 (let ((stream (semantic-something-to-tag-table streamorbuffer))
608 (found nil)
609 (case-fold-search semantic-case-fold))
610 (while (and (not found) stream)
611 (if (funcall function (car stream))
612 (setq found (car stream)))
613 (setq stream (cdr stream)))
614 found))
615
616
617;;; Old Positional Searches
618;;
619;; Are these useful anymore?
620;;
621(defun semantic-brute-find-tag-by-position (position streamorbuffer
622 &optional nomedian)
623 "Find a tag covering POSITION within STREAMORBUFFER.
624POSITION is a number, or marker. If NOMEDIAN is non-nil, don't do
625the median calculation, and return nil."
626 (save-excursion
627 (if (markerp position) (set-buffer (marker-buffer position)))
628 (let* ((stream (if (bufferp streamorbuffer)
629 (save-excursion
630 (set-buffer streamorbuffer)
631 (semantic-fetch-tags))
632 streamorbuffer))
633 (prev nil)
634 (found nil))
635 (while (and stream (not found))
636 ;; perfect fit
637 (if (and (>= position (semantic-tag-start (car stream)))
638 (<= position (semantic-tag-end (car stream))))
639 (setq found (car stream))
640 ;; Median between to objects.
641 (if (and prev (not nomedian)
642 (>= position (semantic-tag-end prev))
643 (<= position (semantic-tag-start (car stream))))
644 (let ((median (/ (+ (semantic-tag-end prev)
645 (semantic-tag-start (car stream)))
646 2)))
647 (setq found
648 (if (> position median)
649 (car stream)
650 prev)))))
651 ;; Next!!!
652 (setq prev (car stream)
653 stream (cdr stream)))
654 found)))
655
656(defun semantic-brute-find-innermost-tag-by-position
657 (position streamorbuffer &optional nomedian)
658 "Find a list of tags covering POSITION within STREAMORBUFFER.
659POSITION is a number, or marker. If NOMEDIAN is non-nil, don't do
660the median calculation, and return nil.
661This function will find the topmost item, and recurse until no more
662details are available of findable."
663 (let* ((returnme nil)
664 (current (semantic-brute-find-tag-by-position
665 position streamorbuffer nomedian))
666 (nextstream (and current
667 (if (eq (semantic-tag-class current) 'type)
668 (semantic-tag-type-members current)
669 nil))))
670 (while nextstream
671 (setq returnme (cons current returnme))
672 (setq current (semantic-brute-find-tag-by-position
673 position nextstream nomedian))
674 (setq nextstream (and current
675 ;; NOTE TO SELF:
676 ;; Looking at this after several years away,
677 ;; what does this do???
678 (if (eq (semantic-tag-class current) 'token)
679 (semantic-tag-type-members current)
680 nil))))
681 (nreverse (cons current returnme))))
682
683;;; Compatibility Aliases
684(semantic-alias-obsolete 'semantic-find-nonterminal-by-overlay
685 'semantic-find-tag-by-overlay)
686
687(semantic-alias-obsolete 'semantic-find-nonterminal-by-overlay-in-region
688 'semantic-find-tag-by-overlay-in-region)
689
690(semantic-alias-obsolete 'semantic-find-nonterminal-by-overlay-next
691 'semantic-find-tag-by-overlay-next)
692
693(semantic-alias-obsolete 'semantic-find-nonterminal-by-overlay-prev
694 'semantic-find-tag-by-overlay-prev)
695
696(semantic-alias-obsolete 'semantic-find-nonterminal-parent-by-overlay
697 'semantic-find-tag-parent-by-overlay)
698
699(semantic-alias-obsolete 'semantic-current-nonterminal
700 'semantic-current-tag)
701
702(semantic-alias-obsolete 'semantic-current-nonterminal-parent
703 'semantic-current-tag-parent)
704
705(semantic-alias-obsolete 'semantic-current-nonterminal-of-type
706 'semantic-current-tag-of-class)
707
708(semantic-alias-obsolete 'semantic-find-nonterminal-by-name
709 'semantic-brute-find-first-tag-by-name)
710
711(semantic-alias-obsolete 'semantic-find-nonterminal-by-token
712 'semantic-brute-find-tag-by-class)
713
714(semantic-alias-obsolete 'semantic-find-nonterminal-standard
715 'semantic-brute-find-tag-standard)
716
717(semantic-alias-obsolete 'semantic-find-nonterminal-by-type
718 'semantic-brute-find-tag-by-type)
719
720(semantic-alias-obsolete 'semantic-find-nonterminal-by-type-regexp
721 'semantic-brute-find-tag-by-type-regexp)
722
723(semantic-alias-obsolete 'semantic-find-nonterminal-by-name-regexp
724 'semantic-brute-find-tag-by-name-regexp)
725
726(semantic-alias-obsolete 'semantic-find-nonterminal-by-property
727 'semantic-brute-find-tag-by-property)
728
729(semantic-alias-obsolete 'semantic-find-nonterminal-by-extra-spec
730 'semantic-brute-find-tag-by-attribute)
731
732(semantic-alias-obsolete 'semantic-find-nonterminal-by-extra-spec-value
733 'semantic-brute-find-tag-by-attribute-value)
734
735(semantic-alias-obsolete 'semantic-find-nonterminal-by-function
736 'semantic-brute-find-tag-by-function)
737
738(semantic-alias-obsolete 'semantic-find-nonterminal-by-function-first-match
739 'semantic-brute-find-first-tag-by-function)
740
741(semantic-alias-obsolete 'semantic-find-nonterminal-by-position
742 'semantic-brute-find-tag-by-position)
743
744(semantic-alias-obsolete 'semantic-find-innermost-nonterminal-by-position
745 'semantic-brute-find-innermost-tag-by-position)
746
747;;; TESTING
748;;
749(defun semantic-find-benchmark ()
750 "Run some simple benchmarks to see how we are doing.
751Optional argument ARG is the number of iterations to run."
752 (interactive)
753 (require 'benchmark)
754 (let ((f-name nil)
755 (b-name nil)
756 (f-comp)
757 (b-comp)
758 (f-regex)
759 )
760 (garbage-collect)
761 (setq f-name
762 (benchmark-run-compiled
763 1000 (semantic-find-first-tag-by-name "class3"
764 "test/test.cpp")))
765 (garbage-collect)
766 (setq b-name
767 (benchmark-run-compiled
768 1000 (semantic-brute-find-first-tag-by-name "class3"
769 "test/test.cpp")))
770 (garbage-collect)
771 (setq f-comp
772 (benchmark-run-compiled
773 1000 (semantic-find-tags-for-completion "method"
774 "test/test.cpp")))
775 (garbage-collect)
776 (setq b-comp
777 (benchmark-run-compiled
778 1000 (semantic-brute-find-tag-by-name-regexp "^method"
779 "test/test.cpp")))
780 (garbage-collect)
781 (setq f-regex
782 (benchmark-run-compiled
783 1000 (semantic-find-tags-by-name-regexp "^method"
784 "test/test.cpp")))
785
786 (message "Name [new old] [ %.3f %.3f ] Complete [newc/new old] [ %.3f/%.3f %.3f ]"
787 (car f-name) (car b-name)
788 (car f-comp) (car f-regex)
789 (car b-comp))
790 ))
791
792
793(provide 'semantic/find)
794
795;;; semantic-find.el ends here
diff --git a/lisp/cedet/semantic/format.el b/lisp/cedet/semantic/format.el
new file mode 100644
index 00000000000..ad6523f4fa8
--- /dev/null
+++ b/lisp/cedet/semantic/format.el
@@ -0,0 +1,774 @@
1;;; format.el --- Routines for formatting tags
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;; Once a language file has been parsed into a TAG, it is often useful
27;; then display that tag information in browsers, completion engines, or
28;; help routines. The functions and setup in this file provide ways
29;; to reformat a tag into different standard output types.
30;;
31;; In addition, macros for setting up customizable variables that let
32;; the user choose their default format type are also provided.
33;;
34
35;;; Code:
36(eval-when-compile (require 'font-lock))
37(require 'semantic/tag)
38(require 'ezimage)
39
40;;; Tag to text overload functions
41;;
42;; abbreviations, prototypes, and coloring support.
43(defvar semantic-format-tag-functions
44 '(semantic-format-tag-name
45 semantic-format-tag-canonical-name
46 semantic-format-tag-abbreviate
47 semantic-format-tag-summarize
48 semantic-format-tag-summarize-with-file
49 semantic-format-tag-short-doc
50 semantic-format-tag-prototype
51 semantic-format-tag-concise-prototype
52 semantic-format-tag-uml-abbreviate
53 semantic-format-tag-uml-prototype
54 semantic-format-tag-uml-concise-prototype
55 semantic-format-tag-prin1
56 )
57 "List of functions which convert a tag to text.
58Each function must take the parameters TAG &optional PARENT COLOR.
59TAG is the tag to convert.
60PARENT is a parent tag or name which refers to the structure
61or class which contains TAG. PARENT is NOT a class which a TAG
62would claim as a parent.
63COLOR indicates that the generated text should be colored using
64`font-lock'.")
65
66(semantic-varalias-obsolete 'semantic-token->text-functions
67 'semantic-format-tag-functions)
68(defvar semantic-format-tag-custom-list
69 (append '(radio)
70 (mapcar (lambda (f) (list 'const f))
71 semantic-format-tag-functions)
72 '(function))
73 "A List used by customizeable variables to choose a tag to text function.
74Use this variable in the :type field of a customizable variable.")
75
76(semantic-varalias-obsolete 'semantic-token->text-custom-list
77 'semantic-format-tag-custom-list)
78
79(defcustom semantic-format-use-images-flag ezimage-use-images
80 "Non-nil means semantic format functions use images.
81Images can be used as icons instead of some types of text strings."
82 :group 'semantic
83 :type 'boolean)
84
85(defvar semantic-function-argument-separator ","
86 "Text used to separate arguments when creating text from tags.")
87(make-variable-buffer-local 'semantic-function-argument-separator)
88
89(defvar semantic-format-parent-separator "::"
90 "Text used to separate names when between namespaces/classes and functions.")
91(make-variable-buffer-local 'semantic-format-parent-separator)
92
93(defun semantic-test-all-format-tag-functions (&optional arg)
94 "Test all outputs from `semantic-format-tag-functions'.
95Output is generated from the function under `point'.
96Optional argument ARG specifies not to use color."
97 (interactive "P")
98 (semantic-fetch-tags)
99 (let* ((tag (semantic-current-tag))
100 (par (semantic-current-tag-parent))
101 (fns semantic-format-tag-functions))
102 (with-output-to-temp-buffer "*format-tag*"
103 (princ "Tag->format function tests:")
104 (while fns
105 (princ "\n")
106 (princ (car fns))
107 (princ ":\n ")
108 (let ((s (funcall (car fns) tag par (not arg))))
109 (save-excursion
110 (set-buffer "*format-tag*")
111 (goto-char (point-max))
112 (insert s)))
113 (setq fns (cdr fns))))
114 ))
115
116(defvar semantic-format-face-alist
117 `( (function . font-lock-function-name-face)
118 (variable . font-lock-variable-name-face)
119 (type . font-lock-type-face)
120 ;; These are different between Emacsen.
121 (include . ,(if (featurep 'xemacs)
122 'font-lock-preprocessor-face
123 'font-lock-constant-face))
124 (package . ,(if (featurep 'xemacs)
125 'font-lock-preprocessor-face
126 'font-lock-constant-face))
127 ;; Not a tag, but instead a feature of output
128 (label . font-lock-string-face)
129 (comment . font-lock-comment-face)
130 (keyword . font-lock-keyword-face)
131 (abstract . italic)
132 (static . underline)
133 (documentation . font-lock-doc-face)
134 )
135 "Face used to colorize tags of different types.
136Override the value locally if a language supports other tag types.
137When adding new elements, try to use symbols also returned by the parser.
138The form of an entry in this list is of the form:
139 ( SYMBOL . FACE )
140where SYMBOL is a tag type symbol used with semantic. FACE
141is a symbol representing a face.
142Faces used are generated in `font-lock' for consistency, and will not
143be used unless font lock is a feature.")
144
145(semantic-varalias-obsolete 'semantic-face-alist
146 'semantic-format-face-alist)
147
148
149
150;;; Coloring Functions
151;;
152(defun semantic--format-colorize-text (text face-class)
153 "Apply onto TEXT a color associated with FACE-CLASS.
154FACE-CLASS is a tag type found in `semantic-face-alist'. See this variable
155for details on adding new types."
156 (if (featurep 'font-lock)
157 (let ((face (cdr-safe (assoc face-class semantic-format-face-alist)))
158 (newtext (concat text)))
159 (put-text-property 0 (length text) 'face face newtext)
160 newtext)
161 text))
162
163(make-obsolete 'semantic-colorize-text
164 'semantic--format-colorize-text)
165
166(defun semantic--format-colorize-merge-text (precoloredtext face-class)
167 "Apply onto PRECOLOREDTEXT a color associated with FACE-CLASS.
168FACE-CLASS is a tag type found in 'semantic-face-alist'. See this
169variable for details on adding new types."
170 (let ((face (cdr-safe (assoc face-class semantic-format-face-alist)))
171 (newtext (concat precoloredtext))
172 )
173 (if (featurep 'xemacs)
174 (add-text-properties 0 (length newtext) (list 'face face) newtext)
175 (alter-text-property 0 (length newtext) 'face
176 (lambda (current-face)
177 (let ((cf
178 (cond ((facep current-face)
179 (list current-face))
180 ((listp current-face)
181 current-face)
182 (t nil)))
183 (nf
184 (cond ((facep face)
185 (list face))
186 ((listp face)
187 face)
188 (t nil))))
189 (append cf nf)))
190 newtext))
191 newtext))
192
193;;; Function Arguments
194;;
195(defun semantic--format-tag-arguments (args formatter color)
196 "Format the argument list ARGS with FORMATTER.
197FORMATTER is a function used to format a tag.
198COLOR specifies if color should be used."
199 (let ((out nil))
200 (while args
201 (push (if (and formatter
202 (semantic-tag-p (car args))
203 (not (string= (semantic-tag-name (car args)) ""))
204 )
205 (funcall formatter (car args) nil color)
206 (semantic-format-tag-name-from-anything
207 (car args) nil color 'variable))
208 out)
209 (setq args (cdr args)))
210 (mapconcat 'identity (nreverse out) semantic-function-argument-separator)
211 ))
212
213;;; Data Type
214(define-overloadable-function semantic-format-tag-type (tag color)
215 "Convert the data type of TAG to a string usable in tag formatting.
216It is presumed that TYPE is a string or semantic tag.")
217
218(defun semantic-format-tag-type-default (tag color)
219 "Convert the data type of TAG to a string usable in tag formatting.
220Argument COLOR specifies to colorize the text."
221 (let* ((type (semantic-tag-type tag))
222 (out (cond ((semantic-tag-p type)
223 (let* ((typetype (semantic-tag-type type))
224 (name (semantic-tag-name type))
225 (str (if typetype
226 (concat typetype " " name)
227 name)))
228 (if color
229 (semantic--format-colorize-text
230 str
231 'type)
232 str)))
233 ((and (listp type)
234 (stringp (car type)))
235 (car type))
236 ((stringp type)
237 type)
238 (t nil))))
239 (if (and color out)
240 (setq out (semantic--format-colorize-text out 'type))
241 out)
242 ))
243
244
245;;; Abstract formatting functions
246
247(defun semantic-format-tag-prin1 (tag &optional parent color)
248 "Convert TAG to a string that is the print name for TAG.
249PARENT and COLOR are ignored."
250 (format "%S" tag))
251
252(defun semantic-format-tag-name-from-anything (anything &optional
253 parent color
254 colorhint)
255 "Convert just about anything into a name like string.
256Argument ANYTHING is the thing to be converted.
257Optional argument PARENT is the parent type if TAG is a detail.
258Optional argument COLOR means highlight the prototype with font-lock colors.
259Optional COLORHINT is the type of color to use if ANYTHING is not a tag
260with a tag class. See `semantic--format-colorize-text' for a definition
261of FACE-CLASS for which this is used."
262 (cond ((stringp anything)
263 (semantic--format-colorize-text anything colorhint))
264 ((semantic-tag-p anything)
265 (let ((ans (semantic-format-tag-name anything parent color)))
266 ;; If ANS is empty string or nil, then the name wasn't
267 ;; supplied. The implication is as in C where there is a data
268 ;; type but no name for a prototype from an include file, or
269 ;; an argument just wasn't used in the body of the fcn.
270 (if (or (null ans) (string= ans ""))
271 (setq ans (semantic-format-tag-type anything color)))
272 ans))
273 ((and (listp anything)
274 (stringp (car anything)))
275 (semantic--format-colorize-text (car anything) colorhint))))
276
277(define-overloadable-function semantic-format-tag-name (tag &optional parent color)
278 "Return the name string describing TAG.
279The name is the shortest possible representation.
280Optional argument PARENT is the parent type if TAG is a detail.
281Optional argument COLOR means highlight the prototype with font-lock colors.")
282
283(defun semantic-format-tag-name-default (tag &optional parent color)
284 "Return an abbreviated string describing TAG.
285Optional argument PARENT is the parent type if TAG is a detail.
286Optional argument COLOR means highlight the prototype with font-lock colors."
287 (let ((name (semantic-tag-name tag))
288 (destructor
289 (if (eq (semantic-tag-class tag) 'function)
290 (semantic-tag-function-destructor-p tag))))
291 (when destructor
292 (setq name (concat "~" name)))
293 (if color
294 (setq name (semantic--format-colorize-text name (semantic-tag-class tag))))
295 name))
296
297(defun semantic--format-tag-parent-tree (tag parent)
298 "Under Consideration.
299
300Return a list of parents for TAG.
301PARENT is the first parent, or nil. If nil, then an attempt to
302determine PARENT is made.
303Once PARENT is identified, additional parents are looked for.
304The return list first element is the nearest parent, and the last
305item is the first parent which may be a string. The root parent may
306not be the actual first parent as there may just be a failure to find
307local definitions."
308 ;; First, validate the PARENT argument.
309 (unless parent
310 ;; All mechanisms here must be fast as often parent
311 ;; is nil because there isn't one.
312 (setq parent (or (semantic-tag-function-parent tag)
313 (save-excursion
314 (semantic-go-to-tag tag)
315 (semantic-current-tag-parent)))))
316 (when (stringp parent)
317 (setq parent (semantic-find-first-tag-by-name
318 parent (current-buffer))))
319 ;; Try and find a trail of parents from PARENT
320 (let ((rlist (list parent))
321 )
322 ;; IMPLELEMENT ME!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
323 (reverse rlist)))
324
325(define-overloadable-function semantic-format-tag-canonical-name (tag &optional parent color)
326 "Return a canonical name for TAG.
327A canonical name includes the names of any parents or namespaces preceeding
328the tag.
329Optional argument PARENT is the parent type if TAG is a detail.
330Optional argument COLOR means highlight the prototype with font-lock colors.")
331
332(defun semantic-format-tag-canonical-name-default (tag &optional parent color)
333 "Return a canonical name for TAG.
334A canonical name includes the names of any parents or namespaces preceeding
335the tag with colons separating them.
336Optional argument PARENT is the parent type if TAG is a detail.
337Optional argument COLOR means highlight the prototype with font-lock colors."
338 (let ((parent-input-str
339 (if (and parent
340 (semantic-tag-p parent)
341 (semantic-tag-of-class-p parent 'type))
342 (concat
343 ;; Choose a class of 'type as the default parent for something.
344 ;; Just a guess though.
345 (semantic-format-tag-name-from-anything parent nil color 'type)
346 ;; Default separator between class/namespace and others.
347 semantic-format-parent-separator)
348 ""))
349 (tag-parent-str
350 (or (when (and (semantic-tag-of-class-p tag 'function)
351 (semantic-tag-function-parent tag))
352 (concat (semantic-tag-function-parent tag)
353 semantic-format-parent-separator))
354 ""))
355 )
356 (concat parent-input-str
357 tag-parent-str
358 (semantic-format-tag-name tag parent color))
359 ))
360
361(define-overloadable-function semantic-format-tag-abbreviate (tag &optional parent color)
362 "Return an abbreviated string describing TAG.
363The abbreviation is to be short, with possible symbols indicating
364the type of tag, or other information.
365Optional argument PARENT is the parent type if TAG is a detail.
366Optional argument COLOR means highlight the prototype with font-lock colors.")
367
368(defun semantic-format-tag-abbreviate-default (tag &optional parent color)
369 "Return an abbreviated string describing TAG.
370Optional argument PARENT is a parent tag in the tag hierarchy.
371In this case PARENT refers to containment, not inheritance.
372Optional argument COLOR means highlight the prototype with font-lock colors.
373This is a simple C like default."
374 ;; Do lots of complex stuff here.
375 (let ((class (semantic-tag-class tag))
376 (name (semantic-format-tag-canonical-name tag parent color))
377 (suffix "")
378 (prefix "")
379 str)
380 (cond ((eq class 'function)
381 (setq suffix "()"))
382 ((eq class 'include)
383 (setq suffix "<>"))
384 ((eq class 'variable)
385 (setq suffix (if (semantic-tag-variable-default tag)
386 "=" "")))
387 ((eq class 'label)
388 (setq suffix ":"))
389 ((eq class 'code)
390 (setq prefix "{"
391 suffix "}"))
392 ((eq class 'type)
393 (setq suffix "{}"))
394 )
395 (setq str (concat prefix name suffix))
396 str))
397
398;; Semantic 1.2.x had this misspelling. Keep it for backwards compatibiity.
399(semantic-alias-obsolete
400 'semantic-summerize-nonterminal 'semantic-format-tag-summarize)
401
402(define-overloadable-function semantic-format-tag-summarize (tag &optional parent color)
403 "Summarize TAG in a reasonable way.
404Optional argument PARENT is the parent type if TAG is a detail.
405Optional argument COLOR means highlight the prototype with font-lock colors.")
406
407(defun semantic-format-tag-summarize-default (tag &optional parent color)
408 "Summarize TAG in a reasonable way.
409Optional argument PARENT is the parent type if TAG is a detail.
410Optional argument COLOR means highlight the prototype with font-lock colors."
411 (let* ((proto (semantic-format-tag-prototype tag nil color))
412 (names (if parent
413 semantic-symbol->name-assoc-list-for-type-parts
414 semantic-symbol->name-assoc-list))
415 (tsymb (semantic-tag-class tag))
416 (label (capitalize (or (cdr-safe (assoc tsymb names))
417 (symbol-name tsymb)))))
418 (if color
419 (setq label (semantic--format-colorize-text label 'label)))
420 (concat label ": " proto)))
421
422(define-overloadable-function semantic-format-tag-summarize-with-file (tag &optional parent color)
423 "Like `semantic-format-tag-summarize', but with the file name.
424Optional argument PARENT is the parent type if TAG is a detail.
425Optional argument COLOR means highlight the prototype with font-lock colors.")
426
427(defun semantic-format-tag-summarize-with-file-default (tag &optional parent color)
428 "Summarize TAG in a reasonable way.
429Optional argument PARENT is the parent type if TAG is a detail.
430Optional argument COLOR means highlight the prototype with font-lock colors."
431 (let* ((proto (semantic-format-tag-prototype tag nil color))
432 (file (semantic-tag-file-name tag))
433 )
434 ;; Nothing for tag? Try parent.
435 (when (and (not file) (and parent))
436 (setq file (semantic-tag-file-name parent)))
437 ;; Don't include the file name if we can't find one, or it is the
438 ;; same as the current buffer.
439 (if (or (not file)
440 (string= file (buffer-file-name (current-buffer))))
441 proto
442 (setq file (file-name-nondirectory file))
443 (when color
444 (setq file (semantic--format-colorize-text file 'label)))
445 (concat file ": " proto))))
446
447(define-overloadable-function semantic-format-tag-short-doc (tag &optional parent color)
448 "Display a short form of TAG's documentation. (Comments, or docstring.)
449Optional argument PARENT is the parent type if TAG is a detail.
450Optional argument COLOR means highlight the prototype with font-lock colors.")
451
452(defun semantic-format-tag-short-doc-default (tag &optional parent color)
453 "Display a short form of TAG's documentation. (Comments, or docstring.)
454Optional argument PARENT is the parent type if TAG is a detail.
455Optional argument COLOR means highlight the prototype with font-lock colors."
456 (let* ((fname (or (semantic-tag-file-name tag)
457 (when parent (semantic-tag-file-name parent))))
458 (buf (or (semantic-tag-buffer tag)
459 (when parent (semantic-tag-buffer parent))))
460 (doc (semantic-tag-docstring tag buf)))
461 (when (and (not doc) (not buf) fname)
462 ;; If there is no doc, and no buffer, but we have a filename,
463 ;; lets try again.
464 (setq buf (find-file-noselect fname))
465 (setq doc (semantic-tag-docstring tag buf)))
466 (when (not doc)
467 (setq doc (semantic-documentation-for-tag tag))
468 )
469 (setq doc
470 (if (not doc)
471 ;; No doc, use summarize.
472 (semantic-format-tag-summarize tag parent color)
473 ;; We have doc. Can we devise a single line?
474 (if (string-match "$" doc)
475 (substring doc 0 (match-beginning 0))
476 doc)
477 ))
478 (when color
479 (setq doc (semantic--format-colorize-text doc 'documentation)))
480 doc
481 ))
482
483;;; Prototype generation
484;;
485(define-overloadable-function semantic-format-tag-prototype (tag &optional parent color)
486 "Return a prototype for TAG.
487This function should be overloaded, though it need not be used.
488This is because it can be used to create code by language independent
489tools.
490Optional argument PARENT is the parent type if TAG is a detail.
491Optional argument COLOR means highlight the prototype with font-lock colors.")
492
493(defun semantic-format-tag-prototype-default (tag &optional parent color)
494 "Default method for returning a prototype for TAG.
495This will work for C like languages.
496Optional argument PARENT is the parent type if TAG is a detail.
497Optional argument COLOR means highlight the prototype with font-lock colors."
498 (let* ((class (semantic-tag-class tag))
499 (name (semantic-format-tag-name tag parent color))
500 (type (if (member class '(function variable type))
501 (semantic-format-tag-type tag color)))
502 (args (if (member class '(function type))
503 (semantic--format-tag-arguments
504 (if (eq class 'function)
505 (semantic-tag-function-arguments tag)
506 (list "")
507 ;;(semantic-tag-type-members tag)
508 )
509 #'semantic-format-tag-prototype
510 color)))
511 (const (semantic-tag-get-attribute tag :constant-flag))
512 (tm (semantic-tag-get-attribute tag :typemodifiers))
513 (mods (append
514 (if const '("const") nil)
515 (cond ((stringp tm) (list tm))
516 ((consp tm) tm)
517 (t nil))
518 ))
519 (array (if (eq class 'variable)
520 (let ((deref
521 (semantic-tag-get-attribute
522 tag :dereference))
523 (r ""))
524 (while (and deref (/= deref 0))
525 (setq r (concat r "[]")
526 deref (1- deref)))
527 r)))
528 )
529 (if args
530 (setq args
531 (concat " "
532 (if (eq class 'type) "{" "(")
533 args
534 (if (eq class 'type) "}" ")"))))
535 (when mods
536 (setq mods (concat (mapconcat 'identity mods " ") " ")))
537 (concat (or mods "")
538 (if type (concat type " "))
539 name
540 (or args "")
541 (or array ""))))
542
543(define-overloadable-function semantic-format-tag-concise-prototype (tag &optional parent color)
544 "Return a concise prototype for TAG.
545Optional argument PARENT is the parent type if TAG is a detail.
546Optional argument COLOR means highlight the prototype with font-lock colors.")
547
548(defun semantic-format-tag-concise-prototype-default (tag &optional parent color)
549 "Return a concise prototype for TAG.
550This default function will make a cheap concise prototype using C like syntax.
551Optional argument PARENT is the parent type if TAG is a detail.
552Optional argument COLOR means highlight the prototype with font-lock colors."
553 (let ((class (semantic-tag-class tag)))
554 (cond
555 ((eq class 'type)
556 (concat (semantic-format-tag-name tag parent color) "{}"))
557 ((eq class 'function)
558 (concat (semantic-format-tag-name tag parent color)
559 " ("
560 (semantic--format-tag-arguments
561 (semantic-tag-function-arguments tag)
562 'semantic-format-tag-concise-prototype
563 color)
564 ")"))
565 ((eq class 'variable)
566 (let* ((deref (semantic-tag-get-attribute
567 tag :dereference))
568 (array "")
569 )
570 (while (and deref (/= deref 0))
571 (setq array (concat array "[]")
572 deref (1- deref)))
573 (concat (semantic-format-tag-name tag parent color)
574 array)))
575 (t
576 (semantic-format-tag-abbreviate tag parent color)))))
577
578;;; UML display styles
579;;
580(defcustom semantic-uml-colon-string " : "
581 "*String used as a color separator between parts of a UML string.
582In UML, a variable may appear as `varname : type'.
583Change this variable to change the output separator."
584 :group 'semantic
585 :type 'string)
586
587(defcustom semantic-uml-no-protection-string ""
588 "*String used to describe when no protection is specified.
589Used by `semantic-format-tag-uml-protection-to-string'."
590 :group 'semantic
591 :type 'string)
592
593(defun semantic--format-uml-post-colorize (text tag parent)
594 "Add color to TEXT created from TAG and PARENT.
595Adds augmentation for `abstract' and `static' entries."
596 (if (semantic-tag-abstract-p tag parent)
597 (setq text (semantic--format-colorize-merge-text text 'abstract)))
598 (if (semantic-tag-static-p tag parent)
599 (setq text (semantic--format-colorize-merge-text text 'static)))
600 text
601 )
602
603(defun semantic-uml-attribute-string (tag &optional parent)
604 "Return a string for TAG, a child of PARENT representing a UML attribute.
605UML attribute strings are things like {abstract} or {leaf}."
606 (cond ((semantic-tag-abstract-p tag parent)
607 "{abstract}")
608 ((semantic-tag-leaf-p tag parent)
609 "{leaf}")
610 ))
611
612(defvar semantic-format-tag-protection-image-alist
613 '(("+" . ezimage-unlock)
614 ("#" . ezimage-key)
615 ("-" . ezimage-lock)
616 )
617 "Association of protection strings, and images to use.")
618
619(defvar semantic-format-tag-protection-symbol-to-string-assoc-list
620 '((public . "+")
621 (protected . "#")
622 (private . "-")
623 )
624 "Association list of the form (SYMBOL . \"STRING\") for protection symbols.
625This associates a symbol, such as 'public with the st ring \"+\".")
626
627(define-overloadable-function semantic-format-tag-uml-protection-to-string (protection-symbol color)
628 "Convert PROTECTION-SYMBOL to a string for UML.
629By default, uses `semantic-format-tag-protection-symbol-to-string-assoc-list'
630to convert.
631By defaul character returns are:
632 public -- +
633 private -- -
634 protected -- #.
635If PROTECTION-SYMBOL is unknown, then the return value is
636`semantic-uml-no-protection-string'.
637COLOR indicates if we should use an image on the text.")
638
639(defun semantic-format-tag-uml-protection-to-string-default (protection-symbol color)
640 "Convert PROTECTION-SYMBOL to a string for UML.
641Uses `semantic-format-tag-protection-symbol-to-string-assoc-list' to convert.
642If PROTECTION-SYMBOL is unknown, then the return value is
643`semantic-uml-no-protection-string'.
644COLOR indicates if we should use an image on the text."
645 (let* ((ezimage-use-images (and semantic-format-use-images-flag color))
646 (key (assoc protection-symbol
647 semantic-format-tag-protection-symbol-to-string-assoc-list))
648 (str (or (cdr-safe key) semantic-uml-no-protection-string)))
649 (ezimage-image-over-string
650 (copy-sequence str) ; make a copy to keep the original pristine.
651 semantic-format-tag-protection-image-alist)))
652
653(defsubst semantic-format-tag-uml-protection (tag parent color)
654 "Retrieve the protection string for TAG with PARENT.
655Argument COLOR specifies that color should be added to the string as
656needed."
657 (semantic-format-tag-uml-protection-to-string
658 (semantic-tag-protection tag parent)
659 color))
660
661(defun semantic--format-tag-uml-type (tag color)
662 "Format the data type of TAG to a string usable for formatting.
663COLOR indicates if it should be colorized."
664 (let ((str (semantic-format-tag-type tag color)))
665 (if str
666 (concat semantic-uml-colon-string str))))
667
668(define-overloadable-function semantic-format-tag-uml-abbreviate (tag &optional parent color)
669 "Return a UML style abbreviation for TAG.
670Optional argument PARENT is the parent type if TAG is a detail.
671Optional argument COLOR means highlight the prototype with font-lock colors.")
672
673(defun semantic-format-tag-uml-abbreviate-default (tag &optional parent color)
674 "Return a UML style abbreviation for TAG.
675Optional argument PARENT is the parent type if TAG is a detail.
676Optional argument COLOR means highlight the prototype with font-lock colors."
677 (let* ((name (semantic-format-tag-name tag parent color))
678 (type (semantic--format-tag-uml-type tag color))
679 (protstr (semantic-format-tag-uml-protection tag parent color))
680 (text nil))
681 (setq text
682 (concat
683 protstr
684 (if type (concat name type)
685 name)))
686 (if color
687 (setq text (semantic--format-uml-post-colorize text tag parent)))
688 text))
689
690(define-overloadable-function semantic-format-tag-uml-prototype (tag &optional parent color)
691 "Return a UML style prototype for TAG.
692Optional argument PARENT is the parent type if TAG is a detail.
693Optional argument COLOR means highlight the prototype with font-lock colors.")
694
695(defun semantic-format-tag-uml-prototype-default (tag &optional parent color)
696 "Return a UML style prototype for TAG.
697Optional argument PARENT is the parent type if TAG is a detail.
698Optional argument COLOR means highlight the prototype with font-lock colors."
699 (let* ((class (semantic-tag-class tag))
700 (cp (semantic-format-tag-name tag parent color))
701 (type (semantic--format-tag-uml-type tag color))
702 (prot (semantic-format-tag-uml-protection tag parent color))
703 (argtext
704 (cond ((eq class 'function)
705 (concat
706 " ("
707 (semantic--format-tag-arguments
708 (semantic-tag-function-arguments tag)
709 #'semantic-format-tag-uml-prototype
710 color)
711 ")"))
712 ((eq class 'type)
713 "{}")))
714 (text nil))
715 (setq text (concat prot cp argtext type))
716 (if color
717 (setq text (semantic--format-uml-post-colorize text tag parent)))
718 text
719 ))
720
721(define-overloadable-function semantic-format-tag-uml-concise-prototype (tag &optional parent color)
722 "Return a UML style concise prototype for TAG.
723Optional argument PARENT is the parent type if TAG is a detail.
724Optional argument COLOR means highlight the prototype with font-lock colors.")
725
726(defun semantic-format-tag-uml-concise-prototype-default (tag &optional parent color)
727 "Return a UML style concise prototype for TAG.
728Optional argument PARENT is the parent type if TAG is a detail.
729Optional argument COLOR means highlight the prototype with font-lock colors."
730 (let* ((cp (semantic-format-tag-concise-prototype tag parent color))
731 (type (semantic--format-tag-uml-type tag color))
732 (prot (semantic-format-tag-uml-protection tag parent color))
733 (text nil)
734 )
735 (setq text (concat prot cp type))
736 (if color
737 (setq text (semantic--format-uml-post-colorize text tag parent)))
738 text
739 ))
740
741
742;;; Compatibility and aliases
743;;
744(semantic-alias-obsolete 'semantic-prin1-nonterminal
745 'semantic-format-tag-prin1)
746
747(semantic-alias-obsolete 'semantic-name-nonterminal
748 'semantic-format-tag-name)
749
750(semantic-alias-obsolete 'semantic-abbreviate-nonterminal
751 'semantic-format-tag-abbreviate)
752
753(semantic-alias-obsolete 'semantic-summarize-nonterminal
754 'semantic-format-tag-summarize)
755
756(semantic-alias-obsolete 'semantic-prototype-nonterminal
757 'semantic-format-tag-prototype)
758
759(semantic-alias-obsolete 'semantic-concise-prototype-nonterminal
760 'semantic-format-tag-concise-prototype)
761
762(semantic-alias-obsolete 'semantic-uml-abbreviate-nonterminal
763 'semantic-format-tag-uml-abbreviate)
764
765(semantic-alias-obsolete 'semantic-uml-prototype-nonterminal
766 'semantic-format-tag-uml-prototype)
767
768(semantic-alias-obsolete 'semantic-uml-concise-prototype-nonterminal
769 'semantic-format-tag-uml-concise-prototype)
770
771
772(provide 'semantic/format)
773
774;;; semantic-format.el ends here
diff --git a/lisp/cedet/semantic/sort.el b/lisp/cedet/semantic/sort.el
new file mode 100644
index 00000000000..7fa08530672
--- /dev/null
+++ b/lisp/cedet/semantic/sort.el
@@ -0,0 +1,592 @@
1;;; sort.el --- Utilities for sorting and re-arranging 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;; Tag tables originate in the order they appear in a buffer, or source file.
27;; It is often useful to re-arrange them is some predictable way for browsing
28;; purposes. Re-organization may be alphabetical, or even a complete
29;; reorganization of parents and children.
30;;
31;; Originally written in semantic-util.el
32;;
33
34(require 'assoc)
35(require 'semantic)
36(require 'semantic/db)
37(eval-when-compile
38 (require 'semantic/find)
39 (require 'semantic/db-find))
40
41;;; Alphanumeric sorting
42;;
43;; Takes a list of tags, and sorts them in a case-insensitive way
44;; at a single level.
45
46;;; Code:
47(defun semantic-string-lessp-ci (s1 s2)
48 "Case insensitive version of `string-lessp'.
49Argument S1 and S2 are the strings to compare."
50 ;; Use downcase instead of upcase because an average name
51 ;; has more lower case characters.
52 (if (fboundp 'compare-strings)
53 (eq (compare-strings s1 0 nil s2 0 nil t) -1)
54 (string-lessp (downcase s1) (downcase s2))))
55
56(defun semantic-sort-tag-type (tag)
57 "Return a type string for TAG guaranteed to be a string."
58 (let ((ty (semantic-tag-type tag)))
59 (cond ((stringp ty)
60 ty)
61 ((listp ty)
62 (or (car ty) ""))
63 (t ""))))
64
65(defun semantic-tag-lessp-name-then-type (A B)
66 "Return t if tag A is < tag B.
67First sorts on name, then sorts on the name of the :type of
68each tag."
69 (let ((na (semantic-tag-name A))
70 (nb (semantic-tag-name B))
71 )
72 (if (string-lessp na nb)
73 t ; a sure thing.
74 (if (string= na nb)
75 ;; If equal, test the :type which might be different.
76 (let* ((ta (semantic-tag-type A))
77 (tb (semantic-tag-type B))
78 (tas (cond ((stringp ta)
79 ta)
80 ((semantic-tag-p ta)
81 (semantic-tag-name ta))
82 (t nil)))
83 (tbs (cond ((stringp tb)
84 tb)
85 ((semantic-tag-p tb)
86 (semantic-tag-name tb))
87 (t nil))))
88 (if (and (stringp tas) (stringp tbs))
89 (string< tas tbs)
90 ;; This is if A == B, and no types in A or B
91 nil))
92 ;; This nil is if A > B, but not =
93 nil))))
94
95(defun semantic-sort-tags-by-name-increasing (tags)
96 "Sort TAGS by name in increasing order with side effects.
97Return the sorted list."
98 (sort tags (lambda (a b)
99 (string-lessp (semantic-tag-name a)
100 (semantic-tag-name b)))))
101
102(defun semantic-sort-tags-by-name-decreasing (tags)
103 "Sort TAGS by name in decreasing order with side effects.
104Return the sorted list."
105 (sort tags (lambda (a b)
106 (string-lessp (semantic-tag-name b)
107 (semantic-tag-name a)))))
108
109(defun semantic-sort-tags-by-type-increasing (tags)
110 "Sort TAGS by type in increasing order with side effects.
111Return the sorted list."
112 (sort tags (lambda (a b)
113 (string-lessp (semantic-sort-tag-type a)
114 (semantic-sort-tag-type b)))))
115
116(defun semantic-sort-tags-by-type-decreasing (tags)
117 "Sort TAGS by type in decreasing order with side effects.
118Return the sorted list."
119 (sort tags (lambda (a b)
120 (string-lessp (semantic-sort-tag-type b)
121 (semantic-sort-tag-type a)))))
122
123(defun semantic-sort-tags-by-name-increasing-ci (tags)
124 "Sort TAGS by name in increasing order with side effects.
125Return the sorted list."
126 (sort tags (lambda (a b)
127 (semantic-string-lessp-ci (semantic-tag-name a)
128 (semantic-tag-name b)))))
129
130(defun semantic-sort-tags-by-name-decreasing-ci (tags)
131 "Sort TAGS by name in decreasing order with side effects.
132Return the sorted list."
133 (sort tags (lambda (a b)
134 (semantic-string-lessp-ci (semantic-tag-name b)
135 (semantic-tag-name a)))))
136
137(defun semantic-sort-tags-by-type-increasing-ci (tags)
138 "Sort TAGS by type in increasing order with side effects.
139Return the sorted list."
140 (sort tags (lambda (a b)
141 (semantic-string-lessp-ci (semantic-sort-tag-type a)
142 (semantic-sort-tag-type b)))))
143
144(defun semantic-sort-tags-by-type-decreasing-ci (tags)
145 "Sort TAGS by type in decreasing order with side effects.
146Return the sorted list."
147 (sort tags (lambda (a b)
148 (semantic-string-lessp-ci (semantic-sort-tag-type b)
149 (semantic-sort-tag-type a)))))
150
151(defun semantic-sort-tags-by-name-then-type-increasing (tags)
152 "Sort TAGS by name, then type in increasing order with side effects.
153Return the sorted list."
154 (sort tags (lambda (a b) (semantic-tag-lessp-name-then-type a b))))
155
156(defun semantic-sort-tags-by-name-then-type-decreasing (tags)
157 "Sort TAGS by name, then type in increasing order with side effects.
158Return the sorted list."
159 (sort tags (lambda (a b) (semantic-tag-lessp-name-then-type b a))))
160
161
162(semantic-alias-obsolete 'semantic-sort-tokens-by-name-increasing
163 'semantic-sort-tags-by-name-increasing)
164(semantic-alias-obsolete 'semantic-sort-tokens-by-name-decreasing
165 'semantic-sort-tags-by-name-decreasing)
166(semantic-alias-obsolete 'semantic-sort-tokens-by-type-increasing
167 'semantic-sort-tags-by-type-increasing)
168(semantic-alias-obsolete 'semantic-sort-tokens-by-type-decreasing
169 'semantic-sort-tags-by-type-decreasing)
170(semantic-alias-obsolete 'semantic-sort-tokens-by-name-increasing-ci
171 'semantic-sort-tags-by-name-increasing-ci)
172(semantic-alias-obsolete 'semantic-sort-tokens-by-name-decreasing-ci
173 'semantic-sort-tags-by-name-decreasing-ci)
174(semantic-alias-obsolete 'semantic-sort-tokens-by-type-increasing-ci
175 'semantic-sort-tags-by-type-increasing-ci)
176(semantic-alias-obsolete 'semantic-sort-tokens-by-type-decreasing-ci
177 'semantic-sort-tags-by-type-decreasing-ci)
178
179
180;;; Unique
181;;
182;; Scan a list of tags, removing duplicates.
183;; This must first sort the tags by name alphabetically ascending.
184;;
185;; Useful for completion lists, or other situations where the
186;; other data isn't as useful.
187
188(defun semantic-unique-tag-table-by-name (tags)
189 "Scan a list of TAGS, removing duplicate names.
190This must first sort the tags by name alphabetically ascending.
191For more complex uniqueness testing used by the semanticdb
192typecaching system, see `semanticdb-typecache-merge-streams'."
193 (let ((sorted (semantic-sort-tags-by-name-increasing
194 (copy-sequence tags)))
195 (uniq nil))
196 (while sorted
197 (if (or (not uniq)
198 (not (string= (semantic-tag-name (car sorted))
199 (semantic-tag-name (car uniq)))))
200 (setq uniq (cons (car sorted) uniq)))
201 (setq sorted (cdr sorted))
202 )
203 (nreverse uniq)))
204
205(defun semantic-unique-tag-table (tags)
206 "Scan a list of TAGS, removing duplicates.
207This must first sort the tags by position ascending.
208TAGS are removed only if they are equivalent, as can happen when
209multiple tag sources are scanned.
210For more complex uniqueness testing used by the semanticdb
211typecaching system, see `semanticdb-typecache-merge-streams'."
212 (let ((sorted (sort (copy-sequence tags)
213 (lambda (a b)
214 (cond ((not (semantic-tag-with-position-p a))
215 t)
216 ((not (semantic-tag-with-position-p b))
217 nil)
218 (t
219 (< (semantic-tag-start a)
220 (semantic-tag-start b)))))))
221 (uniq nil))
222 (while sorted
223 (if (or (not uniq)
224 (not (semantic-equivalent-tag-p (car sorted) (car uniq))))
225 (setq uniq (cons (car sorted) uniq)))
226 (setq sorted (cdr sorted))
227 )
228 (nreverse uniq)))
229
230
231;;; Tag Table Flattening
232;;
233;; In the 1.4 search API, there was a parameter "search-parts" which
234;; was used to find tags inside other tags. This was used
235;; infrequently, mostly for completion/jump routines. These types
236;; of commands would be better off with a flattened list, where all
237;; tags appear at the top level.
238
239(defun semantic-flatten-tags-table (&optional table)
240 "Flatten the tags table TABLE.
241All tags in TABLE, and all components of top level tags
242in TABLE will appear at the top level of list.
243Tags promoted to the top of the list will still appear
244unmodified as components of their parent tags."
245 (let* ((table (semantic-something-to-tag-table table))
246 ;; Initialize the starting list with our table.
247 (lists (list table)))
248 (mapc (lambda (tag)
249 (let ((components (semantic-tag-components tag)))
250 (if (and components
251 ;; unpositined tags can be hazardous to
252 ;; completion. Do we need any type of tag
253 ;; here? - EL
254 (semantic-tag-with-position-p (car components)))
255 (setq lists (cons
256 (semantic-flatten-tags-table components)
257 lists)))))
258 table)
259 (apply 'append (nreverse lists))
260 ))
261
262
263;;; Buckets:
264;;
265;; A list of tags can be grouped into buckets based on the tag class.
266;; Bucketize means to take a list of tags at a given level in a tag
267;; table, and reorganize them into buckets based on class.
268;;
269(defvar semantic-bucketize-tag-class
270 ;; Must use lambda because `semantic-tag-class' is a macro.
271 (lambda (tok) (semantic-tag-class tok))
272 "Function used to get a symbol describing the class of a tag.
273This function must take one argument of a semantic tag.
274It should return a symbol found in `semantic-symbol->name-assoc-list'
275which `semantic-bucketize' uses to bin up tokens.
276To create new bins for an application augment
277`semantic-symbol->name-assoc-list', and
278`semantic-symbol->name-assoc-list-for-type-parts' in addition
279to setting this variable (locally in your function).")
280
281(defun semantic-bucketize (tags &optional parent filter)
282 "Sort TAGS into a group of buckets based on tag class.
283Unknown classes are placed in a Misc bucket.
284Type bucket names are defined by either `semantic-symbol->name-assoc-list'.
285If PARENT is specified, then TAGS belong to this PARENT in some way.
286This will use `semantic-symbol->name-assoc-list-for-type-parts' to
287generate bucket names.
288Optional argument FILTER is a filter function to be applied to each bucket.
289The filter function will take one argument, which is a list of tokens, and
290may re-organize the list with side-effects."
291 (let* ((name-list (if parent
292 semantic-symbol->name-assoc-list-for-type-parts
293 semantic-symbol->name-assoc-list))
294 (sn name-list)
295 (bins (make-vector (1+ (length sn)) nil))
296 ask tagtype
297 (nsn nil)
298 (num 1)
299 (out nil))
300 ;; Build up the bucket vector
301 (while sn
302 (setq nsn (cons (cons (car (car sn)) num) nsn)
303 sn (cdr sn)
304 num (1+ num)))
305 ;; Place into buckets
306 (while tags
307 (setq tagtype (funcall semantic-bucketize-tag-class (car tags))
308 ask (assq tagtype nsn)
309 num (or (cdr ask) 0))
310 (aset bins num (cons (car tags) (aref bins num)))
311 (setq tags (cdr tags)))
312 ;; Remove from buckets into a list.
313 (setq num 1)
314 (while (< num (length bins))
315 (when (aref bins num)
316 (setq out
317 (cons (cons
318 (cdr (nth (1- num) name-list))
319 ;; Filtering, First hacked by David Ponce david@dponce.com
320 (funcall (or filter 'nreverse) (aref bins num)))
321 out)))
322 (setq num (1+ num)))
323 (if (aref bins 0)
324 (setq out (cons (cons "Misc"
325 (funcall (or filter 'nreverse) (aref bins 0)))
326 out)))
327 (nreverse out)))
328
329;;; Adoption
330;;
331;; Some languages allow children of a type to be defined outside
332;; the syntactic scope of that class. These routines will find those
333;; external members, and bring them together in a cloned copy of the
334;; class tag.
335;;
336(defvar semantic-orphaned-member-metaparent-type "class"
337 "In `semantic-adopt-external-members', the type of 'type for metaparents.
338A metaparent is a made-up type semantic token used to hold the child list
339of orphaned members of a named type.")
340(make-variable-buffer-local 'semantic-orphaned-member-metaparent-type)
341
342(defvar semantic-mark-external-member-function nil
343 "Function called when an externally defined orphan is found.
344By default, the token is always marked with the `adopted' property.
345This function should be locally bound by a program that needs
346to add additional behaviors into the token list.
347This function is called with two arguments. The first is TOKEN which is
348a shallow copy of the token to be modified. The second is the PARENT
349which is adopting TOKEN. This function should return TOKEN (or a copy of it)
350which is then integrated into the revised token list.")
351
352(defun semantic-adopt-external-members (tags)
353 "Rebuild TAGS so that externally defined members are regrouped.
354Some languages such as C++ and CLOS permit the declaration of member
355functions outside the definition of the class. It is easier to study
356the structure of a program when such methods are grouped together
357more logically.
358
359This function uses `semantic-tag-external-member-p' to
360determine when a potential child is an externally defined member.
361
362Note: Applications which use this function must account for token
363types which do not have a position, but have children which *do*
364have positions.
365
366Applications should use `semantic-mark-external-member-function'
367to modify all tags which are found as externally defined to some
368type. For example, changing the token type for generating extra
369buckets with the bucket function."
370 (let ((parent-buckets nil)
371 (decent-list nil)
372 (out nil)
373 (tmp nil)
374 )
375 ;; Rebuild the output list, stripping out all parented
376 ;; external entries
377 (while tags
378 (cond
379 ((setq tmp (semantic-tag-external-member-parent (car tags)))
380 (let ((tagcopy (semantic-tag-clone (car tags)))
381 (a (assoc tmp parent-buckets)))
382 (semantic--tag-put-property-no-side-effect tagcopy 'adopted t)
383 (if a
384 ;; If this parent is already in the list, append.
385 (setcdr (nthcdr (1- (length a)) a) (list tagcopy))
386 ;; If not, prepend this new parent bucket into our list
387 (setq parent-buckets
388 (cons (cons tmp (list tagcopy)) parent-buckets)))
389 ))
390 ((eq (semantic-tag-class (car tags)) 'type)
391 ;; Types need to be rebuilt from scratch so we can add in new
392 ;; children to the child list. Only the top-level cons
393 ;; cells need to be duplicated so we can hack out the
394 ;; child list later.
395 (setq out (cons (semantic-tag-clone (car tags)) out))
396 (setq decent-list (cons (car out) decent-list))
397 )
398 (t
399 ;; Otherwise, append this tag to our new output list.
400 (setq out (cons (car tags) out)))
401 )
402 (setq tags (cdr tags)))
403 ;; Rescan out, by descending into all types and finding parents
404 ;; for all entries moved into the parent-buckets.
405 (while decent-list
406 (let* ((bucket (assoc (semantic-tag-name (car decent-list))
407 parent-buckets))
408 (bucketkids (cdr bucket)))
409 (when bucket
410 ;; Run our secondary marking function on the children
411 (if semantic-mark-external-member-function
412 (setq bucketkids
413 (mapcar (lambda (tok)
414 (funcall semantic-mark-external-member-function
415 tok (car decent-list)))
416 bucketkids)))
417 ;; We have some extra kids. Merge.
418 (semantic-tag-put-attribute
419 (car decent-list) :members
420 (append (semantic-tag-type-members (car decent-list))
421 bucketkids))
422 ;; Nuke the bucket label so it is not found again.
423 (setcar bucket nil))
424 (setq decent-list
425 (append (cdr decent-list)
426 ;; get embedded types to scan and make copies
427 ;; of them.
428 (mapcar
429 (lambda (tok) (semantic-tag-clone tok))
430 (semantic-find-tags-by-class 'type
431 (semantic-tag-type-members (car decent-list)))))
432 )))
433 ;; Scan over all remaining lost external methods, and tack them
434 ;; onto the end.
435 (while parent-buckets
436 (if (car (car parent-buckets))
437 (let* ((tmp (car parent-buckets))
438 (fauxtag (semantic-tag-new-type
439 (car tmp)
440 semantic-orphaned-member-metaparent-type
441 nil ;; Part list
442 nil ;; parents (unknown)
443 ))
444 (bucketkids (cdr tmp)))
445 (semantic-tag-set-faux fauxtag) ;; properties
446 (if semantic-mark-external-member-function
447 (setq bucketkids
448 (mapcar (lambda (tok)
449 (funcall semantic-mark-external-member-function
450 tok fauxtag))
451 bucketkids)))
452 (semantic-tag-put-attribute fauxtag :members bucketkids)
453 ;; We have a bunch of methods with no parent in this file.
454 ;; Create a meta-type to hold it.
455 (setq out (cons fauxtag out))
456 ))
457 (setq parent-buckets (cdr parent-buckets)))
458 ;; Return the new list.
459 (nreverse out)))
460
461
462;;; External children
463;;
464;; In order to adopt external children, we need a few overload methods
465;; to enable the feature.
466;;
467(define-overloadable-function semantic-tag-external-member-parent (tag)
468 "Return a parent for TAG when TAG is an external member.
469TAG is an external member if it is defined at a toplevel and
470has some sort of label defining a parent. The parent return will
471be a string.
472
473The default behavior, if not overridden with
474`tag-member-parent' gets the 'parent extra
475specifier of TAG.
476
477If this function is overridden, use
478`semantic-tag-external-member-parent-default' to also
479include the default behavior, and merely extend your own."
480 )
481
482(defun semantic-tag-external-member-parent-default (tag)
483 "Return the name of TAGs parent only if TAG is not defined in it's parent."
484 ;; Use only the extra spec because a type has a parent which
485 ;; means something completely different.
486 (let ((tp (semantic-tag-get-attribute tag :parent)))
487 (when (stringp tp)
488 tp)
489 ))
490
491(semantic-alias-obsolete 'semantic-nonterminal-external-member-parent
492 'semantic-tag-external-member-parent)
493
494(define-overloadable-function semantic-tag-external-member-p (parent tag)
495 "Return non-nil if PARENT is the parent of TAG.
496TAG is an external member of PARENT when it is somehow tagged
497as having PARENT as it's parent.
498PARENT and TAG must both be semantic tags.
499
500The default behavior, if not overridden with
501`tag-external-member-p' is to match :parent attribute in
502the name of TAG.
503
504If this function is overridden, use
505`semantic-tag-external-member-children-p-default' to also
506include the default behavior, and merely extend your own."
507 )
508
509(defun semantic-tag-external-member-p-default (parent tag)
510 "Return non-nil if PARENT is the parent of TAG."
511 ;; Use only the extra spec because a type has a parent which
512 ;; means something completely different.
513 (let ((tp (semantic-tag-external-member-parent tag)))
514 (and (stringp tp)
515 (string= (semantic-tag-name parent) tp))
516 ))
517
518(semantic-alias-obsolete 'semantic-nonterminal-external-member-p
519 'semantic-tag-external-member-p)
520
521(define-overloadable-function semantic-tag-external-member-children (tag &optional usedb)
522 "Return the list of children which are not *in* TAG.
523If optional argument USEDB is non-nil, then also search files in
524the Semantic Database. If USEDB is a list of databases, search those
525databases.
526
527Children in this case are functions or types which are members of
528TAG, such as the parts of a type, but which are not defined inside
529the class. C++ and CLOS both permit methods of a class to be defined
530outside the bounds of the class' definition.
531
532The default behavior, if not overridden with
533`tag-external-member-children' is to search using
534`semantic-tag-external-member-p' in all top level definitions
535with a parent of TAG.
536
537If this function is overridden, use
538`semantic-tag-external-member-children-default' to also
539include the default behavior, and merely extend your own."
540 )
541
542(defun semantic-tag-external-member-children-default (tag &optional usedb)
543 "Return list of external children for TAG.
544Optional argument USEDB specifies if the semantic database is used.
545See `semantic-tag-external-member-children' for details."
546 (if (and usedb
547 (fboundp 'semanticdb-minor-mode-p)
548 (semanticdb-minor-mode-p))
549 (let ((m (semanticdb-find-tags-external-children-of-type
550 (semantic-tag-name tag))))
551 (if m (apply #'append (mapcar #'cdr m))))
552 (semantic--find-tags-by-function
553 `(lambda (tok)
554 ;; This bit of annoying backquote forces the contents of
555 ;; tag into the generated lambda.
556 (semantic-tag-external-member-p ',tag tok))
557 (current-buffer))
558 ))
559
560(define-overloadable-function semantic-tag-external-class (tag)
561 "Return a list of real tags that faux TAG might represent.
562
563In some languages, a method can be defined on an object which is
564not in the same file. In this case,
565`semantic-adopt-external-members' will create a faux-tag. If it
566is necessary to get the tag from which for faux TAG was most
567likely derived, then this function is needed."
568 (unless (semantic-tag-faux-p tag)
569 (signal 'wrong-type-argument (list tag 'semantic-tag-faux-p)))
570 (:override)
571 )
572
573(defun semantic-tag-external-class-default (tag)
574 "Return a list of real tags that faux TAG might represent.
575See `semantic-tag-external-class' for details."
576 (if (and (fboundp 'semanticdb-minor-mode-p)
577 (semanticdb-minor-mode-p))
578 (let* ((semanticdb-search-system-databases nil)
579 (m (semanticdb-find-tags-by-class
580 (semantic-tag-class tag)
581 (semanticdb-find-tags-by-name (semantic-tag-name tag)))))
582 (semanticdb-strip-find-results m 'name))
583 ;; Presumably, if the tag is faux, it is not local.
584 nil
585 ))
586
587(semantic-alias-obsolete 'semantic-nonterminal-external-member-children
588 'semantic-tag-external-member-children)
589
590(provide 'semantic/sort)
591
592;;; semantic-sort.el ends here