1 ;;; senator.el --- SEmantic NAvigaTOR
3 ;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by David Ponce
5 ;; Author: David Ponce <david@dponce.com>
6 ;; Maintainer: David Ponce <david@dponce.com>
7 ;; Created: 10 Nov 2000
9 ;; X-RCS: $Id: senator.el.upstream,v 1.1 2008-04-06 18:06:18 michaels Exp $
11 ;; This file is not part of Emacs
13 ;; This program is free software; you can redistribute it and/or
14 ;; modify it under the terms of the GNU General Public License as
15 ;; published by the Free Software Foundation; either version 2, or (at
16 ;; your option) any later version.
18 ;; This program is distributed in the hope that it will be useful, but
19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
21 ;; General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with this program; see the file COPYING. If not, write to
25 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
26 ;; Boston, MA 02110-1301, USA.
30 ;; This library defines commands and a minor mode to navigate between
31 ;; semantic language tags in the current buffer.
33 ;; The commands `senator-next-tag' and `senator-previous-tag'
34 ;; navigate respectively to the tag after or before the point. The
35 ;; command `senator-jump' directly jumps to a particular semantic
38 ;; Also, for each built-in search command `search-forward',
39 ;; `search-backward', `re-search-forward', `re-search-backward',
40 ;; `word-search-forward' and `word-search-backward', there is an
41 ;; equivalent `senator-<search-command>' defined which searches only
42 ;; in semantic tag names.
44 ;; The command `senator-isearch-toggle-semantic-mode' toggles semantic
45 ;; search in isearch mode. When semantic search is enabled, isearch
46 ;; is restricted to tag names.
48 ;; Finally, the library provides a `senator-minor-mode' to easily
49 ;; enable or disable the SEmantic NAvigaTOR stuff for the current
52 ;; The best way to use navigation commands is to bind them to keyboard
53 ;; shortcuts. Senator minor mode uses the common prefix key "C-c ,".
54 ;; The following default key bindings are provided when semantic minor
59 ;; C-c , n `senator-next-tag'
60 ;; C-c , p `senator-previous-tag'
61 ;; C-c , j `senator-jump'
62 ;; C-c , i `senator-isearch-toggle-semantic-mode'
63 ;; C-c , TAB `senator-complete-symbol'
64 ;; C-c , SPC `senator-completion-menu-popup'
65 ;; S-mouse-3 `senator-completion-menu-popup'
66 ;; C-c , C-y `senator-yank-tag'
67 ;; C-c , C-w `senator-kill-tag'
68 ;; C-c , M-w `senator-copy-tag'
70 ;; You can customize the `senator-step-at-tag-classes' to navigate (and
71 ;; search) only between tags of a particular class. (Such as
72 ;; functions and variables.)
74 ;; Customize `senator-step-at-start-end-tag-classes' to stop at the
75 ;; start and end of the specified tag classes.
77 ;; To have a mode specific customization, do something like this in a
80 ;; (add-hook 'mode-hook
82 ;; (setq senator-step-at-tag-classes '(function variable))
83 ;; (setq senator-step-at-start-end-tag-classes '(function))
86 ;; The above example specifies to navigate (and search) only between
87 ;; functions and variables, and to step at start and end of functions
95 (require 'semantic-ctxt)
96 (require 'semantic-imenu)
99 (require 'semanticdb-find)
104 (defgroup senator nil
105 "SEmantic NAvigaTOR."
109 (defcustom global-senator-minor-mode nil
110 "*If non-nil enable global use of senator minor mode."
114 :initialize 'custom-initialize-default
115 :set (lambda (sym val)
116 (global-senator-minor-mode (if val 1 -1))))
118 (defcustom senator-minor-mode-hook nil
119 "Hook run at the end of function `senator-minor-mode'."
124 (defcustom senator-step-at-tag-classes nil
125 "*List of tag classes where to step.
126 A tag class is a symbol like 'variable, 'function, 'type, or other.
127 If nil navigation steps at any tag found. This is a buffer local
128 variable. It can be set in a mode hook to get a specific langage
131 :type '(repeat (symbol)))
132 (make-variable-buffer-local 'senator-step-at-tag-classes)
133 (semantic-varalias-obsolete 'semantic-step-at-token-ids
134 'semantic-step-at-tag-classes)
137 (defcustom senator-step-at-start-end-tag-classes '(function)
138 "*List of tag classes where to step at start and end.
139 A tag class is a symbol like 'variable, 'function, 'type, or other.
140 If nil, navigation only step at beginning of tags. If t, step at
141 start and end of any tag where it is allowed to step. Also, stepping
142 at start and end of a tag prevent stepping inside its components.
143 This is a buffer local variable. It can be set in a mode hook to get
144 a specific langage navigation."
146 :type '(choice :tag "Identifiers"
147 (repeat :menu-tag "Symbols" (symbol))
148 (const :tag "All" t)))
149 (make-variable-buffer-local 'senator-step-at-start-end-tag-classes)
150 (semantic-varalias-obsolete 'senator-step-at-start-end-token-ids
151 'senator-step-at-start-end-tag-classes)
153 (defcustom senator-highlight-found t
154 "*If non-nil highlight tags found.
155 This option requires semantic 1.3 and above. This is a buffer
156 local variable. It can be set in a mode hook to get a specific
160 (make-variable-buffer-local 'senator-highlight-found)
163 (defface senator-momentary-highlight-face
164 '((((class color) (background dark))
165 (:background "gray30"))
166 (((class color) (background light))
167 (:background "gray70")))
168 "Face used to momentarily highlight tags."
169 :group 'semantic-faces)
171 (defface senator-intangible-face
172 '((((class color) (background light))
173 (:foreground "gray25"))
174 (((class color) (background dark))
175 (:foreground "gray75")))
176 "Face placed on intangible text."
177 :group 'semantic-faces)
179 (defface senator-read-only-face
180 '((((class color) (background dark))
181 (:background "#664444"))
182 (((class color) (background light))
183 (:background "#CCBBBB")))
184 "Face placed on read-only text."
185 :group 'semantic-faces)
188 ;;;; Common functions
191 (defsubst senator-parse ()
192 "Parse the current buffer and return the tags where to navigate."
193 (semantic-fetch-tags))
195 (defsubst senator-current-tag ()
196 "Return the current tag in the current buffer.
197 Raise an error is there is no tag here."
198 (or (semantic-current-tag)
199 (error "No semantic tag here")))
200 (semantic-alias-obsolete 'senator-current-token 'senator-current-tag)
202 (defun senator-momentary-highlight-tag (tag)
203 "Momentary highlight TAG.
204 Does nothing if `senator-highlight-found' is nil."
205 (and senator-highlight-found
206 (semantic-momentary-highlight-tag
207 tag 'senator-momentary-highlight-face)))
209 (defun senator-step-at-start-end-p (tag)
210 "Return non-nil if must step at start and end of TAG."
212 (or (eq senator-step-at-start-end-tag-classes t)
213 (memq (semantic-tag-class tag)
214 senator-step-at-start-end-tag-classes))))
216 (defun senator-skip-p (tag)
217 "Return non-nil if must skip TAG."
219 senator-step-at-tag-classes
220 (not (memq (semantic-tag-class tag)
221 senator-step-at-tag-classes))))
223 (defun senator-middle-of-tag-p (pos tag)
224 "Return non-nil if POS is between start and end of TAG."
225 (and (> pos (semantic-tag-start tag))
226 (< pos (semantic-tag-end tag))))
228 (defun senator-step-at-parent (tag)
229 "Return TAG's outermost parent if must step at start/end of it.
230 Return nil otherwise."
232 (let (parent parents)
233 (setq parents (semantic-find-tag-by-overlay
234 (semantic-tag-start tag)))
235 (while (and parents (not parent))
236 (setq parent (car parents)
237 parents (cdr parents))
238 (if (or (eq tag parent)
239 (senator-skip-p parent)
240 (not (senator-step-at-start-end-p parent)))
244 (defun senator-previous-tag-or-parent (pos)
245 "Return the tag before POS or one of its parent where to step."
247 (while (and pos (> pos (point-min)) (not tag))
248 (setq pos (semantic-overlay-previous-change pos))
250 ;; Get overlays at position
251 (setq ol (semantic-overlays-at pos))
252 ;; find the overlay that belongs to semantic
253 ;; and STARTS or ENDS at the found position.
254 (while (and ol (not tag))
255 (setq tag (semantic-overlay-get (car ol) 'semantic))
256 (unless (and tag (semantic-tag-p tag)
257 (or (= (semantic-tag-start tag) pos)
258 (= (semantic-tag-end tag) pos)))
261 (or (senator-step-at-parent tag) tag)))
263 (defun senator-full-tag-name (tag parent)
264 "Compose a full name from TAG name and PARENT names.
265 That is append to TAG name PARENT names each one separated by
266 `semantic-type-relation-separator-character'. The PARENT list is in
268 (let ((sep (car semantic-type-relation-separator-character))
271 (setq name (concat name sep
272 (semantic-tag-name (car parent)))
273 parent (cdr parent)))
274 (concat (semantic-tag-name tag) name)))
275 (semantic-alias-obsolete 'senator-full-token-name
276 'senator-full-tag-name)
278 (defvar senator-completion-cache nil
279 "The latest full completion list is cached here.")
280 (make-variable-buffer-local 'senator-completion-cache)
282 (defun senator-completion-cache-flush-fcn (&optional ignore)
283 "Hook run to clear the completion list cache.
284 It is called each time the semantic cache is changed.
286 (setq senator-completion-cache nil))
288 (defun senator-completion-flatten-stream (stream parents &optional top-level)
289 "Return a flat list of all tags available in STREAM.
290 PARENTS is the list of parent tags. Each element of the list is a
291 pair (TAG . PARENTS) where PARENTS is the list of TAG parent
292 tags or nil. If TOP-LEVEL is non-nil the completion list will
293 contain only tags at top level. Otherwise all component tags are
295 (let (fs e tag components)
297 (setq tag (car stream)
302 ;; Not include function arguments
303 (not (semantic-tag-of-class-p tag 'function))
304 (setq components (semantic-tag-components tag))
305 (setq fs (append fs (senator-completion-flatten-stream
309 (defun senator-completion-function-args (tag)
310 "Return a string of argument names from function TAG."
311 (mapconcat #'(lambda (arg)
312 (if (semantic-tag-p arg)
313 (semantic-tag-name arg)
315 (semantic-tag-function-arguments tag)
316 semantic-function-argument-separation-character))
318 (defun senator-completion-refine-name (elt)
319 "Refine the name part of ELT.
320 ELT has the form (NAME . (TAG . PARENTS)). The NAME refinement is
321 done in the following incremental way:
323 - If TAG is a function, append the list of argument names to NAME.
325 - If TAG is a type, append \"{}\" to NAME.
327 - If TAG is an include, append \"#\" to NAME.
329 - If TAG is a package, append \"=\" to NAME.
331 - If TAG has PARENTS append to NAME, the first separator in
332 `semantic-type-relation-separator-character', followed by the next
335 - Otherwise NAME is set to \"tag-name@tag-start-position\"."
336 (let* ((sep (car semantic-type-relation-separator-character))
338 (tag (car (cdr elt)))
339 (parents (cdr (cdr elt)))
340 (oname (semantic-tag-name tag))
341 (class (semantic-tag-class tag)))
343 ((and (eq class 'function) (string-equal name oname))
344 (setq name (format "%s(%s)" name
345 (senator-completion-function-args tag))))
346 ((and (eq class 'type) (string-equal name oname))
347 (setq name (format "%s{}" name)))
348 ((and (eq class 'include) (string-equal name oname))
349 (setq name (format "%s#" name)))
350 ((and (eq class 'package) (string-equal name oname))
351 (setq name (format "%s=" name)))
353 (setq name (format "%s%s%s" name
354 (if (semantic-tag-of-class-p
355 (car parents) 'function)
357 (semantic-tag-name (car parents)))
358 parents (cdr parents)))
360 (setq name (format "%s@%d" oname
361 (semantic-tag-start tag)))))
363 (setcdr elt (cons tag parents))))
365 (defun senator-completion-uniquify-names (completion-stream)
366 "Uniquify names in COMPLETION-STREAM.
367 That is refine the name part of each COMPLETION-STREAM element until
368 there is no duplicated names. Each element of COMPLETION-STREAM has
369 the form (NAME . (TAG . PARENTS)). See also the function
370 `senator-completion-refine-name'."
371 (let ((completion-stream (sort completion-stream
373 (string-lessp (car e1)
379 clst completion-stream)
385 (string-equal name (car (car clst)))
389 (senator-completion-refine-name dup)
391 dup (and elt (string-equal name (car elt)) elt))
392 (and dup (setq clst (cdr clst))))))
393 ;; Return a usable completion alist where each element has the
394 ;; form (NAME . TAG).
395 (setq clst completion-stream)
399 (setcdr elt (car (cdr elt))))
402 (defun senator-completion-stream (stream &optional top-level)
403 "Return a useful completion list from tags in STREAM.
404 That is an alist of all (COMPLETION-NAME . TAG) available.
405 COMPLETION-NAME is an unique tag name (see also the function
406 `senator-completion-uniquify-names'). If TOP-LEVEL is non-nil the
407 completion list will contain only tags at top level. Otherwise all
408 sub tags are included too."
409 (let* ((fs (senator-completion-flatten-stream stream nil top-level))
411 ;; Transform each FS element from (TAG . PARENTS)
412 ;; to (NAME . (TAG . PARENT)).
417 cs (cons (cons (semantic-tag-name tag) elt) cs)))
418 ;; Return a completion list with unique COMPLETION-NAMEs.
419 (senator-completion-uniquify-names cs)))
421 (defun senator-current-type-context ()
422 "Return tags in the type context at point or nil if not found."
423 (let ((context (semantic-find-tags-by-class
424 'type (semantic-find-tag-by-overlay))))
426 (semantic-tag-type-members
427 (nth (1- (length context)) context)))))
429 (defun senator-completion-list (&optional in-context)
430 "Return a useful completion list from tags in current buffer.
431 If IN-CONTEXT is non-nil return only the top level tags in the type
432 context at point or the top level tags in the current buffer if no
433 type context exists at point."
436 (setq stream (senator-current-type-context)))
437 (or stream (setq stream (senator-parse)))
438 ;; IN-CONTEXT completion doesn't use nor set the cache.
439 (or (and (not in-context) senator-completion-cache)
440 (let ((clst (senator-completion-stream stream in-context)))
442 (setq senator-completion-cache clst))
445 (defun senator-find-tag-for-completion (prefix)
446 "Find all tags with a name starting with PREFIX.
447 Uses `semanticdb' when available."
450 (if (and (featurep 'semantic-analyze))
451 (setq tagsa (semantic-analyze-possible-completions
452 (semantic-analyze-current-context))))
454 (if (and (featurep 'semanticdb) (semanticdb-minor-mode-p))
455 ;; semanticdb version returns a list of (DB-TABLE . TAG-LIST)
456 (semanticdb-deep-find-tags-for-completion prefix)
457 ;; semantic version returns a TAG-LIST
458 (semantic-deep-find-tags-for-completion prefix (current-buffer))))
459 (append tagsa (semanticdb-strip-find-results tagsb))))
461 ;;; Senator stream searching functions: no more supported.
463 (defun senator-find-nonterminal-by-name (&rest ignore)
464 (error "Use the semantic and semanticdb find API instead"))
466 (defun senator-find-nonterminal-by-name-regexp (&rest ignore)
467 (error "Use the semantic and semanticdb find API instead"))
470 ;;;; Search functions
473 (defun senator-search-tag-name (tag)
474 "Search for TAG name in current buffer.
475 Limit the search to TAG bounds.
476 If found, set point to the end of the name, and return point. The
477 beginning of the name is at (match-beginning 0).
478 Return nil if not found, that is if TAG name doesn't come from the
480 (let ((name (semantic-tag-name tag)))
481 (setq name (if (string-match "\\`\\([^[]+\\)[[]" name)
482 (match-string 1 name)
484 (goto-char (semantic-tag-start tag))
485 (when (re-search-forward (concat
486 ;; The tag name is expected to be
487 ;; between word delimiters, whitespaces,
489 "\\(\\<\\|\\s-+\\|\\s.\\)"
491 "\\(\\>\\|\\s-+\\|\\s.\\)")
492 (semantic-tag-end tag)
494 (goto-char (match-beginning 0))
495 (search-forward name))))
497 (defcustom senator-search-ignore-tag-classes
499 "*List of ignored tag classes.
500 Tags of those classes are excluded from search."
502 :type '(repeat (symbol :tag "class")))
504 (defun senator-search-default-tag-filter (tag)
505 "Default function that filters searched tags.
506 Ignore tags of classes in `senator-search-ignore-tag-classes'"
507 (not (memq (semantic-tag-class tag)
508 senator-search-ignore-tag-classes)))
510 (defvar senator-search-tag-filter-functions
511 '(senator-search-default-tag-filter)
512 "List of functions to be called to filter searched tags.
513 Each function is passed a tag. If one of them returns nil, the tag is
514 excluded from the search.")
516 (defun senator-search (searcher text &optional bound noerror count)
517 "Use the SEARCHER function to search from point for TEXT in a tag name.
518 SEARCHER is typically the function `search-forward', `search-backward',
519 `word-search-forward', `word-search-backward', `re-search-forward', or
520 `re-search-backward'. See one of the above function to see how the
521 TEXT, BOUND, NOERROR, and COUNT arguments are interpreted."
522 (let* ((origin (point))
524 (step (cond ((> count 0) 1)
525 ((< count 0) (setq count (- count)) -1)
527 found next sstart send tag tstart tend)
529 (while (and (not found)
530 (setq next (funcall searcher text bound t step)))
531 (setq sstart (match-beginning 0)
535 (and (setq tag (semantic-current-tag))
536 (run-hook-with-args-until-failure
537 'senator-search-tag-filter-functions tag)
538 (setq tend (senator-search-tag-name tag))
539 (setq tstart (match-beginning 0)
540 found (and (>= sstart tstart)
542 (zerop (setq count (1- count))))))
553 ;; Setup the returned value and the `match-data' or maybe fail!
554 (funcall searcher text send noerror step)))
557 ;;;; Navigation commands
561 (defun senator-next-tag ()
562 "Navigate to the next Semantic tag.
563 Return the tag or nil if at end of buffer."
566 (tag (semantic-current-tag))
569 (not (senator-skip-p tag))
570 (senator-step-at-start-end-p tag)
571 (or (= pos (semantic-tag-start tag))
572 (senator-middle-of-tag-p pos tag)))
574 (if (setq tag (senator-step-at-parent tag))
576 (setq tag (semantic-find-tag-by-overlay-next pos))
577 (while (and tag (senator-skip-p tag))
578 (setq tag (semantic-find-tag-by-overlay-next
579 (semantic-tag-start tag))))))
582 (goto-char (point-max))
583 (working-message "End of buffer"))
584 (cond ((and (senator-step-at-start-end-p tag)
585 (or (= pos (semantic-tag-start tag))
586 (senator-middle-of-tag-p pos tag)))
588 (goto-char (semantic-tag-end tag)))
591 (goto-char (semantic-tag-start tag))))
592 (senator-momentary-highlight-tag tag)
593 (working-message "%S: %s (%s)"
594 (semantic-tag-class tag)
595 (semantic-tag-name tag)
598 (semantic-alias-obsolete 'senator-next-token 'senator-next-tag)
601 (defun senator-previous-tag ()
602 "Navigate to the previous Semantic tag.
603 Return the tag or nil if at beginning of buffer."
606 (tag (semantic-current-tag))
609 (not (senator-skip-p tag))
610 (senator-step-at-start-end-p tag)
611 (or (= pos (semantic-tag-end tag))
612 (senator-middle-of-tag-p pos tag)))
614 (if (setq tag (senator-step-at-parent tag))
616 (setq tag (senator-previous-tag-or-parent pos))
617 (while (and tag (senator-skip-p tag))
618 (setq tag (senator-previous-tag-or-parent
619 (semantic-tag-start tag))))))
622 (goto-char (point-min))
623 (working-message "Beginning of buffer"))
624 (cond ((or (not (senator-step-at-start-end-p tag))
625 (= pos (semantic-tag-end tag))
626 (senator-middle-of-tag-p pos tag))
628 (goto-char (semantic-tag-start tag)))
631 (goto-char (semantic-tag-end tag))))
632 (senator-momentary-highlight-tag tag)
633 (working-message "%S: %s (%s)"
634 (semantic-tag-class tag)
635 (semantic-tag-name tag)
638 (semantic-alias-obsolete 'senator-previous-token 'senator-previous-tag)
640 (defvar senator-jump-completion-list nil
641 "`senator-jump' stores here its current completion list.
642 Then use `assoc' to retrieve the tag associated to a symbol.")
644 (defun senator-jump-interactive (prompt &optional in-context no-default require-match)
645 "Called interactively to provide completion on some tag name.
647 Use PROMPT. If optional IN-CONTEXT is non-nil jump in the local
648 type's context \(see function `senator-current-type-context'). If
649 optional NO-DEFAULT is non-nil do not provide a default value. If
650 optional REQUIRE-MATCH is non-nil an explicit match must be made.
652 The IN-CONTEXT and NO-DEFAULT switches are combined using the
653 following prefix arguments:
655 - \\[universal-argument] IN-CONTEXT.
656 - \\[universal-argument] - NO-DEFAULT.
657 - \\[universal-argument] \\[universal-argument] IN-CONTEXT + NO-DEFAULT."
658 (let* ((arg (prefix-numeric-value current-prefix-arg))
661 ;; The `completing-read' function provided by XEmacs
662 ;; (21.1) don't allow a default value argument :-(
665 (= arg 16))) ; C-u C-u
669 (= arg 16))) ; C-u C-u
671 (and (not no-default)
672 (or (semantic-ctxt-current-symbol)
673 (semantic-ctxt-current-function))))
674 (completing-read-args
675 (list (if (and context (car context))
676 (format "%s(default: %s) " prompt (car context))
678 (setq senator-jump-completion-list
679 (senator-completion-list in-context))
683 'semantic-read-symbol-history)))
685 (apply #'completing-read
686 (if (and context (car context))
687 (append completing-read-args context)
688 completing-read-args))
689 in-context no-default)))
691 (defun senator-jump-noselect (sym &optional next-p regexp-p)
692 "Jump to the semantic symbol SYM.
693 If NEXT-P is non-nil, then move the the next tag in the search
694 assuming there was already one jump for the given symbol.
695 If REGEXP-P is non nil, then treat SYM as a regular expression.
696 Return the tag jumped to.
697 Note: REGEXP-P doesn't work yet. This needs to be added to get
698 the etags override to be fully functional."
699 (let ((tag (cdr (assoc sym senator-jump-completion-list))))
701 (set-buffer (semantic-tag-buffer tag))
702 (goto-char (semantic-tag-start tag))
706 (defun senator-jump (sym &optional in-context no-default)
707 "Jump to the semantic symbol SYM.
709 If optional IN-CONTEXT is non-nil jump in the local type's context
710 \(see function `senator-current-type-context'). If optional
711 NO-DEFAULT is non-nil do not provide a default value.
713 When called interactively you can combine the IN-CONTEXT and
714 NO-DEFAULT switches like this:
716 - \\[universal-argument] IN-CONTEXT.
717 - \\[universal-argument] - NO-DEFAULT.
718 - \\[universal-argument] \\[universal-argument] IN-CONTEXT + NO-DEFAULT."
719 (interactive (senator-jump-interactive "Jump to: " nil nil t))
721 (let ((tag (senator-jump-noselect sym no-default)))
723 (switch-to-buffer (semantic-tag-buffer tag))
724 (senator-momentary-highlight-tag tag)
725 (working-message "%S: %s "
726 (semantic-tag-class tag)
727 (semantic-tag-name tag)))))
730 (defun senator-jump-regexp (symregex &optional in-context no-default)
731 "Jump to the semantic symbol SYMREGEX.
732 SYMREGEX is treated as a regular expression.
734 If optional IN-CONTEXT is non-nil jump in the local type's context
735 \(see function `senator-current-type-context'). If optional
736 NO-DEFAULT is non-nil do not provide a default value and move to the
737 next match of SYMREGEX. NOTE: Doesn't actually work yet.
739 When called interactively you can combine the IN-CONTEXT and
740 NO-DEFAULT switches like this:
742 - \\[universal-argument] IN-CONTEXT.
743 - \\[universal-argument] - NO-DEFAULT.
744 - \\[universal-argument] \\[universal-argument] IN-CONTEXT + NO-DEFAULT."
745 (interactive (senator-jump-interactive "Jump to: "))
746 (let ((tag (senator-jump-noselect symregex no-default)))
748 (switch-to-buffer (semantic-tag-buffer tag))
749 (senator-momentary-highlight-tag tag)
750 (working-message "%S: %s "
751 (semantic-tag-class tag)
752 (semantic-tag-name tag)))))
754 (defvar senator-last-completion-stats nil
755 "The last senator completion was here.
756 Of the form (BUFFER STARTPOS INDEX REGEX COMPLIST...)")
758 (defsubst senator-current-symbol-start ()
759 "Return position of start of the current symbol under point or nil."
761 (save-excursion (forward-sexp -1) (point))
765 (defun senator-complete-symbol (&optional cycle-once)
766 "Complete the current symbol under point.
767 If optional argument CYCLE-ONCE is non-nil, only cycle through the list
768 of completions once, doing nothing where there are no more matches."
770 (let ((symstart (senator-current-symbol-start))
773 ;; Get old stats if apropriate.
774 (if (and senator-last-completion-stats
775 ;; Check if completing in the same buffer
776 (eq (car senator-last-completion-stats) (current-buffer))
777 ;; Check if completing from the same point
778 (= (nth 1 senator-last-completion-stats) symstart)
779 ;; Check if completing the same symbol
782 (looking-at (nth 3 senator-last-completion-stats))))
784 (setq complst (nthcdr 4 senator-last-completion-stats))
786 (setq regex (regexp-quote (buffer-substring symstart (point)))
787 complst (senator-find-tag-for-completion regex)
788 senator-last-completion-stats (append (list (current-buffer)
793 ;; Do the completion if apropriate.
796 (index (nth 2 senator-last-completion-stats))
798 (if (= index (length complst))
799 ;; Cycle to the first completion tag.
801 ;; Stop completion if CYCLE-ONCE is non-nil.
802 ret (not cycle-once)))
803 ;; Get the new completion tag.
804 (setq newtok (nth index complst))
806 ;; Move index to the next completion tag.
807 (setq index (1+ index)
808 ;; Return the completion string (useful to hippie
809 ;; expand for example)
810 ret (semantic-tag-name newtok))
811 ;; Replace the string.
812 (delete-region symstart (point))
814 ;; Update the completion index.
815 (setcar (nthcdr 2 senator-last-completion-stats) index)
822 (defcustom senator-completion-menu-summary-function
823 'semantic-format-tag-concise-prototype
824 "*Function to use when creating items in completion menu.
825 Some useful functions are in `semantic-format-tag-functions'."
827 :type semantic-format-tag-custom-list)
828 (make-variable-buffer-local 'senator-completion-menu-summary-function)
830 (defcustom senator-completion-menu-insert-function
831 'senator-completion-menu-insert-default
832 "*Function to use to insert an item from completion menu.
833 It will receive a Semantic tag as argument."
835 :type '(radio (const senator-completion-menu-insert-default)
837 (make-variable-buffer-local 'senator-completion-menu-insert-function)
839 (defun senator-completion-menu-insert-default (tag)
840 "Insert a text representation of TAG at point."
841 (insert (semantic-tag-name tag)))
843 (defun senator-completion-menu-do-complete (tag-array)
844 "Replace the current syntactic expression with a chosen completion.
845 Argument TAG-ARRAY is an array of one element containting the tag
846 choosen from the completion menu."
847 (let ((tag (aref tag-array 0))
848 (symstart (senator-current-symbol-start))
849 (finsert (if (fboundp senator-completion-menu-insert-function)
850 senator-completion-menu-insert-function
851 #'senator-completion-menu-insert-default)))
854 (delete-region symstart (point))
855 (funcall finsert tag)))))
857 (defun senator-completion-menu-item (tag)
858 "Return a completion menu item from TAG.
859 That is a pair (MENU-ITEM-TEXT . TAG-ARRAY). TAG-ARRAY is an
860 array of one element containing TAG. Can return nil to discard a
862 (cons (funcall (if (fboundp senator-completion-menu-summary-function)
863 senator-completion-menu-summary-function
864 #'semantic-format-tag-prototype) tag)
867 (defun senator-completion-menu-window-offsets (&optional window)
868 "Return offsets of WINDOW relative to WINDOW's frame.
869 Return a cons cell (XOFFSET . YOFFSET) so the position (X . Y) in
870 WINDOW is equal to the position ((+ X XOFFSET) . (+ Y YOFFSET)) in
872 (let* ((window (or window (selected-window)))
873 (e (window-edges window))
878 (x (+ left (/ (- right left) 2)))
879 (y (+ top (/ (- bottom top) 2)))
880 (wpos (coordinates-in-window-p (cons x y) window))
884 (let* ((f (window-frame window))
885 (cy (/ 1.0 (float (frame-char-height f)))))
886 (setq xoffset (- x (car wpos))
887 yoffset (float (- y (cdr wpos))))
888 ;; If Emacs 21 add to:
889 ;; - XOFFSET the WINDOW left margin width.
890 ;; - YOFFSET the height of header lines above WINDOW.
891 (if (> emacs-major-version 20)
893 (setq wpos (cons (+ left xoffset) 0.0)
894 bottom (float bottom))
895 (while (< (cdr wpos) bottom)
896 (if (eq (coordinates-in-window-p wpos window)
898 (setq yoffset (+ yoffset cy)))
899 (setcdr wpos (+ (cdr wpos) cy)))
900 (setq xoffset (floor (+ xoffset
901 (or (car (window-margins window))
903 (setq yoffset (floor yoffset))))
904 (cons xoffset yoffset)))
906 (defun senator-completion-menu-point-as-event()
907 "Returns the text cursor position as an event.
908 Also move the mouse pointer to the cursor position."
909 (let* ((w (get-buffer-window (current-buffer)))
910 (x (mod (- (current-column) (window-hscroll))
915 (narrow-to-region (window-start) (point))
916 (goto-char (point-min))
917 (1+ (vertical-motion (buffer-size))))))
919 (if (featurep 'xemacs)
920 (let* ((at (progn (set-mouse-position w x (1- y))
921 (cdr (mouse-pixel-position))))
924 (make-event 'button-press
930 (let ((offsets (senator-completion-menu-window-offsets w)))
931 ;; Convert window position (x,y) to the equivalent frame
932 ;; position and move the mouse pointer to it.
933 (set-mouse-position (window-frame w)
939 (defun senator-completion-menu-popup ()
940 "Popup a completion menu for the symbol at point.
941 The popup menu displays all of the possible completions for the symbol
942 it was invoked on. To automatically split large menus this function
943 use `imenu--mouse-menu' to handle the popup menu."
945 (let ((symstart (senator-current-symbol-start))
946 symbol regexp complst
947 ;; Turn off tag jumping for this menu.
948 (imenu-default-goto-function (lambda (name pos &optional rest) pos)))
950 (setq symbol (buffer-substring-no-properties symstart (point))
951 regexp (regexp-quote symbol)
952 complst (senator-find-tag-for-completion regexp)))
954 (error "No completions available"))
955 ;; We have a completion list, build a menu
956 (let ((index (delq nil
957 (mapcar #'senator-completion-menu-item
960 (cond ;; Here index is a menu structure like:
962 ;; -1- (("menu-item1" . [tag1]) ...)
963 ((vectorp (cdr (car index)))
964 ;; There are more than one item, setup the popup title.
966 (setq title (format "%S completion" symbol))
967 ;; Only one item , no need to popup the menu.
968 (setq item (car index))))
970 ;; -2- (("menu-title1" ("menu-item1" . [tag1]) ...) ...)
972 ;; There are sub-menus.
974 ;; Several sub-menus, setup the popup title.
975 (setq title (format "%S completion" symbol))
976 ;; Only one sub-menu, convert it to a main menu and add the
977 ;; sub-menu title (filename) to the popup title.
978 (setq title (format "%S completion (%s)"
979 symbol (car (car index)))
980 index (cdr (car index)))
983 ;; ... If only one menu item, no need to popup the menu.
984 (setq item (car index))))))
986 ;; `imenu--mouse-menu' automagically splits large menu into
987 ;; several submenus, displays the popup menu, and returns
988 ;; the selected item :-)
989 (setq item (imenu--mouse-menu
992 (senator-completion-menu-point-as-event)
995 (senator-completion-menu-do-complete (cdr item))))))
1002 (defun senator-search-forward (string &optional bound noerror count)
1003 "Search in tag names forward from point for STRING.
1004 Set point to the end of the occurrence found, and return point.
1005 See also the function `search-forward' for details on the BOUND,
1006 NOERROR and COUNT arguments."
1007 (interactive "sSemantic search: ")
1008 (senator-search 'search-forward string bound noerror count))
1011 (defun senator-re-search-forward (regexp &optional bound noerror count)
1012 "Search in tag names forward from point for regular expression REGEXP.
1013 Set point to the end of the occurrence found, and return point.
1014 See also the function `re-search-forward' for details on the BOUND,
1015 NOERROR and COUNT arguments."
1016 (interactive "sSemantic regexp search: ")
1017 (senator-search 're-search-forward regexp bound noerror count))
1020 (defun senator-word-search-forward (word &optional bound noerror count)
1021 "Search in tag names forward from point for WORD.
1022 Set point to the end of the occurrence found, and return point.
1023 See also the function `word-search-forward' for details on the BOUND,
1024 NOERROR and COUNT arguments."
1025 (interactive "sSemantic word search: ")
1026 (senator-search 'word-search-forward word bound noerror count))
1029 (defun senator-search-backward (string &optional bound noerror count)
1030 "Search in tag names backward from point for STRING.
1031 Set point to the beginning of the occurrence found, and return point.
1032 See also the function `search-backward' for details on the BOUND,
1033 NOERROR and COUNT arguments."
1034 (interactive "sSemantic backward search: ")
1035 (senator-search 'search-backward string bound noerror count))
1038 (defun senator-re-search-backward (regexp &optional bound noerror count)
1039 "Search in tag names backward from point for regular expression REGEXP.
1040 Set point to the beginning of the occurrence found, and return point.
1041 See also the function `re-search-backward' for details on the BOUND,
1042 NOERROR and COUNT arguments."
1043 (interactive "sSemantic backward regexp search: ")
1044 (senator-search 're-search-backward regexp bound noerror count))
1047 (defun senator-word-search-backward (word &optional bound noerror count)
1048 "Search in tag names backward from point for WORD.
1049 Set point to the beginning of the occurrence found, and return point.
1050 See also the function `word-search-backward' for details on the BOUND,
1051 NOERROR and COUNT arguments."
1052 (interactive "sSemantic backward word search: ")
1053 (senator-search 'word-search-backward word bound noerror count))
1056 ;;;; Others useful search commands (minor mode menu)
1060 (or (not (featurep 'xemacs))
1061 (fboundp 'isearch-update-ring)
1063 ;; Provide `isearch-update-ring' function.
1064 ;; (from XEmacs 21.1.9 isearch-mode.el)
1065 (defun isearch-update-ring (string &optional regexp)
1066 "Add STRING to the beginning of the search ring.
1067 REGEXP says which ring to use."
1068 (if (> (length string) 0)
1069 ;; Update the ring data.
1071 (if (not (setq regexp-search-ring-yank-pointer
1072 (member string regexp-search-ring)))
1074 (setq regexp-search-ring
1075 (cons string regexp-search-ring)
1076 regexp-search-ring-yank-pointer regexp-search-ring)
1077 (if (> (length regexp-search-ring) regexp-search-ring-max)
1078 (setcdr (nthcdr (1- regexp-search-ring-max) regexp-search-ring)
1080 (if (not (setq search-ring-yank-pointer
1081 ;; really need equal test instead of eq.
1082 (member string search-ring)))
1084 (setq search-ring (cons string search-ring)
1085 search-ring-yank-pointer search-ring)
1086 (if (> (length search-ring) search-ring-max)
1087 (setcdr (nthcdr (1- search-ring-max) search-ring) nil)))))))
1091 (defvar senator-last-search-type nil
1092 "Type of last non-incremental search command called.")
1094 (defun senator-nonincremental-repeat-search-forward ()
1095 "Search forward for the previous search string or regexp."
1098 ((and (eq senator-last-search-type 'string)
1100 (senator-search-forward (car search-ring)))
1101 ((and (eq senator-last-search-type 'regexp)
1103 (senator-re-search-forward (car regexp-search-ring)))
1105 (error "No previous search"))))
1107 (defun senator-nonincremental-repeat-search-backward ()
1108 "Search backward for the previous search string or regexp."
1111 ((and (eq senator-last-search-type 'string)
1113 (senator-search-backward (car search-ring)))
1114 ((and (eq senator-last-search-type 'regexp)
1116 (senator-re-search-backward (car regexp-search-ring)))
1118 (error "No previous search"))))
1120 (defun senator-nonincremental-search-forward (string)
1121 "Search for STRING nonincrementally."
1122 (interactive "sSemantic search for string: ")
1123 (setq senator-last-search-type 'string)
1124 (if (equal string "")
1125 (senator-search-forward (car search-ring))
1126 (isearch-update-ring string nil)
1127 (senator-search-forward string)))
1129 (defun senator-nonincremental-search-backward (string)
1130 "Search backward for STRING nonincrementally."
1131 (interactive "sSemantic search for string: ")
1132 (setq senator-last-search-type 'string)
1133 (if (equal string "")
1134 (senator-search-backward (car search-ring))
1135 (isearch-update-ring string nil)
1136 (senator-search-backward string)))
1138 (defun senator-nonincremental-re-search-forward (string)
1139 "Search for the regular expression STRING nonincrementally."
1140 (interactive "sSemantic search for regexp: ")
1141 (setq senator-last-search-type 'regexp)
1142 (if (equal string "")
1143 (senator-re-search-forward (car regexp-search-ring))
1144 (isearch-update-ring string t)
1145 (senator-re-search-forward string)))
1147 (defun senator-nonincremental-re-search-backward (string)
1148 "Search backward for the regular expression STRING nonincrementally."
1149 (interactive "sSemantic search for regexp: ")
1150 (setq senator-last-search-type 'regexp)
1151 (if (equal string "")
1152 (senator-re-search-backward (car regexp-search-ring))
1153 (isearch-update-ring string t)
1154 (senator-re-search-backward string)))
1156 (defvar senator--search-filter nil)
1158 (defun senator-search-set-tag-class-filter (&optional classes)
1159 "In current buffer, limit search scope to tag CLASSES.
1160 CLASSES is a list of tag class symbols or nil. If nil only global
1161 filters in `senator-search-tag-filter-functions' remain active."
1162 (interactive "sClasses: ")
1170 (mapcar 'read (split-string classes)))
1172 (signal 'wrong-type-argument (list classes)))
1174 ;; Clear previous filter.
1175 (remove-hook 'senator-search-tag-filter-functions
1176 senator--search-filter t)
1177 (kill-local-variable 'senator--search-filter)
1179 (let ((tag (make-symbol "tag"))
1180 (names (mapconcat 'symbol-name classes "', `")))
1181 (set (make-local-variable 'senator--search-filter)
1183 (memq (semantic-tag-class ,tag) ',classes)))
1184 (semantic-make-local-hook
1185 'senator-search-tag-filter-functions)
1186 (add-hook 'senator-search-tag-filter-functions
1187 senator--search-filter nil t)
1188 (message "Limit search to `%s' tags" names))
1189 (message "Default search filter restored")))
1195 (defun senator-toggle-read-only (&optional tag)
1196 "Toggle the read-only status of the current TAG."
1198 (let* ((tag (or tag (senator-current-tag)))
1199 (read (semantic-tag-read-only-p tag)))
1200 (semantic-set-tag-read-only tag read)
1201 (semantic-set-tag-face
1203 (if read nil 'senator-read-only-face))))
1205 (defun senator-toggle-intangible (&optional tag)
1206 "Toggle the tangibility of the current TAG."
1208 (let* ((tag (or tag (senator-current-tag)))
1209 (tang (semantic-tag-intangible-p tag)))
1210 (semantic-set-tag-intangible tag tang)
1211 (semantic-set-tag-face
1213 (if tang nil 'senator-intangible-face))))
1215 (defun senator-set-face (face &optional tag)
1216 "Set the foreground FACE of the current TAG."
1217 (interactive (list (read-face-name
1218 (if (featurep 'xemacs)
1220 ;; GNU Emacs already append ": "
1222 (let ((tag (or tag (senator-current-tag))))
1223 (semantic-set-tag-face tag face)))
1225 (defun senator-set-foreground (color &optional tag)
1226 "Set the foreground COLOR of the current TAG."
1227 ;; This was copied from facemenu
1228 (interactive (list (facemenu-read-color "Foreground color: ")))
1229 (let ((face (intern (concat "fg:" color))))
1230 (or (facemenu-get-face face)
1231 (error "Unknown color: %s" color))
1232 (senator-set-face face)))
1234 (defun senator-set-background (color &optional tag)
1235 "Set the background COLOR of the current TAG."
1236 ;; This was copied from facemenu
1237 (interactive (list (facemenu-read-color "Background color: ")))
1238 (let ((face (intern (concat "bg:" color))))
1239 (or (facemenu-get-face face)
1240 (error "Unknown color: %s" color))
1241 (senator-set-face face)))
1243 (defun senator-clear-tag (&optional tag)
1244 "Clear all properties from TAG."
1246 (let ((tag (or tag (senator-current-tag))))
1247 (semantic-set-tag-read-only tag t)
1248 (semantic-set-tag-intangible tag t)
1249 (semantic-set-tag-face tag nil)))
1250 (semantic-alias-obsolete 'senator-clear-token 'senator-clear-tag)
1254 ;; Use new folding state. It might be wise to extend the idea
1255 ;; of folding for hiding all but this, or show all children, etc.
1257 (defun senator-fold-tag (&optional tag)
1258 "Fold the current TAG."
1260 (semantic-set-tag-folded (or tag (semantic-current-tag)) t))
1262 (defun senator-unfold-tag (&optional tag)
1263 "Fold the current TAG."
1265 (semantic-set-tag-folded (or tag (semantic-current-tag)) nil))
1267 (defun senator-fold-tag-toggle (&optional tag)
1268 "Fold the current TAG."
1270 (let ((tag (or tag (semantic-current-tag))))
1271 (if (semantic-tag-folded-p tag)
1272 (senator-unfold-tag tag)
1273 (senator-fold-tag tag))))
1278 (defun senator-go-to-up-reference (&optional tag)
1279 "Move up one reference from the current TAG.
1280 A \"reference\" could be any interesting feature of TAG.
1281 In C++, a function may have a 'parent' which is non-local.
1282 If that parent which is only a reference in the function tag
1283 is found, we can jump to it.
1284 Some tags such as includes have other reference features."
1286 (let ((newtag (semantic-up-reference (or tag (semantic-current-tag)))))
1288 (error "No up reference found")
1290 (semantic-go-to-tag newtag)
1291 (switch-to-buffer (current-buffer))
1292 (semantic-momentary-highlight-tag newtag))))
1294 (define-overload semantic-up-reference (tag)
1295 "Return a tag that is referredto by TAG.
1296 A \"reference\" could be any interesting feature of TAG.
1297 In C++, a function may have a 'parent' which is non-local.
1298 If that parent which is only a reference in the function tag
1299 is found, we can jump to it.
1300 Some tags such as includes have other reference features.")
1302 (defun semantic-up-reference-default (tag)
1303 "Return a tag that is referredto by TAG.
1304 Makes C/C++ language like assumptions."
1305 (cond ((semantic-tag-faux-p tag)
1306 ;; Faux tags should have a real tag in some other location.
1307 (let ((options (semantic-tag-external-class tag)))
1308 ;; I should do something a little better than
1312 ((eq (semantic-tag-class tag) 'include)
1313 ;; Include always point to another file.
1315 ;; Note: if you then call 'semantic-go-to-tag', then
1316 ;; you would just to the source of this tag.
1318 ((and (eq (semantic-tag-class tag) 'function)
1319 (semantic-tag-function-parent tag))
1320 ;; Is there a parent of the function to jump to?
1321 (let* ((p (semantic-tag-function-parent tag))
1322 (sr1 (semanticdb-find-tags-by-name p))
1324 (semanticdb-find-tags-by-class 'type sr1)))
1326 (semanticdb-find-result-nth-in-buffer sr2 0)
1329 ((and (eq (semantic-tag-class tag) 'function)
1330 (semantic-tag-get-attribute tag :prototype-flag))
1331 ;; Is there a parent of the function to jump to?
1332 (let* ((p (semantic-tag-name tag))
1333 (sr1 (semanticdb-find-tags-by-name p))
1335 (semanticdb-find-tags-by-class
1336 (semantic-tag-class tag)
1339 (len (semanticdb-find-result-length sr2)))
1340 (while (and (< int len)
1341 (semantic-tag-get-attribute
1342 (semanticdb-find-result-nth-in-buffer sr2 int)
1344 (setq int (1+ int)))
1345 (semanticdb-find-result-nth-in-buffer sr2 int)
1347 ((semantic-tag-type tag)
1348 ;; Get the data type, and try to find that.
1349 (let* ((type (semantic-tag-type tag))
1350 (tn (cond ((stringp type)
1352 ((semantic-tag-p type)
1353 (semantic-tag-name type))
1354 (t (error "No known type"))))
1355 (sr1 (semanticdb-find-tags-by-name tn))
1357 (semanticdb-find-tags-by-class 'type sr1))))
1358 (semanticdb-find-result-nth-in-buffer sr2 0)
1363 ;;;; Misc. menu stuff.
1366 (defun senator-menu-item (item)
1367 "Build an XEmacs compatible menu item from vector ITEM.
1368 That is remove the unsupported :help stuff."
1369 (if (featurep 'xemacs)
1370 (let ((n (length item))
1374 (setq slot (aref item i))
1375 (if (and (keywordp slot)
1378 (setq l (cons slot l)))
1380 (apply #'vector (nreverse l)))
1384 ;;;; The dynamic sub-menu of Semantic minor modes.
1386 (defvar senator-registered-mode-entries nil)
1387 (defvar senator-registered-mode-settings nil)
1388 (defvar senator-modes-menu-cache nil)
1390 (defun senator-register-command-menu (spec global)
1391 "Register the minor mode menu item specified by SPEC.
1392 Return a menu item allowing to change the corresponding minor mode
1393 setting. If GLOBAL is non-nil SPEC defines a global setting else a
1396 SPEC must be a list of the form:
1398 \(CALLBACK [ KEYWORD ARG ] ... )
1400 Where KEYWORD is one of those recognized by `easy-menu-define' plus:
1404 VARIABLE is a variable that will be saved by Custom when using the
1405 \"Modes/Save global settings\" menu item. This keyword is ignored if
1408 By default the returned menu item is setup with:
1410 :active t :style toggle :selected CALLBACK.
1412 So when :selected is not specified the function assumes that CALLBACK
1413 is a symbol which refer to a bound variable too."
1415 (symbolp (car spec))
1416 (fboundp (car spec))
1417 (let* ((callback (car spec)) ; callback function
1418 (props (cdr spec)) ; properties
1419 (selected callback) ; selected default to callback
1420 (active t) ; active by default
1421 (style 'toggle) ; toggle style by default
1422 (save nil) ; what to save via custom
1425 (setq key (car props)
1436 (setq selected val))
1438 (setq item (cons key (cons val item))))))
1439 (if (and global save (symbolp save) (boundp save))
1440 (add-to-list 'senator-registered-mode-settings save))
1441 (setq item (cons :selected (cons selected item))
1442 item (cons :active (cons active item))
1443 item (cons :style (cons style item))
1444 item (cons callback item)))))
1446 (defun senator-register-custom-menu (spec)
1447 "Register SPEC as a menu item entry for customizing some aspect of a mode.
1448 SPEC can either be one entry, or a list of SPEC entries. A SPEC is of
1451 \(SYMBOL [ :KEYWORD ARG ] ...)
1453 Valid keywords include:
1455 :name - ARG represents the string used in the menu item.
1457 :style - ARG represents the style of menu item this is. Values for ARG
1459 :group - SYMBOL is a group that `customize-group' will be called on.
1460 :variable - SYMBOL is a variable that `customize-variable' will be called on.
1461 :face - SYMBOL is a face that `customize-face' will be called on.
1462 :toggle - SYMBOL is a variable that will be toggled on and off.
1464 If :style is not specified, the symbol is queried to try and
1465 predict the correct style to use.
1467 :option-symbol - SYMBOL is a variable that contains a value that is from
1468 a list of symbols. ARG should be a list of symbols that can assign
1469 to the variable SYMBOL."
1470 (if (and (not (null spec)) (not (consp spec)))
1471 (signal 'wrong-type-argument (list spec)))
1472 ;; Turn spec into a list of specs if it is not so already.
1473 (if (and spec (not (consp (car spec)))) (setq spec (list spec)))
1474 (let ((menulist nil)
1477 (let* ((sym (car (car spec)))
1478 (pl (cdr (car spec)))
1479 (name (car-safe (cdr-safe (member :name pl))))
1480 (style (car-safe (cdr-safe (member :style pl)))))
1484 ((get sym 'custom-group)
1491 (setq name (symbol-name sym)))
1497 (vector (concat "Customize Group " name)
1498 `(lambda (ARG) (interactive "p")
1499 (customize-group (quote ,sym)))
1500 :help (format "Customize Group %s" name)))
1502 ((eq style :variable)
1504 (vector (concat "Customize " name)
1505 `(lambda (ARG) (interactive "p")
1506 (customize-variable (quote ,sym)))
1507 :help (format "Customize Variable %s" name)))
1511 (vector (concat "Customize " name)
1512 `(lambda (ARG) (interactive "p")
1513 (customize-face (quote ,sym)))
1514 :help (format "Customize Face %s" name)))
1520 (setq spec (cdr spec)))
1523 (defun senator-register-mode-menu-entry (name local global &optional custom)
1524 "Register a minor mode menu entry.
1525 This will add menu items to the \"Modes\" menu allowing to change the
1526 minor mode settings. NAME is the name displayed in the menu. LOCAL
1527 and GLOBAL define command menu items to respectively change the minor
1528 mode local and global settings. nil means to omit the corresponding
1529 menu item. See the function `senator-register-command-menu' for the
1530 command menu specification. If NAME is already registered the
1531 corresponding entry will be updated with the given LOCAL and GLOBAL
1532 definitions. If LOCAL and GLOBAL are both nil the NAME entry is
1533 unregistered if present.
1534 Optional fourth argument CUSTOM represents a menu item, or submenu
1535 item that will customize something about the mode being registered.
1536 See the function `senator-register-custom-menu' for the details on
1537 what this menu looks like."
1538 ;; Clear the cached menu to rebuild it.
1539 (setq senator-modes-menu-cache nil)
1540 (let* ((entry (assoc name senator-registered-mode-entries))
1541 (local-item (senator-register-command-menu local nil))
1542 (global-item (senator-register-command-menu global t))
1543 (custom-item (senator-register-custom-menu custom))
1544 (entry-construct (append (list local-item global-item)
1548 (if (not (or local-item global-item))
1549 (setq senator-registered-mode-entries
1550 (delq entry senator-registered-mode-entries))
1552 (setcdr entry entry-construct)
1553 (setq entry (cons name entry-construct)
1554 senator-registered-mode-entries
1555 (nconc senator-registered-mode-entries (list entry))))
1558 (defsubst senator-build-command-menu-item (label props)
1559 "Return a command menu item with an unique name based on LABEL.
1560 PROPS is the list of properties of this menu item."
1562 (senator-menu-item (apply #'vector (cons label props)))))
1564 (defcustom senator-mode-menu-local-toggle-label "In this buffer"
1565 "*Label of menu item that toggles a Semantic minor mode locally."
1568 :set (lambda (sym val)
1569 (set-default sym val)
1570 (setq senator-modes-menu-cache nil)))
1572 (defcustom senator-mode-menu-global-toggle-label "Globally"
1573 "*Label of menu item that toggles a Semantic minor mode globally."
1576 :set (lambda (sym val)
1577 (set-default sym val)
1578 (setq senator-modes-menu-cache nil)))
1580 (defun senator-build-mode-sub-menu (entry)
1581 "Return a sub-menu for the registered minor mode ENTRY.
1582 The sub-menu displayed in the Senator/Modes menu looks like this:
1591 The menu item \"In this buffer\" toggles the minor mode locally.
1592 The menu item \"Globally\" toggles the minor mode globally."
1593 (let ((mode (nth 1 entry))
1594 (global (nth 2 entry))
1595 (customs (nthcdr 3 entry)))
1599 (senator-build-command-menu-item
1600 senator-mode-menu-local-toggle-label mode)
1601 (senator-build-command-menu-item
1602 senator-mode-menu-global-toggle-label global))
1603 (if (and (symbolp customs) (fboundp customs))
1607 (defun senator-build-modes-menu (&rest ignore)
1608 "Build and return the \"Modes\" menu.
1609 It is dynamically build from registered minor mode entries. See also
1610 the function `senator-register-mode-menu-entry'.
1611 IGNORE any arguments.
1612 This function is a menu :filter."
1613 (or senator-modes-menu-cache
1614 (setq senator-modes-menu-cache
1615 (nconc (mapcar 'senator-build-mode-sub-menu
1616 senator-registered-mode-entries)
1619 [ "Save global settings"
1620 senator-save-registered-mode-settings
1622 Save global settings of Semantic minor modes in your init file."
1625 (defun senator-save-registered-mode-settings ()
1626 "Save current value of registered minor modes global setting.
1627 The setting is saved by Custom. See the function
1628 `senator-register-mode-menu-entry' for details on how to register a
1631 (dolist (opt senator-registered-mode-settings)
1633 (customize-save-variable opt (default-value opt))
1636 ;; Register the various minor modes settings used by Semantic.
1637 (senator-register-mode-menu-entry
1639 '(senator-minor-mode
1640 :help "Turn off Senator minor mode."
1642 '(global-senator-minor-mode
1643 :help "Automatically turn on Senator on all Semantic buffers."
1644 :save global-senator-minor-mode
1649 (senator-register-mode-menu-entry
1651 '(semantic-highlight-edits-mode
1652 :help "Highlight changes tracked by Semantic."
1654 '(global-semantic-highlight-edits-mode
1655 :help "Automatically highlight changes in all Semantic buffers."
1656 :save global-semantic-highlight-edits-mode
1658 '(semantic-highlight-edits-face)
1661 (senator-register-mode-menu-entry
1663 '(semantic-show-parser-state-mode
1664 :help "`-': OK, `!': will parse all, `~': will parse part, `@': running."
1666 '(global-semantic-show-parser-state-mode
1667 :help "Automatically show parser state in all Semantic buffers."
1668 :save global-semantic-show-parser-state-mode
1672 (senator-register-mode-menu-entry
1673 "Highlight Unmatched Syntax"
1674 '(semantic-show-unmatched-syntax-mode
1675 :help "Highlight syntax which is not recognized valid syntax."
1677 '(global-semantic-show-unmatched-syntax-mode
1678 :help "Automatically highlight unmatched syntax in all Semantic buffers."
1679 :save global-semantic-show-unmatched-syntax-mode
1681 '(semantic-unmatched-syntax-face)
1684 (senator-register-mode-menu-entry
1686 '(semantic-idle-scheduler-mode
1687 :help "Schedule idle time to automatically parse buffer following changes."
1689 '(global-semantic-idle-scheduler-mode
1690 :help "Schedule idle time to automatically parse all Semantic buffer following changes."
1691 :save global-semantic-idle-scheduler-mode
1693 '((semantic-idle-scheduler-idle-time)
1694 (semantic-idle-scheduler-max-buffer-size)
1698 (senator-register-mode-menu-entry
1700 '(semantic-idle-summary-mode
1701 :help "Show tag summaries in idle time."
1703 '(global-semantic-idle-summary-mode
1704 :help "Show tag summaries in idle time in all buffers."
1705 :save global-semantic-idle-summary-mode
1709 (senator-register-mode-menu-entry
1711 '(semantic-idle-completions-mode
1712 :help "Show completion tips in idle time."
1714 '(global-semantic-idle-completions-mode
1715 :help "Show completion tips in idle time in all buffers."
1716 :save global-semantic-idle-completions-mode
1720 (senator-register-mode-menu-entry
1722 '(semantic-stickyfunc-mode
1723 :help "Cause function declaration to become stuck to the header line."
1725 '(global-semantic-stickyfunc-mode
1726 :help "Automatically enable sticky function mode in all Semantic buffers."
1727 :save global-semantic-stickyfunc-mode
1731 (senator-register-mode-menu-entry
1733 '(semantic-decoration-mode
1734 :help "Decorate Tags."
1736 '(global-semantic-decoration-mode
1737 :help "Automatically enable decoration mode in all Semantic buffers."
1738 :save global-semantic-decoration-mode
1745 ;;;; Global minor mode to show tag names in the mode line
1749 (require 'which-func)
1754 ((boundp 'which-function-mode)
1755 'which-function-mode)
1757 ((boundp 'which-func-mode-global)
1758 'which-func-mode-global)
1760 (if (and (fboundp 'which-func-mode) select)
1761 (senator-register-mode-menu-entry
1764 (list 'which-func-mode
1766 :help "Enable `which-func-mode' and use it in Semantic buffers."
1771 (senator-register-mode-menu-entry
1774 '(semanticdb-toggle-global-mode
1775 :active (featurep 'semanticdb)
1776 :selected (and (featurep 'semanticdb) (semanticdb-minor-mode-p))
1777 :suffix (if (and (featurep 'semanticdb) (semanticdb-minor-mode-p))
1778 (if (semanticdb-write-directory-p
1779 semanticdb-current-database)
1783 :help "Cache tags for killed buffers and between sessions."
1784 :save semanticdb-global-mode
1789 ;;;; Senator minor mode
1792 (defvar senator-status nil
1793 "Minor mode status displayed in the mode line.")
1794 (make-variable-buffer-local 'senator-status)
1796 (defvar senator-isearch-semantic-mode nil
1797 "Non-nil if isearch does semantic search.
1798 This is a buffer local variable.")
1799 (make-variable-buffer-local 'senator-isearch-semantic-mode)
1801 (defvar senator-prefix-key [(control ?c) ?,]
1802 "The common prefix key in senator minor mode.")
1804 (defvar senator-prefix-map
1805 (let ((km (make-sparse-keymap)))
1806 (define-key km "f" 'senator-search-set-tag-class-filter)
1807 (define-key km "i" 'senator-isearch-toggle-semantic-mode)
1808 (define-key km "j" 'semantic-complete-jump-local) ;senator-jump)
1809 (define-key km "J" 'semantic-complete-jump)
1810 (define-key km "p" 'senator-previous-tag)
1811 (define-key km "n" 'senator-next-tag)
1812 (define-key km "u" 'senator-go-to-up-reference)
1813 (define-key km "\t" 'senator-complete-symbol)
1814 (define-key km " " 'senator-completion-menu-popup)
1815 (define-key km "\C-w" 'senator-kill-tag)
1816 (define-key km "\M-w" 'senator-copy-tag)
1817 (define-key km "\C-y" 'senator-yank-tag)
1818 (define-key km "-" 'senator-fold-tag)
1819 (define-key km "+" 'senator-unfold-tag)
1822 "Default key bindings in senator minor mode.")
1824 (defvar senator-menu-bar
1833 :help "Go to the next tag found"
1837 senator-previous-tag
1839 :help "Go to the previous tag found"
1843 senator-go-to-up-reference
1845 :help "Navigate up one reference by tag."
1848 ["Jump in this file..."
1849 semantic-complete-jump-local
1851 :help "Jump to a semantic symbol"
1854 ["Jump to any tag..."
1855 semantic-complete-jump-local
1857 :help "Jump to a semantic symbol"
1861 senator-narrow-to-defun
1862 :active (semantic-current-tag)
1863 :help "Narrow to the bounds of the current tag."
1869 ["String Forward..."
1870 senator-nonincremental-search-forward
1872 :help "Search forward for a string"
1875 ["String Backwards..."
1876 senator-nonincremental-search-backward
1878 :help "Search backwards for a string"
1881 ["Regexp Forward..."
1882 senator-nonincremental-re-search-forward
1884 :help "Search forward for a regular expression"
1887 ["Regexp Backwards..."
1888 senator-nonincremental-re-search-backward
1890 :help "Search backwards for a regular expression"
1895 senator-nonincremental-repeat-search-forward
1896 :active (or (and (eq senator-last-search-type 'string)
1898 (and (eq senator-last-search-type 'regexp)
1899 regexp-search-ring))
1900 :help "Repeat last search forward"
1904 senator-nonincremental-repeat-search-backward
1905 :active (or (and (eq senator-last-search-type 'string)
1907 (and (eq senator-last-search-type 'regexp)
1908 regexp-search-ring))
1909 :help "Repeat last search backwards"
1914 senator-search-set-tag-class-filter
1916 :help "In current buffer, limit search to certain classes of tag"
1919 ["Semantic isearch mode"
1920 senator-isearch-toggle-semantic-mode
1922 :style toggle :selected senator-isearch-semantic-mode
1923 :help "Toggle semantic search in isearch mode"
1931 :active (semantic-current-tag)
1932 :help "Copy the current tag to the tag ring"
1937 :active (semantic-current-tag)
1938 :help "Kill tag text to the kill ring, and copy the tag to the tag ring"
1943 :active (not (ring-empty-p senator-tag-ring))
1944 :help "Yank a tag from the tag ring, inserting a summary/prototype"
1947 [ "Copy Tag to Register"
1948 senator-copy-tag-to-register
1949 :active (semantic-current-tag)
1950 :help "Copy the current tag to a register"
1957 senator-fold-tag-toggle
1958 :active (semantic-current-tag)
1960 :selected (let ((tag (semantic-current-tag)))
1961 (and tag (semantic-tag-folded-p tag)))
1962 :help "Fold the current tag to one line"
1966 senator-toggle-read-only
1967 :active (semantic-current-tag)
1969 :selected (let ((tag (semantic-current-tag)))
1970 (and tag (semantic-tag-read-only-p tag)))
1971 :help "Make the current tag read-only"
1975 senator-toggle-intangible
1976 ;; XEmacs extent `intangible' property seems to not exists.
1977 :active (and (not (featurep 'xemacs))
1978 (semantic-current-tag))
1980 :selected (and (not (featurep 'xemacs))
1981 (let ((tag (semantic-current-tag)))
1982 (and tag (semantic-tag-intangible-p tag))))
1983 :help "Make the current tag intangible"
1988 :active (semantic-current-tag)
1989 :help "Set the face on the current tag"
1992 [ "Set Tag Foreground"
1993 senator-set-foreground
1994 :active (semantic-current-tag)
1995 :help "Set the foreground color on the current tag"
1998 [ "Set Tag Background"
1999 senator-set-background
2000 :active (semantic-current-tag)
2001 :help "Set the background color on the current tag"
2004 [ "Remove all properties"
2006 :active (semantic-current-tag)
2007 :help "Remove all special face properties on the current tag "
2010 (if (or (featurep 'xemacs) (> emacs-major-version 20))
2011 (list "Tag Decorations" :filter 'semantic-build-decoration-mode-menu)
2012 ;; The :filter feature seems broken in GNU Emacs versions before
2013 ;; 21.1. So dont delay the menu creation. This also means that
2014 ;; new registered decoration entries will not be added "on the
2015 ;; fly" to the menu :-(
2016 (cons "Tag Decorations" (semantic-build-decoration-mode-menu)))
2021 [ "Speedbar Class Browser"
2022 semantic-cb-speedbar-mode
2024 :help "Start speedbar in Class Broswer mode showing inheritance"
2027 [ "Speedbar Analyzer Mode"
2028 semantic-speedbar-analysis
2030 :help "Start speedbar in Context Analysis/Completion mode."
2033 [ "Context Analysis Dump"
2034 semantic-analyze-current-context
2036 :help "Show a dump of an analysis of the current local context"
2039 [ "Smart Completion Dump"
2040 semantic-analyze-possible-completions
2042 :help "Show a dump of the semantic analyzer's guess at possible completions"
2048 [ "Chart Tags by Class"
2049 semantic-chart-tags-by-class
2051 :help "Catagorize all tags by class, and chart the volume for each class"
2054 [ "Chart Tags by Complexity"
2055 semantic-chart-tag-complexity
2057 :help "Choose the most complex tags, and chart them by complexity"
2060 [ "Chart File Complexity"
2061 semantic-chart-database-size
2062 :active (and (featurep 'semanticdb) (semanticdb-minor-mode-p))
2063 :help "Choose the files with the most tags, and chart them by volume"
2066 (if (or (featurep 'xemacs) (> emacs-major-version 20))
2067 (list "Modes" :filter 'senator-build-modes-menu)
2068 ;; The :filter feature seems broken in GNU Emacs versions before
2069 ;; 21.1. So dont delay the menu creation. This also means that
2070 ;; new registered minor mode entries will not be added "on the
2071 ;; fly" to the menu :-(
2072 (cons "Modes" (senator-build-modes-menu)))
2077 "Tag Sorting Function"
2080 (setq semantic-imenu-sort-bucket-function nil)
2083 :selected (eq semantic-imenu-sort-bucket-function nil)
2084 :help "Do not sort imenu items"
2087 [ "Increasing by name"
2088 (setq semantic-imenu-sort-bucket-function
2089 'semantic-sort-tags-by-name-increasing)
2092 :selected (eq semantic-imenu-sort-bucket-function
2093 'semantic-sort-tags-by-name-increasing)
2094 :help "Sort tags by name increasing"
2097 [ "Decreasing by name"
2098 (setq semantic-imenu-sort-bucket-function
2099 'semantic-sort-tags-by-name-decreasing)
2102 :selected (eq semantic-imenu-sort-bucket-function
2103 'semantic-sort-tags-by-name-decreasing)
2104 :help "Sort tags by name decreasing"
2107 [ "Increasing Case Insensitive by Name"
2108 (setq semantic-imenu-sort-bucket-function
2109 'semantic-sort-tags-by-name-increasing-ci)
2112 :selected (eq semantic-imenu-sort-bucket-function
2113 'semantic-sort-tags-by-name-increasing-ci)
2114 :help "Sort tags by name increasing and case insensitive"
2117 [ "Decreasing Case Insensitive by Name"
2118 (setq semantic-imenu-sort-bucket-function
2119 'semantic-sort-tags-by-name-decreasing-ci)
2122 :selected (eq semantic-imenu-sort-bucket-function
2123 'semantic-sort-tags-by-name-decreasing-ci)
2124 :help "Sort tags by name decreasing and case insensitive"
2128 [ "Bin tags by class"
2129 (setq semantic-imenu-bucketize-file
2130 (not semantic-imenu-bucketize-file))
2133 :selected semantic-imenu-bucketize-file
2134 :help "Organize tags in bins by class of tag"
2137 [ "Bins are submenus"
2138 (setq semantic-imenu-buckets-to-submenu
2139 (not semantic-imenu-buckets-to-submenu))
2142 :selected semantic-imenu-buckets-to-submenu
2143 :help "Organize tags into submenus by class of tag"
2146 [ "Bin tags in components"
2147 (setq semantic-imenu-bucketize-type-members
2148 (not semantic-imenu-bucketize-type-members))
2151 :selected semantic-imenu-bucketize-type-members
2152 :help "When listing tags inside another tag; bin by tag class"
2155 [ "List other files"
2156 (setq semantic-imenu-index-directory (not semantic-imenu-index-directory))
2157 :active (and (featurep 'semanticdb) (semanticdb-minor-mode-p))
2159 :selected semantic-imenu-index-directory
2160 :help "List all files in the current database in the Imenu menu"
2163 [ "Auto-rebuild other buffers"
2164 (setq semantic-imenu-auto-rebuild-directory-indexes
2165 (not semantic-imenu-auto-rebuild-directory-indexes))
2166 :active (and (featurep 'semanticdb) (semanticdb-minor-mode-p))
2168 :selected semantic-imenu-auto-rebuild-directory-indexes
2169 :help "If listing other buffers, update all buffer menus after a parse"
2176 (customize-group "semantic")
2178 :help "Customize Semantic options"
2182 (customize-group "senator")
2184 :help "Customize SEmantic NAvigaTOR options"
2187 ["Semantic Imenu..."
2188 (customize-group "semantic-imenu")
2190 :help "Customize Semantic Imenu options"
2193 ["Semantic Database..."
2194 (customize-group "semanticdb")
2196 :help "Customize Semantic Database options"
2200 "Menu for senator minor mode.")
2202 (defvar senator-minor-menu nil
2203 "Menu keymap build from `senator-menu-bar'.")
2205 (defvar senator-mode-map
2206 (let ((km (make-sparse-keymap)))
2207 (define-key km senator-prefix-key senator-prefix-map)
2208 (define-key km [(shift mouse-3)] 'senator-completion-menu-popup)
2209 (easy-menu-define senator-minor-menu km "Senator Minor Mode Menu"
2212 "Keymap for senator minor mode.")
2214 (defvar senator-minor-mode nil
2215 "Non-nil if Senator minor mode is enabled.
2216 Use the command `senator-minor-mode' to change this variable.")
2217 (make-variable-buffer-local 'senator-minor-mode)
2219 (defconst senator-minor-mode-name "n"
2220 "Name shown in the mode line when senator minor mode is on.
2221 Not displayed if the minor mode is globally enabled.")
2223 (defconst senator-minor-mode-isearch-suffix "i"
2224 "String appended to the mode name when senator isearch mode is on.")
2226 (defun senator-mode-line-update ()
2227 "Update the modeline to show the senator minor mode state.
2228 If `senator-isearch-semantic-mode' is non-nil append
2229 `senator-minor-mode-isearch-suffix' to the value of the variable
2230 `senator-minor-mode-name'."
2231 (if (not (and senator-minor-mode senator-minor-mode-name))
2232 (setq senator-status "")
2233 (setq senator-status
2234 (format "%s%s" senator-minor-mode-name
2235 (if senator-isearch-semantic-mode
2236 (or senator-minor-mode-isearch-suffix "")
2238 (semantic-mode-line-update))
2240 (defun senator-minor-mode-setup ()
2241 "Actually setup the senator minor mode.
2242 The minor mode can be turned on only if semantic feature is available
2243 and the current buffer was set up for parsing. When minor mode is
2244 enabled parse the current buffer if needed. Return non-nil if the
2245 minor mode is enabled."
2246 (if senator-minor-mode
2247 (if (not (and (featurep 'semantic) (semantic-active-p)))
2249 ;; Disable minor mode if semantic stuff not available
2250 (setq senator-minor-mode nil)
2251 (error "Buffer %s was not set up for parsing"
2253 ;; XEmacs needs this
2254 (if (featurep 'xemacs)
2255 (easy-menu-add senator-minor-menu senator-mode-map))
2256 ;; Add completion hooks
2257 (semantic-make-local-hook
2258 'semantic-after-toplevel-cache-change-hook)
2259 (add-hook 'semantic-after-toplevel-cache-change-hook
2260 'senator-completion-cache-flush-fcn nil t)
2261 (semantic-make-local-hook
2262 'semantic-after-partial-cache-change-hook)
2263 (add-hook 'semantic-after-partial-cache-change-hook
2264 'senator-completion-cache-flush-fcn nil t))
2265 ;; XEmacs needs this
2266 (if (featurep 'xemacs)
2267 (easy-menu-remove senator-minor-menu))
2268 ;; Remove completion hooks
2269 (remove-hook 'semantic-after-toplevel-cache-change-hook
2270 'senator-completion-cache-flush-fcn t)
2271 (remove-hook 'semantic-after-partial-cache-change-hook
2272 'senator-completion-cache-flush-fcn t)
2273 ;; Disable semantic isearch
2274 (setq senator-isearch-semantic-mode nil))
2278 (defun senator-minor-mode (&optional arg)
2279 "Toggle senator minor mode.
2280 With prefix argument ARG, turn on if positive, otherwise off. The
2281 minor mode can be turned on only if semantic feature is available and
2282 the current buffer was set up for parsing. Return non-nil if the
2283 minor mode is enabled.
2285 \\{senator-mode-map}"
2287 (list (or current-prefix-arg
2288 (if senator-minor-mode 0 1))))
2289 (setq senator-minor-mode
2292 (prefix-numeric-value arg)
2294 (not senator-minor-mode)))
2295 (senator-minor-mode-setup)
2296 (run-hooks 'senator-minor-mode-hook)
2298 (message "Senator minor mode %sabled"
2299 (if senator-minor-mode "en" "dis")))
2300 (senator-mode-line-update)
2303 (semantic-add-minor-mode 'senator-minor-mode
2307 ;; To show senator isearch mode in the mode line
2308 (semantic-add-minor-mode 'senator-isearch-semantic-mode
2311 ;;; Emacs 21 goodies
2312 (and (not (featurep 'xemacs))
2313 (> emacs-major-version 20)
2316 ;; Add Senator to the the minor mode menu in the mode line
2317 (define-key mode-line-mode-menu [senator-minor-mode]
2318 `(menu-item "Senator" senator-minor-mode
2319 :button (:toggle . senator-minor-mode)
2320 :visible (and (featurep 'semantic)
2321 (semantic-active-p))))
2326 (defun global-senator-minor-mode (&optional arg)
2327 "Toggle global use of senator minor mode.
2328 If ARG is positive, enable, if it is negative, disable.
2329 If ARG is nil, then toggle."
2331 (setq global-senator-minor-mode
2332 (semantic-toggle-minor-mode-globally
2333 'senator-minor-mode arg)))
2339 (defun senator-beginning-of-defun (&optional arg)
2340 "Move backward to the beginning of a defun.
2341 Use semantic tags to navigate.
2342 ARG is the number of tags to navigate (not yet implemented)."
2343 (let* ((senator-highlight-found nil)
2344 ;; Step at beginning of next tag with class specified in
2345 ;; `senator-step-at-tag-classes'.
2346 (senator-step-at-start-end-tag-classes t)
2347 (tag (senator-previous-tag)))
2349 (if (= (point) (semantic-tag-end tag))
2350 (goto-char (semantic-tag-start tag)))
2351 (beginning-of-line))
2352 (working-message nil)))
2354 (defun senator-end-of-defun (&optional arg)
2355 "Move forward to next end of defun.
2356 Use semantic tags to navigate.
2357 ARG is the number of tags to navigate (not yet implemented)."
2358 (let* ((senator-highlight-found nil)
2359 ;; Step at end of next tag with class specified in
2360 ;; `senator-step-at-tag-classes'.
2361 (senator-step-at-start-end-tag-classes t)
2362 (tag (senator-next-tag)))
2364 (if (= (point) (semantic-tag-start tag))
2365 (goto-char (semantic-tag-end tag)))
2366 (skip-chars-forward " \t")
2367 (if (looking-at "\\s<\\|\n")
2369 (working-message nil)))
2371 (defun senator-narrow-to-defun ()
2372 "Make text outside current defun invisible.
2373 The defun visible is the one that contains point or follows point.
2374 Use semantic tags to navigate."
2378 (senator-end-of-defun)
2379 (let ((end (point)))
2380 (senator-beginning-of-defun)
2381 (narrow-to-region (point) end))))
2383 (defun senator-mark-defun ()
2384 "Put mark at end of this defun, point at beginning.
2385 The defun marked is the one that contains point or follows point.
2386 Use semantic tags to navigate."
2388 (let ((origin (point))
2389 (end (progn (senator-end-of-defun) (point)))
2390 (start (progn (senator-beginning-of-defun) (point))))
2393 (goto-char end) ;; end-of-defun
2394 (push-mark (point) nil t)
2395 (goto-char start) ;; beginning-of-defun
2396 (re-search-backward "^\n" (- (point) 1) t)))
2398 (defadvice beginning-of-defun (around senator activate)
2399 "Move backward to the beginning of a defun.
2400 If semantic tags are available, use them to navigate."
2401 (if (and senator-minor-mode (interactive-p))
2402 (senator-beginning-of-defun (ad-get-arg 0))
2405 (defadvice end-of-defun (around senator activate)
2406 "Move forward to next end of defun.
2407 If semantic tags are available, use them to navigate."
2408 (if (and senator-minor-mode (interactive-p))
2409 (senator-end-of-defun (ad-get-arg 0))
2412 (defadvice narrow-to-defun (around senator activate)
2413 "Make text outside current defun invisible.
2414 The defun visible is the one that contains point or follows point.
2415 If semantic tags are available, use them to navigate."
2416 (if (and senator-minor-mode (interactive-p))
2417 (senator-narrow-to-defun)
2420 (defadvice mark-defun (around senator activate)
2421 "Put mark at end of this defun, point at beginning.
2422 The defun marked is the one that contains point or follows point.
2423 If semantic tags are available, use them to navigate."
2424 (if (and senator-minor-mode (interactive-p))
2425 (senator-mark-defun)
2428 (defadvice c-mark-function (around senator activate)
2429 "Put mark at end of this defun, point at beginning.
2430 The defun marked is the one that contains point or follows point.
2431 If semantic tags are available, use them to navigate."
2432 (if (and senator-minor-mode (interactive-p))
2433 (senator-mark-defun)
2436 (defvar senator-add-log-tags '(function variable type)
2437 "When advising `add-log-current-defun', tag classes used.
2438 Semantic tags that are of these classes will be used to find the name
2440 (semantic-varalias-obsolete 'senator-add-log-tokens
2441 'senator-add-log-tags)
2443 (defadvice add-log-current-defun (around senator activate)
2444 "Return name of function definition point is in, or nil."
2445 (if senator-minor-mode
2446 (let ((tag (semantic-current-tag))
2448 (if (and tag (memq (semantic-tag-class tag)
2449 senator-add-log-tags))
2452 (semantic-format-tag-canonical-name
2454 (or (semantic-current-tag-parent)
2455 (if (semantic-tag-function-parent tag)
2456 (or (semantic-find-first-tag-by-name
2457 (semantic-tag-function-parent tag)
2459 (semantic-tag-function-parent
2461 (setq ad-return-value name))
2466 ;;;; Tag Cut & Paste
2469 ;; To copy a tag, means to put a tag definition into the tag
2470 ;; ring. To kill a tag, put the tag into the tag ring AND put
2471 ;; the body of the tag into the kill-ring.
2473 ;; To retrieve a killed tag's text, use C-y (yank), but to retrieve
2474 ;; the tag as a reference of some sort, use senator-yank-tag.
2476 (defvar senator-tag-ring (make-ring 20)
2477 "Ring of tags for use with cut and paste.")
2479 (make-obsolete-overload 'semantic-insert-foreign-token
2480 'semantic-insert-foreign-tag)
2482 (semantic-alias-obsolete 'senator-insert-foreign-token
2483 'semantic-insert-foreign-tag)
2485 (defun senator-copy-tag ()
2486 "Take the current tag, and place it in the tag ring."
2489 (let ((ft (semantic-obtain-foreign-tag)))
2491 (ring-insert senator-tag-ring ft)
2492 (message (semantic-format-tag-summarize ft)))
2494 (semantic-alias-obsolete 'senator-copy-token 'senator-copy-tag)
2496 (defun senator-kill-tag ()
2497 "Take the current tag, place it in the tag ring, and kill it.
2498 Killing the tag removes the text for that tag, and places it into
2499 the kill ring. Retrieve that text with \\[yank]."
2501 (let ((ct (senator-copy-tag))) ;; this handles the reparse for us.
2502 (kill-region (semantic-tag-start ct)
2503 (semantic-tag-end ct))))
2504 (semantic-alias-obsolete 'senator-kill-token 'senator-kill-tag)
2506 (defun senator-yank-tag ()
2507 "Yank a tag from the tag ring.
2508 The form the tag takes is differnet depending on where it is being
2511 (or (ring-empty-p senator-tag-ring)
2512 (let ((ft (ring-ref senator-tag-ring 0)))
2513 (semantic-foreign-tag-check ft)
2514 (semantic-insert-foreign-tag ft))))
2515 (semantic-alias-obsolete 'senator-yank-token 'senator-yank-tag)
2517 (defun senator-copy-tag-to-register (register &optional kill-flag)
2518 "Copy the current tag into REGISTER.
2519 Optional argument KILL-FLAG will delete the text of the tag to the
2521 (interactive "cTag to register: \nP")
2523 (let ((ft (semantic-obtain-foreign-tag)))
2525 (set-register register ft)
2527 (kill-region (semantic-tag-start ft)
2528 (semantic-tag-end ft))))))
2529 (semantic-alias-obsolete 'senator-copy-token-to-register
2530 'senator-copy-tag-to-register)
2532 (defadvice insert-register (around senator activate)
2533 "Insert contents of register REGISTER as a tag.
2534 If senator is not active, use the original mechanism."
2535 (let ((val (get-register (ad-get-arg 0))))
2536 (if (and senator-minor-mode (interactive-p)
2537 (semantic-foreign-tag-p val))
2538 (semantic-insert-foreign-tag val)
2541 (defadvice jump-to-register (around senator activate)
2542 "Insert contents of register REGISTER as a tag.
2543 If senator is not active, use the original mechanism."
2544 (let ((val (get-register (ad-get-arg 0))))
2545 (if (and senator-minor-mode (interactive-p)
2546 (semantic-foreign-tag-p val))
2548 (switch-to-buffer (semantic-tag-buffer val))
2549 (goto-char (semantic-tag-start val)))
2552 (defun senator-transpose-tags-up ()
2553 "Transpose the current tag, and the preceeding tag."
2556 (let* ((current-tag (semantic-current-tag))
2557 (prev-tag (save-excursion
2558 (goto-char (semantic-tag-start current-tag))
2559 (semantic-find-tag-by-overlay-prev)))
2560 (ct-parent (semantic-find-tag-parent-by-overlay current-tag))
2561 (pt-parent (semantic-find-tag-parent-by-overlay prev-tag)))
2562 (if (not (eq ct-parent pt-parent))
2563 (error "Cannot transpose tags"))
2564 (let ((txt (buffer-substring (semantic-tag-start current-tag)
2565 (semantic-tag-end current-tag)))
2566 (line (count-lines (semantic-tag-start current-tag)
2570 (delete-region (semantic-tag-start current-tag)
2571 (semantic-tag-end current-tag))
2572 (delete-blank-lines)
2573 (goto-char (semantic-tag-start prev-tag))
2574 (setq insert-point (point))
2576 (if (/= (current-column) 0)
2579 (goto-char insert-point)
2583 (defun senator-transpose-tags-down ()
2584 "Transpose the current tag, and the following tag."
2587 (let* ((current-tag (semantic-current-tag))
2588 (next-tag (save-excursion
2589 (goto-char (semantic-tag-end current-tag))
2590 (semantic-find-tag-by-overlay-next)))
2591 (end-pt (point-marker))
2593 (goto-char (semantic-tag-start next-tag))
2595 (senator-transpose-tags-up)
2596 ;; I know that the above fcn deletes the next tag, so our pt marker
2598 (goto-char end-pt)))
2602 ;; Senator has a nice completion mechanism. Use it to add a new
2603 ;; hippie expand try method.
2605 (eval-when-compile (require 'hippie-exp))
2607 (defvar senator-try-function-already-enabled nil
2608 "Non-nil if `hippie-expand' semantic completion was already enabled.
2609 This flag remember `senator-hippie-expand-hook' to not remove
2610 `senator-try-expand-semantic' from `hippie-expand-try-functions-list'
2611 if it was previously put here by any sort of user's customization.")
2613 (defun senator-hippie-expand-hook ()
2614 "Enable or disable use of semantic completion with `hippie-expand'.
2615 Depending on the value of the variable `senator-minor-mode'.
2616 Run as `senator-minor-mode-hook'."
2617 (make-local-variable 'hippie-expand-try-functions-list)
2618 (make-local-variable 'senator-try-function-already-enabled)
2619 (if senator-minor-mode
2621 ;; Does nothing if semantic completion is already enabled (via
2622 ;; customization for example).
2623 (setq senator-try-function-already-enabled
2624 (memq 'senator-try-expand-semantic
2625 hippie-expand-try-functions-list))
2626 (or senator-try-function-already-enabled
2627 (setq hippie-expand-try-functions-list
2628 (cons 'senator-try-expand-semantic
2629 hippie-expand-try-functions-list))))
2630 ;; Does nothing if semantic completion wasn't enabled here.
2631 (or senator-try-function-already-enabled
2632 (setq hippie-expand-try-functions-list
2633 (delq 'senator-try-expand-semantic
2634 hippie-expand-try-functions-list)))))
2636 (add-hook 'senator-minor-mode-hook 'senator-hippie-expand-hook)
2639 (defun senator-try-expand-semantic (old)
2640 "Attempt inline completion at the cursor.
2641 Use Semantic, or the semantic database to look up possible
2642 completions. The argument OLD has to be nil the first call of this
2643 function. It returns t if a unique, possibly partial, completion is
2644 found, nil otherwise."
2645 (if (semantic-active-p)
2647 ;; If the hippie says so, start over.
2649 (if (setq symstart (senator-current-symbol-start))
2651 (he-init-string symstart (point))
2652 (setq senator-last-completion-stats nil))))
2653 ;; do completion with senator's mechanism.
2654 (when (or old symstart)
2655 ;; This bit will turn off parsing on lexical errors.
2656 (semantic-lex-catch-errors senator-hippie-expand
2657 (semantic-fetch-tags))
2658 ;; Do the completion
2659 (let ((ret (senator-complete-symbol t)))
2661 ;; Found a new completion, update the end marker.
2662 (set-marker he-string-end (point))
2663 ;; Update the tried table so other hippie expand
2664 ;; try functions can see whether an expansion has
2665 ;; already been tried.
2666 (setq he-tried-table (cons ret he-tried-table)))
2667 ;; No more completion
2669 ;; Reset the initial completed string for other
2670 ;; hippie-expand try functions.
2675 ;;;; Using semantic search in isearch mode
2680 ( ;; GNU Emacs 21.0 lazy highlighting
2681 (fboundp 'isearch-lazy-highlight-cleanup)
2683 ;; Provide this function used by senator
2684 (defun senator-lazy-highlight-update ()
2685 "Force lazy highlight update."
2686 (funcall 'isearch-lazy-highlight-cleanup t)
2687 (set 'isearch-lazy-highlight-last-string nil)
2688 (setq isearch-adjusted t)
2691 ) ;; End of GNU Emacs 21 lazy highlighting
2693 ( ;; XEmacs 21.4 lazy highlighting
2694 (fboundp 'isearch-highlight-all-cleanup)
2696 ;; Provide this function used by senator
2697 (defun senator-lazy-highlight-update ()
2698 "Force lazy highlight update."
2699 (funcall 'isearch-highlight-all-cleanup)
2700 (set 'isearch-highlight-last-string nil)
2701 (setq isearch-adjusted t)
2704 ) ;; End of XEmacs 21.4 Write failed flushing stdout buffer.
\r
2705 write stdout: Broken pipe
\r
2708 ( ;; GNU Emacs 20 lazy highlighting via ishl
2709 (fboundp 'ishl-cleanup)
2711 ;; Provide this function used by senator
2712 (defun senator-lazy-highlight-update ()
2713 "Force lazy highlight update."
2714 (funcall 'ishl-cleanup t)
2715 (set 'ishl-last-string nil)
2716 (setq isearch-adjusted t)
2719 ) ;; End of GNU Emacs 20 lazy highlighting
2721 (t ;; No lazy highlighting
2723 ;; Ignore this function used by senator
2724 (defalias 'senator-lazy-highlight-update 'ignore)
2728 (defmacro senator-define-search-advice (searcher)
2729 "Advice the built-in SEARCHER function to do semantic search.
2730 That is to call the Senator counterpart searcher when variables
2731 `isearch-mode' and `senator-isearch-semantic-mode' are non-nil."
2732 (let ((senator-searcher (intern (format "senator-%s" searcher))))
2733 `(defadvice ,searcher (around senator activate)
2734 (if (and isearch-mode senator-isearch-semantic-mode
2735 ;; The following condition ensure to do a senator
2736 ;; semantic search on the `isearch-string' only!
2737 (string-equal (ad-get-arg 0) isearch-string))
2740 ;; Temporarily set `senator-isearch-semantic-mode' to
2741 ;; nil to avoid an infinite recursive call of the
2742 ;; senator semantic search function!
2743 (setq senator-isearch-semantic-mode nil)
2744 (setq ad-return-value
2745 (funcall ',senator-searcher
2746 (ad-get-arg 0) ; string
2747 (ad-get-arg 1) ; bound
2748 (ad-get-arg 2) ; no-error
2749 (ad-get-arg 3) ; count
2751 (setq senator-isearch-semantic-mode t))
2754 ;; Recent versions of GNU Emacs allow to override the isearch search
2755 ;; function for special needs, and avoid to advice the built-in search
2757 (defun senator-isearch-search-fun ()
2758 "Return the function to use for the search.
2759 Use a senator search function when semantic isearch mode is enabled."
2761 (concat (if senator-isearch-semantic-mode
2764 (cond (isearch-word "word-")
2765 (isearch-regexp "re-")
2772 (unless (boundp 'isearch-search-fun-function)
2773 ;; Advice the built-in search functions to do semantic search when
2774 ;; `isearch-mode' and `senator-isearch-semantic-mode' are on.
2775 (senator-define-search-advice search-forward)
2776 (senator-define-search-advice re-search-forward)
2777 (senator-define-search-advice word-search-forward)
2778 (senator-define-search-advice search-backward)
2779 (senator-define-search-advice re-search-backward)
2780 (senator-define-search-advice word-search-backward)
2782 ;;; End of compatibility stuff
2784 (defun senator-isearch-toggle-semantic-mode ()
2785 "Toggle semantic searching on or off in isearch mode.
2786 \\<senator-mode-map>\\[senator-isearch-toggle-semantic-mode] toggle semantic searching."
2788 (when senator-minor-mode
2789 (setq senator-isearch-semantic-mode
2790 (not senator-isearch-semantic-mode))
2791 (senator-mode-line-update)
2793 ;; force lazy highlight update
2794 (senator-lazy-highlight-update)
2795 (working-message "Isearch semantic mode %s"
2796 (if senator-isearch-semantic-mode
2800 ;; Needed by XEmacs isearch to not terminate isearch mode when
2801 ;; toggling semantic search.
2802 (put 'senator-isearch-toggle-semantic-mode 'isearch-command t)
2804 ;; Keyboard shortcut to toggle semantic search in isearch mode.
2805 (define-key isearch-mode-map
2807 'senator-isearch-toggle-semantic-mode)
2809 (defun senator-isearch-mode-hook ()
2810 "Isearch mode hook to setup semantic searching."
2811 (or senator-minor-mode
2812 (setq senator-isearch-semantic-mode nil))
2813 (when (boundp 'isearch-search-fun-function)
2814 (if (and isearch-mode senator-isearch-semantic-mode)
2815 (set (make-local-variable 'isearch-search-fun-function)
2816 'senator-isearch-search-fun)
2817 (kill-local-variable 'isearch-search-fun-function)))
2818 (senator-mode-line-update))
2820 (add-hook 'isearch-mode-hook 'senator-isearch-mode-hook)
2821 (add-hook 'isearch-mode-end-hook 'senator-isearch-mode-hook)
2825 ;;; senator.el ends here