lisp/cedet/semantic/senator.el

   1 ;;; semantic/senator.el --- SEmantic NAvigaTOR
   2
   3 ;; Copyright (C) 2000-2017 Free Software Foundation, Inc.
   4
   5 ;; Author: David Ponce <david@dponce.com>
   6 ;; Maintainer: emacs-devel@gnu.org
   7 ;; Created: 10 Nov 2000
   8 ;; Keywords: syntax
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26 ;;
  27 ;; This file defines some user commands for navigating between
  28 ;; Semantic tags.  This is a subset of the version of senator.el in
  29 ;; the upstream CEDET package; the rest is incorporated into other
  30 ;; parts of Semantic or Emacs.
  31
  32 ;;; Code:
  33
  34 (require 'ring)
  35 (require 'semantic)
  36 (require 'semantic/ctxt)
  37 (require 'semantic/decorate)
  38 (require 'semantic/format)
  39
  40 (eval-when-compile (require 'semantic/find))
  41
  42 ;; (eval-when-compile (require 'hippie-exp))
  43
  44 (declare-function semantic-analyze-tag-references "semantic/analyze/refs")
  45 (declare-function semantic-analyze-refs-impl "semantic/analyze/refs")
  46 (declare-function semantic-analyze-find-tag "semantic/analyze")
  47 (declare-function semantic-analyze-tag-type "semantic/analyze/fcn")
  48 (declare-function semantic-tag-external-class "semantic/sort")
  49 (declare-function imenu--mouse-menu "imenu")
  50
  51 ;;; Customization
  52 (defgroup senator nil
  53   "Semantic Navigator."
  54   :group 'semantic)
  55
  56 ;;;###autoload
  57 (defcustom senator-step-at-tag-classes nil
  58   "List of tag classes recognized by Senator's navigation commands.
  59 A tag class is a symbol, such as `variable', `function', or `type'.
  60
  61 As a special exception, if the value is nil, Senator's navigation
  62 commands recognize all tag classes."
  63   :group 'senator
  64   :type '(repeat (symbol)))
  65 ;;;###autoload
  66 (make-variable-buffer-local 'senator-step-at-tag-classes)
  67
  68 ;;;###autoload
  69 (defcustom senator-step-at-start-end-tag-classes nil
  70   "List of tag classes at which Senator's navigation commands should stop.
  71 A tag class is a symbol, such as `variable', `function', or `type'.
  72 The navigation commands stop at the start and end of each tag
  73 class in this list, provided the tag class is recognized (see
  74 `senator-step-at-tag-classes').
  75
  76 As a special exception, if the value is nil, the navigation
  77 commands stop at the beginning of every tag.
  78
  79 If t, the navigation commands stop at the start and end of any
  80 tag, where possible."
  81   :group 'senator
  82   :type '(choice :tag "Identifiers"
  83                  (repeat :menu-tag "Symbols" (symbol))
  84                  (const  :tag "All" t)))
  85 ;;;###autoload
  86 (make-variable-buffer-local 'senator-step-at-start-end-tag-classes)
  87
  88 (defcustom senator-highlight-found nil
  89   "If non-nil, Senator commands momentarily highlight found tags."
  90   :group 'senator
  91   :type 'boolean)
  92 (make-variable-buffer-local 'senator-highlight-found)
  93
  94 ;;; Faces
  95 (defface senator-momentary-highlight-face
  96   '((((class color) (background dark))
  97      (:background "gray30"))
  98     (((class color) (background light))
  99      (:background "gray70")))
 100   "Face used to momentarily highlight tags."
 101   :group 'semantic-faces)
 102
 103 ;;; Common functions
 104
 105 (defun senator-momentary-highlight-tag (tag)
 106   "Momentarily highlight TAG.
 107 Does nothing if `senator-highlight-found' is nil."
 108   (and senator-highlight-found
 109        (semantic-momentary-highlight-tag
 110         tag 'senator-momentary-highlight-face)))
 111
 112 (defun senator-step-at-start-end-p (tag)
 113   "Return non-nil if must step at start and end of TAG."
 114   (and tag
 115        (or (eq senator-step-at-start-end-tag-classes t)
 116            (memq (semantic-tag-class tag)
 117                  senator-step-at-start-end-tag-classes))))
 118
 119 (defun senator-skip-p (tag)
 120   "Return non-nil if must skip TAG."
 121   (and tag
 122        senator-step-at-tag-classes
 123        (not (memq (semantic-tag-class tag)
 124                   senator-step-at-tag-classes))))
 125
 126 (defun senator-middle-of-tag-p (pos tag)
 127   "Return non-nil if POS is between start and end of TAG."
 128   (and (> pos (semantic-tag-start tag))
 129        (< pos (semantic-tag-end   tag))))
 130
 131 (defun senator-step-at-parent (tag)
 132   "Return TAG's outermost parent if must step at start/end of it.
 133 Return nil otherwise."
 134   (if tag
 135       (let (parent parents)
 136         (setq parents (semantic-find-tag-by-overlay
 137                        (semantic-tag-start tag)))
 138         (while (and parents (not parent))
 139           (setq parent  (car parents)
 140                 parents (cdr parents))
 141           (if (or (eq tag parent)
 142                   (senator-skip-p parent)
 143                   (not (senator-step-at-start-end-p parent)))
 144               (setq parent nil)))
 145         parent)))
 146
 147 (defun senator-previous-tag-or-parent (pos)
 148   "Return the tag before POS or one of its parent where to step."
 149   (let (ol tag)
 150     (while (and pos (> pos (point-min)) (not tag))
 151       (setq pos (semantic-overlay-previous-change pos))
 152       (when pos
 153         ;; Get overlays at position
 154         (setq ol (semantic-overlays-at pos))
 155         ;; find the overlay that belongs to semantic
 156         ;; and STARTS or ENDS at the found position.
 157         (while (and ol (not tag))
 158           (setq tag (semantic-overlay-get (car ol) 'semantic))
 159           (unless (and tag (semantic-tag-p tag)
 160                        (or (= (semantic-tag-start tag) pos)
 161                            (= (semantic-tag-end   tag) pos)))
 162             (setq tag nil
 163                   ol (cdr ol))))))
 164     (or (senator-step-at-parent tag) tag)))
 165
 166 ;;; Search functions
 167
 168 (defun senator-search-tag-name (tag)
 169   "Search for TAG name in current buffer.
 170 Limit the search to TAG bounds.
 171 If found, set point to the end of the name, and return point.  The
 172 beginning of the name is at (match-beginning 0).
 173 Return nil if not found, that is if TAG name doesn't come from the
 174 source."
 175   (let ((name (semantic-tag-name tag)))
 176     (setq name (if (string-match "\\`\\([^[]+\\)[[]" name)
 177                    (match-string 1 name)
 178                  name))
 179     (goto-char (semantic-tag-start tag))
 180     (when (re-search-forward (concat
 181                               ;; The tag name is expected to be
 182                               ;; between word delimiters, whitespace,
 183                               ;; or punctuation.
 184                               "\\(\\<\\|\\s-+\\|\\s.\\)"
 185                               (regexp-quote name)
 186                               "\\(\\>\\|\\s-+\\|\\s.\\)")
 187                              (semantic-tag-end tag)
 188                              t)
 189       (goto-char (match-beginning 0))
 190       (search-forward name))))
 191
 192 (defcustom senator-search-ignore-tag-classes
 193   '(code block)
 194   "List of ignored tag classes.
 195 Tags of those classes are excluded from search."
 196   :group 'senator
 197   :type '(repeat (symbol :tag "class")))
 198
 199 (defun senator-search-default-tag-filter (tag)
 200   "Default function that filters searched tags.
 201 Ignore tags of classes in `senator-search-ignore-tag-classes'"
 202   (not (memq (semantic-tag-class tag)
 203              senator-search-ignore-tag-classes)))
 204
 205 (defvar senator-search-tag-filter-functions
 206   '(senator-search-default-tag-filter)
 207   "List of functions to be called to filter searched tags.
 208 Each function is passed a tag.  If one of them returns nil, the tag is
 209 excluded from the search.")
 210
 211 (defun senator-search (searcher text &optional bound noerror count)
 212   "Use the SEARCHER function to search from point for TEXT in a tag name.
 213 SEARCHER is typically the function `search-forward', `search-backward',
 214 `word-search-forward', `word-search-backward', `re-search-forward', or
 215 `re-search-backward'.  See one of the above function to see how the
 216 TEXT, BOUND, NOERROR, and COUNT arguments are interpreted."
 217   (let* ((origin (point))
 218          (count  (or count 1))
 219          (step   (cond ((> count 0) 1)
 220                        ((< count 0) (setq count (- count)) -1)
 221                        (0)))
 222          found next sstart send tag tstart tend)
 223     (or (zerop step)
 224         (while (and (not found)
 225                     (setq next (funcall searcher text bound t step)))
 226           (setq sstart (match-beginning 0)
 227                 send   (match-end 0))
 228           (if (= sstart send)
 229               (setq found t)
 230             (and (setq tag (semantic-current-tag))
 231                  (run-hook-with-args-until-failure
 232                   'senator-search-tag-filter-functions tag)
 233                  (setq tend   (senator-search-tag-name tag))
 234                  (setq tstart (match-beginning 0)
 235                        found  (and (>= sstart tstart)
 236                                    (<= send tend)
 237                                    (zerop (setq count (1- count))))))
 238             (goto-char next))))
 239     (cond ((null found)
 240            (setq next origin
 241                  send origin))
 242           ((= next sstart)
 243            (setq next send
 244                  send sstart))
 245           (t
 246            (setq next sstart)))
 247     (goto-char next)
 248     ;; Setup the returned value and the `match-data' or maybe fail!
 249     (funcall searcher text send noerror step)))
 250
 251 ;;; Navigation commands
 252
 253 ;;;###autoload
 254 (defun senator-next-tag ()
 255   "Navigate to the next Semantic tag.
 256 Return the tag or nil if at end of buffer."
 257   (interactive)
 258   (semantic-error-if-unparsed)
 259   (let ((pos (point))
 260         (tag (semantic-current-tag))
 261         where)
 262     (if (and tag
 263              (not (senator-skip-p tag))
 264              (senator-step-at-start-end-p tag)
 265              (or (= pos (semantic-tag-start tag))
 266                  (senator-middle-of-tag-p pos tag)))
 267         nil
 268       (if (setq tag (senator-step-at-parent tag))
 269           nil
 270         (setq tag (semantic-find-tag-by-overlay-next pos))
 271         (while (and tag (senator-skip-p tag))
 272           (setq tag (semantic-find-tag-by-overlay-next
 273                        (semantic-tag-start tag))))))
 274     (if (not tag)
 275         (progn
 276           (goto-char (point-max))
 277           (message "End of buffer"))
 278       (cond ((and (senator-step-at-start-end-p tag)
 279                   (or (= pos (semantic-tag-start tag))
 280                       (senator-middle-of-tag-p pos tag)))
 281              (setq where "end")
 282              (goto-char (semantic-tag-end tag)))
 283             (t
 284              (setq where "start")
 285              (goto-char (semantic-tag-start tag))))
 286       (senator-momentary-highlight-tag tag)
 287       (message "%S: %s (%s)"
 288                (semantic-tag-class tag)
 289                (semantic-tag-name  tag)
 290                where))
 291     tag))
 292
 293 ;;;###autoload
 294 (defun senator-previous-tag ()
 295   "Navigate to the previous Semantic tag.
 296 Return the tag or nil if at beginning of buffer."
 297   (interactive)
 298   (semantic-error-if-unparsed)
 299   (let ((pos (point))
 300         (tag (semantic-current-tag))
 301         where)
 302     (if (and tag
 303              (not (senator-skip-p tag))
 304              (senator-step-at-start-end-p tag)
 305              (or (= pos (semantic-tag-end tag))
 306                  (senator-middle-of-tag-p pos tag)))
 307         nil
 308       (if (setq tag (senator-step-at-parent tag))
 309           nil
 310         (setq tag (senator-previous-tag-or-parent pos))
 311         (while (and tag (senator-skip-p tag))
 312           (setq tag (senator-previous-tag-or-parent
 313                        (semantic-tag-start tag))))))
 314     (if (not tag)
 315         (progn
 316           (goto-char (point-min))
 317           (message "Beginning of buffer"))
 318       (cond ((or (not (senator-step-at-start-end-p tag))
 319                  (= pos (semantic-tag-end tag))
 320                  (senator-middle-of-tag-p pos tag))
 321              (setq where "start")
 322              (goto-char (semantic-tag-start tag)))
 323             (t
 324              (setq where "end")
 325              (goto-char (semantic-tag-end tag))))
 326       (senator-momentary-highlight-tag tag)
 327       (message "%S: %s (%s)"
 328                (semantic-tag-class tag)
 329                (semantic-tag-name  tag)
 330                where))
 331     tag))
 332
 333 ;;; Search commands
 334
 335 (defun senator-search-forward (string &optional bound noerror count)
 336   "Search in tag names forward from point for STRING.
 337 Set point to the end of the occurrence found, and return point.
 338 See also the function `search-forward' for details on the BOUND,
 339 NOERROR and COUNT arguments."
 340   (interactive "sSemantic search: ")
 341   (senator-search 'search-forward string bound noerror count))
 342
 343 (defun senator-re-search-forward (regexp &optional bound noerror count)
 344   "Search in tag names forward from point for regular expression REGEXP.
 345 Set point to the end of the occurrence found, and return point.
 346 See also the function `re-search-forward' for details on the BOUND,
 347 NOERROR and COUNT arguments."
 348   (interactive "sSemantic regexp search: ")
 349   (senator-search 're-search-forward regexp bound noerror count))
 350
 351 (defun senator-word-search-forward (word &optional bound noerror count)
 352   "Search in tag names forward from point for WORD.
 353 Set point to the end of the occurrence found, and return point.
 354 See also the function `word-search-forward' for details on the BOUND,
 355 NOERROR and COUNT arguments."
 356   (interactive "sSemantic word search: ")
 357   (senator-search 'word-search-forward word bound noerror count))
 358
 359 (defun senator-search-backward (string &optional bound noerror count)
 360   "Search in tag names backward from point for STRING.
 361 Set point to the beginning of the occurrence found, and return point.
 362 See also the function `search-backward' for details on the BOUND,
 363 NOERROR and COUNT arguments."
 364   (interactive "sSemantic backward search: ")
 365   (senator-search 'search-backward string bound noerror count))
 366
 367 (defun senator-re-search-backward (regexp &optional bound noerror count)
 368   "Search in tag names backward from point for regular expression REGEXP.
 369 Set point to the beginning of the occurrence found, and return point.
 370 See also the function `re-search-backward' for details on the BOUND,
 371 NOERROR and COUNT arguments."
 372   (interactive "sSemantic backward regexp search: ")
 373   (senator-search 're-search-backward regexp bound noerror count))
 374
 375 (defun senator-word-search-backward (word &optional bound noerror count)
 376   "Search in tag names backward from point for WORD.
 377 Set point to the beginning of the occurrence found, and return point.
 378 See also the function `word-search-backward' for details on the BOUND,
 379 NOERROR and COUNT arguments."
 380   (interactive "sSemantic backward word search: ")
 381   (senator-search 'word-search-backward word bound noerror count))
 382
 383 ;;; Other useful search commands (minor mode menu)
 384
 385 (defvar senator-last-search-type nil
 386   "Type of last non-incremental search command called.")
 387
 388 (defun senator-nonincremental-repeat-search-forward ()
 389   "Search forward for the previous search string or regexp."
 390   (interactive)
 391   (cond
 392    ((and (eq senator-last-search-type 'string)
 393          search-ring)
 394     (senator-search-forward (car search-ring)))
 395    ((and (eq senator-last-search-type 'regexp)
 396          regexp-search-ring)
 397     (senator-re-search-forward (car regexp-search-ring)))
 398    (t
 399     (error "No previous search"))))
 400
 401 (defun senator-nonincremental-repeat-search-backward ()
 402   "Search backward for the previous search string or regexp."
 403   (interactive)
 404   (cond
 405    ((and (eq senator-last-search-type 'string)
 406          search-ring)
 407     (senator-search-backward (car search-ring)))
 408    ((and (eq senator-last-search-type 'regexp)
 409          regexp-search-ring)
 410     (senator-re-search-backward (car regexp-search-ring)))
 411    (t
 412     (error "No previous search"))))
 413
 414 (defun senator-nonincremental-search-forward (string)
 415   "Search for STRING nonincrementally."
 416   (interactive "sSemantic search for string: ")
 417   (setq senator-last-search-type 'string)
 418   (if (equal string "")
 419       (senator-search-forward (car search-ring))
 420     (isearch-update-ring string nil)
 421     (senator-search-forward string)))
 422
 423 (defun senator-nonincremental-search-backward (string)
 424   "Search backward for STRING nonincrementally."
 425   (interactive "sSemantic search for string: ")
 426   (setq senator-last-search-type 'string)
 427   (if (equal string "")
 428       (senator-search-backward (car search-ring))
 429     (isearch-update-ring string nil)
 430     (senator-search-backward string)))
 431
 432 (defun senator-nonincremental-re-search-forward (string)
 433   "Search for the regular expression STRING nonincrementally."
 434   (interactive "sSemantic search for regexp: ")
 435   (setq senator-last-search-type 'regexp)
 436   (if (equal string "")
 437       (senator-re-search-forward (car regexp-search-ring))
 438     (isearch-update-ring string t)
 439     (senator-re-search-forward string)))
 440
 441 (defun senator-nonincremental-re-search-backward (string)
 442   "Search backward for the regular expression STRING nonincrementally."
 443   (interactive "sSemantic search for regexp: ")
 444   (setq senator-last-search-type 'regexp)
 445   (if (equal string "")
 446       (senator-re-search-backward (car regexp-search-ring))
 447     (isearch-update-ring string t)
 448     (senator-re-search-backward string)))
 449
 450 (defvar senator--search-filter nil)
 451
 452 (defun senator-search-set-tag-class-filter (&optional classes)
 453   "In current buffer, limit search scope to tag CLASSES.
 454 CLASSES is a list of tag class symbols or nil.  If nil only global
 455 filters in `senator-search-tag-filter-functions' remain active."
 456   (interactive "sClasses: ")
 457   (setq classes
 458         (cond
 459          ((null classes)
 460           nil)
 461          ((symbolp classes)
 462           (list classes))
 463          ((stringp classes)
 464           (mapcar 'read (split-string classes)))
 465          (t
 466           (signal 'wrong-type-argument (list classes)))
 467          ))
 468   ;; Clear previous filter.
 469   (remove-hook 'senator-search-tag-filter-functions
 470                senator--search-filter t)
 471   (kill-local-variable 'senator--search-filter)
 472   (if classes
 473       (let ((tag   (make-symbol "tag"))
 474             (names (mapconcat 'symbol-name classes "', `")))
 475         (set (make-local-variable 'senator--search-filter)
 476              `(lambda (,tag)
 477                 (memq (semantic-tag-class ,tag) ',classes)))
 478         (add-hook 'senator-search-tag-filter-functions
 479                   senator--search-filter nil t)
 480         (message "Limit search to `%s' tags" names))
 481     (message "Default search filter restored")))
 482
 483 ;;; Folding
 484 ;;
 485 ;; Use new folding state.  It might be wise to extend the idea
 486 ;; of folding for hiding all but this, or show all children, etc.
 487
 488 (defun senator-fold-tag (&optional tag)
 489   "Fold the current TAG."
 490   (interactive)
 491   (semantic-set-tag-folded (or tag (semantic-current-tag)) t))
 492
 493 (defun senator-unfold-tag (&optional tag)
 494   "Fold the current TAG."
 495   (interactive)
 496   (semantic-set-tag-folded (or tag (semantic-current-tag)) nil))
 497
 498 (defun senator-fold-tag-toggle (&optional tag)
 499   "Fold the current TAG."
 500   (interactive)
 501   (let ((tag (or tag (semantic-current-tag))))
 502     (if (semantic-tag-folded-p tag)
 503         (senator-unfold-tag tag)
 504       (senator-fold-tag tag))))
 505
 506 ;; @TODO - move this to some analyzer / refs tool
 507 (define-overloadable-function semantic-up-reference (tag)
 508   "Return a tag that is referred to by TAG.
 509 A \"reference\" could be any interesting feature of TAG.
 510 In C++, a function may have a `parent' which is non-local.
 511 If that parent which is only a reference in the function tag
 512 is found, we can jump to it.
 513 Some tags such as includes have other reference features.")
 514
 515 ;;;###autoload
 516 (defun senator-go-to-up-reference (&optional tag)
 517   "Move up one reference from the current TAG.
 518 A \"reference\" could be any interesting feature of TAG.
 519 In C++, a function may have a `parent' which is non-local.
 520 If that parent which is only a reference in the function tag
 521 is found, we can jump to it.
 522 Some tags such as includes have other reference features."
 523   (interactive)
 524   (semantic-error-if-unparsed)
 525   (let ((result (semantic-up-reference (or tag (semantic-current-tag)))))
 526     (if (not result)
 527         (error "No up reference found")
 528       (push-mark)
 529       (cond
 530        ;; A tag
 531        ((semantic-tag-p result)
 532         (semantic-go-to-tag result)
 533         (switch-to-buffer (current-buffer))
 534         (semantic-momentary-highlight-tag result))
 535        ;; Buffers
 536        ((bufferp result)
 537         (switch-to-buffer result)
 538         (pulse-momentary-highlight-one-line (point)))
 539        ;; Files
 540        ((and (stringp result) (file-exists-p result))
 541         (find-file result)
 542         (pulse-momentary-highlight-one-line (point)))
 543        (t
 544         (error "Unknown result type from `semantic-up-reference'"))))))
 545
 546 (defun semantic-up-reference-default (tag)
 547   "Return a tag that is referred to by TAG.
 548 Makes C/C++ language like assumptions."
 549   (cond ((semantic-tag-faux-p tag)
 550          ;; Faux tags should have a real tag in some other location.
 551          (require 'semantic/sort)
 552          (let ((options (semantic-tag-external-class tag)))
 553            ;; I should do something a little better than
 554            ;; this.  Oy!
 555            (car options)
 556            ))
 557
 558         ;; Include always point to another file.
 559         ((eq (semantic-tag-class tag) 'include)
 560          (let ((file (semantic-dependency-tag-file tag)))
 561            (cond
 562             ((or (not file) (not (file-exists-p file)))
 563              (error "Could not location include %s"
 564                     (semantic-tag-name tag)))
 565             ((get-file-buffer file)
 566              (get-file-buffer file))
 567             ((stringp file)
 568              file)
 569             )))
 570
 571         ;; Is there a parent of the function to jump to?
 572         ((and (semantic-tag-of-class-p tag 'function)
 573               (semantic-tag-function-parent tag))
 574          (let* ((scope (semantic-calculate-scope (point))))
 575            ;; @todo - it would be cool to ask the user which one if
 576            ;; more than one.
 577            (car (oref scope parents))
 578            ))
 579
 580         ;; Is there a non-prototype version of the tag to jump to?
 581         ((semantic-tag-get-attribute tag :prototype-flag)
 582          (require 'semantic/analyze/refs)
 583          (let* ((sar (semantic-analyze-tag-references tag)))
 584            (car (semantic-analyze-refs-impl sar t)))
 585          )
 586
 587         ;; If this is a datatype, and we have superclasses
 588         ((and (semantic-tag-of-class-p tag 'type)
 589               (semantic-tag-type-superclasses tag))
 590          (require 'semantic/analyze)
 591          (let ((scope (semantic-calculate-scope (point)))
 592                (parents (semantic-tag-type-superclasses tag)))
 593            (semantic-analyze-find-tag (car parents) 'type scope)))
 594
 595         ;; Get the data type, and try to find that.
 596         ((semantic-tag-type tag)
 597          (require 'semantic/analyze)
 598          (let ((scope (semantic-calculate-scope (point))))
 599            (semantic-analyze-tag-type tag scope))
 600          )
 601         (t nil)))
 602
 603 (defvar senator-isearch-semantic-mode nil
 604   "Non-nil if isearch does semantic search.
 605 This is a buffer local variable.")
 606 (make-variable-buffer-local 'senator-isearch-semantic-mode)
 607
 608 (defun senator-beginning-of-defun (&optional arg)
 609   "Move backward to the beginning of a defun.
 610 Use semantic tags to navigate.
 611 ARG is the number of tags to navigate (not yet implemented)."
 612   (semantic-fetch-tags)
 613   (let* ((senator-highlight-found nil)
 614          ;; Step at beginning of next tag with class specified in
 615          ;; `senator-step-at-tag-classes'.
 616          (senator-step-at-start-end-tag-classes t)
 617          (tag (senator-previous-tag)))
 618     (when tag
 619       (if (= (point) (semantic-tag-end tag))
 620           (goto-char (semantic-tag-start tag)))
 621       (beginning-of-line))))
 622
 623 (defun senator-end-of-defun (&optional arg)
 624   "Move forward to next end of defun.
 625 Use semantic tags to navigate.
 626 ARG is the number of tags to navigate (not yet implemented)."
 627   (semantic-fetch-tags)
 628   (let* ((senator-highlight-found nil)
 629          ;; Step at end of next tag with class specified in
 630          ;; `senator-step-at-tag-classes'.
 631          (senator-step-at-start-end-tag-classes t)
 632          (tag (senator-next-tag)))
 633     (when tag
 634       (if (= (point) (semantic-tag-start tag))
 635           (goto-char (semantic-tag-end tag)))
 636       (skip-chars-forward " \t")
 637       (if (looking-at "\\s<\\|\n")
 638           (forward-line 1)))))
 639
 640 (defun senator-narrow-to-defun ()
 641   "Make text outside current defun invisible.
 642 The defun visible is the one that contains point or follows point.
 643 Use semantic tags to navigate."
 644   (interactive)
 645   (semantic-fetch-tags)
 646   (save-excursion
 647     (widen)
 648     (senator-end-of-defun)
 649     (let ((end (point)))
 650       (senator-beginning-of-defun)
 651       (narrow-to-region (point) end))))
 652
 653 (defun senator-mark-defun ()
 654   "Put mark at end of this defun, point at beginning.
 655 The defun marked is the one that contains point or follows point.
 656 Use semantic tags to navigate."
 657   (interactive)
 658   (let ((origin (point))
 659         (end    (progn (senator-end-of-defun) (point)))
 660         (start  (progn (senator-beginning-of-defun) (point))))
 661     (goto-char origin)
 662     (push-mark (point))
 663     (goto-char end) ;; end-of-defun
 664     (push-mark (point) nil t)
 665     (goto-char start) ;; beginning-of-defun
 666     (re-search-backward "^\n" (- (point) 1) t)))
 667
 668 ;;; Tag Cut & Paste
 669
 670 ;; To copy a tag, means to put a tag definition into the tag
 671 ;; ring.  To kill a tag, put the tag into the tag ring AND put
 672 ;; the body of the tag into the kill-ring.
 673 ;;
 674 ;; To retrieve a killed tag's text, use C-y (yank), but to retrieve
 675 ;; the tag as a reference of some sort, use senator-yank-tag.
 676
 677 (defvar senator-tag-ring (make-ring 20)
 678   "Ring of tags for use with cut and paste.")
 679
 680 ;;;###autoload
 681 (defun senator-copy-tag ()
 682   "Take the current tag, and place it in the tag ring."
 683   (interactive)
 684   (semantic-fetch-tags)
 685   (let ((ft (semantic-obtain-foreign-tag)))
 686     (when ft
 687       (ring-insert senator-tag-ring ft)
 688       (kill-ring-save (semantic-tag-start ft) (semantic-tag-end ft))
 689       (when (called-interactively-p 'interactive)
 690         (message "Use C-y to yank text.  \
 691 Use `senator-yank-tag' for prototype insert.")))
 692     ft))
 693
 694 ;;;###autoload
 695 (defun senator-kill-tag ()
 696   "Take the current tag, place it in the tag ring, and kill it.
 697 Killing the tag removes the text for that tag, and places it into
 698 the kill ring.  Retrieve that text with \\[yank]."
 699   (interactive)
 700   (let ((ct (senator-copy-tag))) ;; this handles the reparse for us.
 701     (kill-region (semantic-tag-start ct)
 702                  (semantic-tag-end ct))
 703     (when (called-interactively-p 'interactive)
 704       (message "Use C-y to yank text.  \
 705 Use `senator-yank-tag' for prototype insert."))))
 706
 707 ;;;###autoload
 708 (defun senator-yank-tag ()
 709   "Yank a tag from the tag ring.
 710 The form the tag takes is different depending on where it is being
 711 yanked to."
 712   (interactive)
 713   (or (ring-empty-p senator-tag-ring)
 714       (let ((ft (ring-ref senator-tag-ring 0)))
 715           (semantic-foreign-tag-check ft)
 716           (semantic-insert-foreign-tag ft)
 717           (when (called-interactively-p 'interactive)
 718             (message "Use C-y to recover the yank the text of %s."
 719                      (semantic-tag-name ft))))))
 720
 721 ;;;###autoload
 722 (defun senator-copy-tag-to-register (register &optional kill-flag)
 723   "Copy the current tag into REGISTER.
 724 Optional argument KILL-FLAG will delete the text of the tag to the
 725 kill ring.
 726
 727 Interactively, reads the register using `register-read-with-preview',
 728 if available."
 729   (interactive (list (if (fboundp 'register-read-with-preview)
 730                          (register-read-with-preview "Tag to register: ")
 731                        (read-char "Tag to register: "))
 732                      current-prefix-arg))
 733   (semantic-fetch-tags)
 734   (let ((ft (semantic-obtain-foreign-tag)))
 735     (when ft
 736       (set-register
 737        register (registerv-make
 738                  ft
 739                  :insert-func #'semantic-insert-foreign-tag
 740                  :jump-func (lambda (v)
 741                               (switch-to-buffer (semantic-tag-buffer v))
 742                               (goto-char (semantic-tag-start v)))))
 743       (if kill-flag
 744           (kill-region (semantic-tag-start ft)
 745                        (semantic-tag-end ft))))))
 746
 747 ;;;###autoload
 748 (defun senator-transpose-tags-up ()
 749   "Transpose the current tag, and the preceding tag."
 750   (interactive)
 751   (semantic-fetch-tags)
 752   (let* ((current-tag (semantic-current-tag))
 753          (prev-tag (save-excursion
 754                      (goto-char (semantic-tag-start current-tag))
 755                      (semantic-find-tag-by-overlay-prev)))
 756          (ct-parent (semantic-find-tag-parent-by-overlay current-tag))
 757          (pt-parent (semantic-find-tag-parent-by-overlay prev-tag)))
 758     (if (not (eq ct-parent pt-parent))
 759         (error "Cannot transpose tags"))
 760     (let ((txt (buffer-substring (semantic-tag-start current-tag)
 761                                  (semantic-tag-end current-tag)))
 762           (line (count-lines (semantic-tag-start current-tag)
 763                              (point)))
 764           (insert-point nil)
 765           )
 766       (delete-region (semantic-tag-start current-tag)
 767                      (semantic-tag-end current-tag))
 768       (delete-blank-lines)
 769       (goto-char (semantic-tag-start prev-tag))
 770       (setq insert-point (point))
 771       (insert txt)
 772       (if (/= (current-column) 0)
 773           (insert "\n"))
 774       (insert "\n")
 775       (goto-char insert-point)
 776       (forward-line line)
 777       )))
 778
 779 ;;;###autoload
 780 (defun senator-transpose-tags-down ()
 781   "Transpose the current tag, and the following tag."
 782   (interactive)
 783   (semantic-fetch-tags)
 784   (let* ((current-tag (semantic-current-tag))
 785          (next-tag (save-excursion
 786                      (goto-char (semantic-tag-end current-tag))
 787                      (semantic-find-tag-by-overlay-next)))
 788          (end-pt (point-marker))
 789          )
 790     (goto-char (semantic-tag-start next-tag))
 791     (forward-char 1)
 792     (senator-transpose-tags-up)
 793     ;; I know that the above fcn deletes the next tag, so our pt marker
 794     ;; will be stable.
 795     (goto-char end-pt)))
 796
 797 ;;; Using semantic search in isearch mode
 798
 799 (defun senator-lazy-highlight-update ()
 800   "Force lazy highlight update."
 801   (lazy-highlight-cleanup t)
 802   (set 'isearch-lazy-highlight-last-string nil)
 803   (setq isearch-adjusted t)
 804   (isearch-update))
 805
 806 ;; Recent versions of GNU Emacs allow overriding the isearch search
 807 ;; function for special needs, and avoid to advice the built-in search
 808 ;; function :-)
 809 (defun senator-isearch-search-fun ()
 810   "Return the function to use for the search.
 811 Use a senator search function when semantic isearch mode is enabled."
 812   (intern
 813    (concat (if senator-isearch-semantic-mode
 814                "senator-"
 815              "")
 816            (cond (isearch-regexp-function "word-")
 817                  (isearch-regexp "re-")
 818                  (t ""))
 819            "search-"
 820            (if isearch-forward
 821                "forward"
 822              "backward"))))
 823
 824 (defun senator-isearch-toggle-semantic-mode ()
 825   "Toggle semantic searching on or off in isearch mode."
 826   (interactive)
 827   (setq senator-isearch-semantic-mode
 828         (not senator-isearch-semantic-mode))
 829   (if isearch-mode
 830       ;; force lazy highlight update
 831       (senator-lazy-highlight-update)
 832     (message "Isearch semantic mode %s"
 833              (if senator-isearch-semantic-mode
 834                  "enabled"
 835                "disabled"))))
 836
 837 (defvar senator-old-isearch-search-fun nil
 838   "Hold previous value of `isearch-search-fun-function'.")
 839
 840 (defun senator-isearch-mode-hook ()
 841   "Isearch mode hook to setup semantic searching."
 842   (if (and isearch-mode senator-isearch-semantic-mode)
 843       (progn
 844         ;; When `senator-isearch-semantic-mode' is on save the
 845         ;; previous `isearch-search-fun-function' and install the
 846         ;; senator one.
 847         (when (and (local-variable-p 'isearch-search-fun-function)
 848                    (not (local-variable-p 'senator-old-isearch-search-fun)))
 849           (set (make-local-variable 'senator-old-isearch-search-fun)
 850                isearch-search-fun-function))
 851         (set (make-local-variable 'isearch-search-fun-function)
 852              'senator-isearch-search-fun))
 853     ;; When `senator-isearch-semantic-mode' is off restore the
 854     ;; previous `isearch-search-fun-function'.
 855     (when (eq isearch-search-fun-function 'senator-isearch-search-fun)
 856       (if (local-variable-p 'senator-old-isearch-search-fun)
 857           (progn
 858             (set (make-local-variable 'isearch-search-fun-function)
 859                  senator-old-isearch-search-fun)
 860             (kill-local-variable 'senator-old-isearch-search-fun))
 861         (kill-local-variable 'isearch-search-fun-function)))))
 862
 863 ;; (add-hook 'isearch-mode-hook     'senator-isearch-mode-hook)
 864 ;; (add-hook 'isearch-mode-end-hook 'senator-isearch-mode-hook)
 865
 866 ;; ;; Keyboard shortcut to toggle semantic search in isearch mode.
 867 ;; (define-key isearch-mode-map
 868 ;;   [(control ?,)]
 869 ;;   'senator-isearch-toggle-semantic-mode)
 870
 871 (provide 'semantic/senator)
 872
 873 ;; Local variables:
 874 ;; generated-autoload-file: "loaddefs.el"
 875 ;; generated-autoload-load-name: "semantic/senator"
 876 ;; End:
 877
 878 ;;; semantic/senator.el ends here