home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 5 Edit / 05-Edit.zip / browser2.zip / br-tree.el < prev    next >
Lisp/Scheme  |  1995-02-17  |  36KB  |  1,099 lines
  1. ;;; CLASS BROWSER FOR C++
  2. ;;; $Id: br-tree.el,v 3.1 1995/02/17 18:19:36 mmann Exp $
  3. ;;;
  4. ;;; **********************************************************************
  5. ;;; Copyright (C) 1993, 1994 Gerd Moellmann. All rights reserved.
  6. ;;; Altenbergstr. 6, D-40235 Duesseldorf, Germany
  7. ;;; 100025.3303@COMPUSERVE.COM
  8. ;;; Suggestions, comments and requests for improvements are welcome.
  9. ;;; **********************************************************************
  10. ;;;
  11. ;;; This version works with both Emacs version 18 and 19, and I want
  12. ;;; to keep it that way. It requires the CL-19 Common Lisp compatibility
  13. ;;; package for Emacs 18 and 19.
  14. ;;;
  15. ;;; This file contains the functins for TREE-MODE.
  16. ;;; 
  17.  
  18. ;; This code is distributed in the hope that it will be useful,
  19. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  20. ;; accepts responsibility to anyone for the consequences of using it
  21. ;; or for whether it serves any particular purpose or works at all,
  22. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  23. ;; License for full details.
  24.  
  25. ;; Everyone is granted permission to copy, modify and redistribute
  26. ;; this code, but only under the conditions described in the
  27. ;; GNU Emacs General Public License.   A copy of this license is
  28. ;; supposed to have been given to you along with GNU Emacs so you
  29. ;; can know your rights and responsibilities.  It should be in a
  30. ;; file named COPYING.  Among other things, the copyright notice
  31. ;; and this notice must be preserved on all copies.
  32.  
  33. (require 'cl-19 "cl")
  34. (require 'backquote)
  35. (require 'br-struc)
  36. (require 'br-macro)
  37.  
  38. ;;;
  39. ;;; Temporary used to communicate with browse-view/find.
  40. ;;; Contains (TREE-HEADER TREE-OR-MEMBER MEMBER-LIST)
  41. ;;; 
  42.  
  43. (defvar browse-position-to-view nil)
  44. (defvar browse-info-to-view nil)
  45.  
  46. (defvar tree-mode-hook nil
  47.   "Run in each new tree buffer.")
  48.  
  49. (defvar tree-mark-face 'red
  50.   "The face used for the mark character in the tree.")
  51.  
  52. (defvar tree-root-class-face 'purple
  53.   "The face used for root classes in the tree.")
  54.  
  55. (defvar tree-multiply-derived-face 'red
  56.   "The face for classes that have more than one base class.")
  57.  
  58. (defvar tree-filename-face 'ForestGreen
  59.   "The color for filenames displayed in the tree.")
  60.  
  61. (defvar tree-normal-face 'default
  62.   "Face for everything else in the tree.")
  63.  
  64. (defconst tree-buffer-name "*Tree*"
  65.   "The name of the buffer containing the class tree.")
  66.  
  67. (defvar @indentation 2
  68.   "The amount by which subclasses will be indented relative
  69. to their superclasses in the class tree.")
  70.  
  71. (defvar tree-source-file-column 40
  72.   "The column in which source file names are displayed in the tree 
  73. buffer.")
  74.  
  75. (defvar tree-mode-map ()
  76.   "The keymap used in tree mode buffers.")
  77.  
  78. (defvar tree-left-margin 2
  79.   "*Amount of space left at the left side of the tree display. This space
  80. is used to display markers.")
  81.  
  82. (defun tree-make-face (face)
  83.   (when (and window-system (browse-emacs-19-p))
  84.     (unless (memq face (face-list))
  85.       (set-face-foreground (make-face face) (symbol-name face)))))
  86.  
  87. (tree-make-face tree-root-class-face)
  88. (tree-make-face tree-mark-face)
  89. (tree-make-face tree-multiply-derived-face)
  90. (tree-make-face tree-filename-face)
  91.  
  92. ;;;
  93. ;;; Return T if any class in the tree contained in the current buffer
  94. ;;; is marked.
  95. ;;; 
  96.  
  97. (defun* tree-marked-exist-p ()
  98.   (dotrees (tree @tree-obarray)
  99.     (when (tree-mark tree)
  100.       (return-from tree-marked-exist-p tree))))
  101.  
  102. ;;;
  103. ;;; Create a new tree buffer for tree TREE which was loaded from file
  104. ;;; TAGS-FILE.  HEADER is the header structure of the file.  OBARRAY is
  105. ;;; an obarray with a symbol for each class in the tree. 
  106. ;;; FIND-FILE-BUFFER if non-nil is the buffer from which the Lisp data
  107. ;;; was read.  Return the buffer created.
  108. ;;; 
  109.  
  110. (defun* tree-create-buffer (tree tags-file header obarray pop
  111.                                 &optional find-file-buffer
  112.                 &aux name)
  113.   (cond (find-file-buffer
  114.      (set-buffer find-file-buffer)
  115.      (erase-buffer)
  116.      (setq name (tree-frozen-buffer-name tags-file))
  117.      (browse-rename-buffer-safe name))
  118.     (t
  119.      (setq name tree-buffer-name)
  120.      (set-buffer (get-buffer-create name))))
  121.  
  122.   ;; Switch to tree mode and initialize buffer local variables.
  123.   (tree-mode)
  124.   (setf @tree tree
  125.     @tags-filename tags-file
  126.     @tree-obarray obarray
  127.     @header header
  128.     @frozen (not (null find-file-buffer)))
  129.  
  130.   ;; Create obarray of all members for fast member lookup.
  131.   (when (and browse-fast-member-lookup
  132.          (not browse-lazy-fast-members))
  133.     (tree-fill-member-obarray))
  134.  
  135.   ;; Switch or pop to the tree buffer; display the tree and return the
  136.   ;; buffer.
  137.   
  138.   (case pop 
  139.     (switch (switch-to-buffer name))
  140.     (pop (pop-to-buffer name)))
  141.   (tree-redisplay)
  142.   (set-buffer-modified-p nil)
  143.   (current-buffer))
  144.  
  145. ;;;
  146. ;;; Initialize keymap.
  147. ;;; 
  148.  
  149. (unless tree-mode-map
  150.   (setf tree-mode-map (make-keymap))
  151.   (suppress-keymap tree-mode-map)
  152.  
  153.   (when (and (browse-emacs-19-p) window-system)
  154.     (define-key tree-mode-map [mouse-2] 'tree-mouse-2)
  155.     (define-key tree-mode-map [down-mouse-1] 'tree-mouse-1))
  156.   
  157.   (define-key tree-mode-map "a" 'tree-show-vars)
  158.   (define-key tree-mode-map "c" 'tree-window-configuration)
  159.   (define-key tree-mode-map "f" 'tree-find-source)
  160.   (define-key tree-mode-map "g" 'tree-position-on-class)
  161.   (define-key tree-mode-map "l" 'tree-redisplay)
  162.   (define-key tree-mode-map "m" 'tree-toggle-mark)
  163.   (define-key tree-mode-map "p" 'tree-show-fns)
  164.   (define-key tree-mode-map "q" 'bury-buffer)
  165.   (define-key tree-mode-map "r" 'tree-show-revision)
  166.   (define-key tree-mode-map "S" 'tree-toggle-filenames)
  167.   (define-key tree-mode-map "s" 'tree-show-single-filename)
  168.   (define-key tree-mode-map "t" 'tree-show-types)
  169.   (define-key tree-mode-map "u" 'tree-unmark)
  170.   (define-key tree-mode-map "v" 'tree-view-source)
  171.   (define-key tree-mode-map "w" 'tree-set-indentation)
  172.   (define-key tree-mode-map "x" 'tree-statistics)
  173.   (define-key tree-mode-map "A" 'tree-show-svars)
  174.   (define-key tree-mode-map "P" 'tree-show-sfns)
  175.   (define-key tree-mode-map "F" 'tree-show-friends)
  176.   (define-key tree-mode-map "\C-d" 'tree-kill-class)
  177.   (define-key tree-mode-map "\C-i" 'tree-pop-to-members)
  178.   (define-key tree-mode-map "\C-m" 'tree-find-source)
  179.   (define-key tree-mode-map "*" 'tree-expand-all)
  180.   (define-key tree-mode-map "+" 'tree-expand-branch)
  181.   (define-key tree-mode-map "-" 'tree-collapse-branch)
  182.   (define-key tree-mode-map "/" 'tree-position-on-class)
  183.   (define-key tree-mode-map " " 'tree-view-source)
  184.   (define-key tree-mode-map "." 'browse-repeat-search)
  185.   (define-key tree-mode-map "?" 'describe-mode))
  186.  
  187. ;;;###autoload
  188. (defun tree-mode ()
  189.   "Major mode for tree buffers. Each line corresponds to a class in a
  190. class tree. Letters do not insert themselves, they are commands,
  191. instead. File operations in the tree buffer work on trees. E.g.,
  192. \\[save-buffer] writes the tree to the file it was loaded from.
  193. \\<tree-mode-map>
  194. \\[tree-show-vars] -- show instance member variables.
  195. \\[tree-show-svars] -- show static member variables.
  196. \\[tree-window-configuration] -- restore window configuration (Emacs 18).
  197. \\[tree-find-source] -- find the file containing the class declaration.
  198. \\[tree-show-friends] -- display the list of friend functions of the class.
  199. \\[tree-position-on-class] -- position point on a class read from minibuffer.
  200. \\[tree-redisplay] -- redisplay the class tree.
  201. \\[tree-toggle-mark] -- mark/ unmark the class(es) point is on.
  202. \\[tree-show-fns] -- display the list of member functions.
  203. \\[tree-show-sfns] -- display the list of static member functions.
  204. \\[bury-buffer] -- bury the tree buffer.
  205. \\[tree-show-revision] -- show current browser revision level.
  206. \\[tree-show-single-filename] -- display source file for current line.
  207. \\[tree-toggle-filenames] -- toggle file name display.
  208. \\[tree-show-types] -- display the list of nested types.
  209. \\[tree-unmark] -- unmark, with prefix arg mark, all classes in the tree.
  210. \\[tree-view-source] -- view the source file containing the class declaration.
  211. \\[tree-set-indentation] -- set the indentation with of the tree.
  212. \\[tree-statistics] -- display statistics for the tree.
  213. \\[tree-expand-all] -- expand all collapsed branches of the tree.
  214. \\[tree-expand-branch] -- expand a single branch in the tree.
  215. \\[tree-collapse-branch] -- collapse a branch in the tree.
  216. \\[browse-repeat-search] -- repeat the last search performed.
  217. \\[describe-mode] -- describe mode.
  218. \\[tree-kill-class] -- delete a class from the tree.
  219. \\<global-map>
  220. \\[save-buffer] -- write tree to file it was loaded from.
  221. \\[write-file] -- write tree to another file.
  222. \\[revert-buffer] -- revert tree from disk.
  223.  
  224. Tree mode key bindings:
  225. \\{tree-mode-map}
  226. \\<global-map>
  227. Related global key bindings:
  228. \\[browse-tags-apropos] -- view member matching regexp.
  229. \\[browse-tags-back] -- go back in position stack.
  230. \\[browse-tags-forward] -- go forward in position stack.
  231. \\[browse-tags-list] -- list members in file.
  232. \\[browse-tags-find-member-buffer] -- display member buffer containing member.
  233. \\[browse-electric-position-list] -- electric position stack menu.
  234. \\[browse-search] -- search for regexp in files mentioned in tree.
  235. \\[browse-search-member-usage] -- search for calls of member.
  236. \\[browse-tags-view] -- view member point is on.
  237. \\[browse-query-replace] -- perform query replace in files.
  238. \\[browse-tags-find] -- find member point is on.
  239. \\[browse-loop] -- repeat last search or query replace.
  240. \\[browse-add-region] -- add region to tree.
  241. \\[browse-add-buffer] -- add buffer to tree."
  242.   (kill-all-local-variables)
  243.   (mapcar
  244.    'make-local-variable '(@tags-filename
  245.               @indentation @tree @header @show-filenames @frozen
  246.               @tree-obarray @mode-strings))
  247.   (use-local-map tree-mode-map)
  248.   (setf @show-filenames nil
  249.         @tree-obarray (make-vector 127 0)
  250.         @frozen nil
  251.     major-mode 'tree-mode
  252.         mode-name "C++ Tree"
  253.         mode-line-format (list "" 'mode-line-modified 'mode-name ": "
  254.                                '@mode-strings "%-")
  255.         buffer-read-only t
  256.         selective-display t
  257.         selective-display-ellipses t)
  258.   (run-hooks 'tree-mode-hook))
  259.  
  260. ;;;
  261. ;;; Show revision information.
  262. ;;;
  263.  
  264. (defun tree-show-revision ()
  265.   (interactive)
  266.   (message "BROWSE v%s. %s" (browse-revision) (browse-copyright)))
  267.  
  268. ;;;
  269. ;;; Remove the class point is on from the class tree.
  270. ;;; 
  271.  
  272. (defun tree-kill-class (forced)
  273.   (interactive "P")
  274.   (let* ((class (tree-get-tree-at-point))
  275.          (class-name (class-name (tree-class class)))
  276.          (subclasses (tree-subclasses class)))
  277.     (cond ((or forced
  278.                (y-or-n-p (concat "Delete class " class-name "? ")))
  279.            (setf @tree (browse-remove-class @tree class))
  280.            (set-buffer-modified-p t)
  281.            (message "%s %sdeleted." class-name
  282.                     (if subclasses "and derived classes " ""))
  283.            (tree-redisplay))
  284.           (t
  285.            (message "Aborted.")))))
  286.  
  287. ;;;
  288. ;;; Toggle marks in the tree.
  289. ;;; 
  290.  
  291. (defun tree-toggle-mark (&optional n-times)
  292.   "Toggle mark for class cursor is on. If given a numeric argument, mark
  293. that much classes."
  294.   (interactive "p")
  295.   (let (to-change pnt)
  296.  
  297.     ;; Get the classes whose mark must be toggled. Note that
  298.     ;; TREE-GET-TREE-AT-POINT might issue an error.
  299.  
  300.     (condition-case error
  301.     (loop repeat (or n-times 1)
  302.           as tree = (tree-get-tree-at-point)
  303.           do (progn 
  304.            (setf (tree-mark tree) (not (tree-mark tree)))
  305.            (forward-line 1)
  306.            (push tree to-change)))
  307.       (error nil))
  308.  
  309.     ;; SAVE-EXCURSION gets confused here. Instead, remember point and
  310.     ;; go back there after the replacement.
  311.  
  312.     (setq pnt (point))
  313.  
  314.     ;; For all these classes, reverse the mark char in the display
  315.     ;; by a regexp replace over the whole buffer. The reason for this
  316.     ;; is that classes might have multiple base classes. If this is
  317.     ;; the case, they are displayed more than once in the tree.
  318.  
  319.     (browse-output
  320.       (loop for tree in to-change
  321.         as regexp = (concat "^[ >][ \t]*"
  322.                 (regexp-quote (class-name (tree-class tree)))
  323.                 "[ \t\n\r]")
  324.         finally (goto-char pnt) do
  325.         (goto-char (point-min))
  326.         (loop while (re-search-forward regexp nil t)
  327.           do (progn
  328.                (goto-char (match-beginning 0))
  329.                (delete-char 1)
  330.                (insert-char (if (tree-mark tree) ?> ? ) 1)
  331.                (browse-put-text-property (1- (point)) (point)
  332.                          'browser 'mark)
  333.                (browse-put-text-property (1- (point)) (point)
  334.                          'mouse-face 'highlight)
  335.                (browse-set-face (1- (point)) (point) tree-mark-face)
  336.                (goto-char (match-end 0))))))))
  337.  
  338. ;;;
  339. ;;; Mark or unmark the whole tree.
  340. ;;; 
  341.  
  342. (defun tree-unmark (prefix)
  343.   "Unmark, with prefix mark, all classes in the tree."
  344.   (interactive "P")
  345.   (dotrees (tree @tree-obarray)
  346.     (setf (tree-mark tree) prefix))
  347.   (tree-redisplay-marks (point-min) (point-max)))
  348.  
  349. ;;;
  350. ;;; Toggle display of filenames in the current line. This function
  351. ;;; was introduced because the filename display in Emacs 19 when
  352. ;;; highliting is used is quite slow.
  353. ;;; 
  354.  
  355. (defun tree-show-single-filename (prefix)
  356.   "Show filename in the line point is in. With prefix, insert that much
  357. filenames."
  358.   (interactive "p")
  359.   (unless @show-filenames
  360.     (browse-output
  361.       (dotimes (i prefix)
  362.         (let ((tree (tree-get-tree-at-point))
  363.               start
  364.               filename-existing)
  365.           (unless tree
  366.             return)
  367.           (beginning-of-line)
  368.           (skip-chars-forward " \t*a-zA-Z0-9_")
  369.           (setq start (point)
  370.                 filename-existing (looking-at "<"))
  371.  
  372.           (delete-region start (save-excursion (end-of-line) (point)))
  373.  
  374.           (unless filename-existing
  375.             (browse-move-to-column tree-source-file-column)
  376.             (insert "<" (or (class-file (tree-class tree))
  377.                             "unknown")
  378.             ">"))
  379.                  
  380.           (browse-set-face start (point) tree-filename-face)
  381.           (beginning-of-line)
  382.           (forward-line 1))))))
  383.  
  384. ;;;
  385. ;;; Toggle display of filenames for the whole tree.
  386. ;;; 
  387.   
  388. (defun tree-toggle-filenames ()
  389.   "Toggle display of filenames in tree buffer."
  390.   (interactive)
  391.   (setf @show-filenames (not @show-filenames))
  392.   (let ((old-line (count-lines (point-min) (point))))
  393.     (tree-redisplay)
  394.     (goto-line old-line)))
  395.  
  396. ;;;
  397. ;;; Some predicates on buffers.
  398. ;;; 
  399.  
  400. (defun member-buffer-p (buffer)
  401.   (eq (cdr (assoc 'major-mode (buffer-local-variables buffer))) 'member-mode))
  402.  
  403. (defun tree-buffer-p (buffer)
  404.   (eq (cdr (assoc 'major-mode (buffer-local-variables buffer))) 'tree-mode))
  405.  
  406. (defun browse-buffer-p (buffer)
  407.   (memq (cdr (assoc 'major-mode (buffer-local-variables buffer)))
  408.     '(tree-mode member-mode)))
  409.  
  410. ;;;
  411. ;;; Return various lists of buffers.
  412. ;;; 
  413.  
  414. (defun browse-buffers ()
  415.   (delete-if-not 'browse-buffer-p (buffer-list)))
  416.  
  417. (defun member-buffers ()
  418.   (delete-if-not 'member-buffer-p (buffer-list)))
  419.  
  420. (defun tree-buffers ()
  421.   (delete-if-not 'tree-buffer-p (buffer-list)))
  422.  
  423. ;;;
  424. ;;; Return the tree of a buffer
  425. ;;;
  426.  
  427. (defun tree-buffer-tree (buffer)
  428.   (browse-@value '@tree buffer))
  429.  
  430. ;;;
  431. ;;; Return a list of buffers with different trees.
  432. ;;; 
  433.  
  434. (defun* browse-different-tree-buffers ()
  435.   (delete-duplicates (nconc (tree-buffers) (member-buffers))
  436.              :key 'tree-buffer-tree))
  437.  
  438. ;;;                          
  439. ;;; Return a list of members buffers displaying the same tree as
  440. ;;; the current buffer.
  441. ;;; 
  442.  
  443. (defun browse-same-tree-member-buffers ()
  444.   (delete-if-not (function (lambda (b) (eq (tree-buffer-tree b) @tree)))
  445.          (member-buffers)))
  446.  
  447. ;;;
  448. ;;; Pop to a member buffer.
  449. ;;;
  450.  
  451. (defun tree-pop-to-members (arg)
  452.   "Pop to the buffer displaying members (switch to buffer if
  453. prefix arg).  If no member buffer exists, make one."
  454.   (interactive "P")
  455.   (let ((buf (or (first (browse-same-tree-member-buffers))
  456.                  (get-buffer member-buffer-name)
  457.                  (tree-show-fns))))
  458.     (when buf
  459.       (if arg
  460.           (switch-to-buffer buf)
  461.         (pop-to-buffer buf)))
  462.     buf))
  463.  
  464. ;;;
  465. ;;; Saving/ restoring the window configuration. This is for Emacs 18,
  466. ;;; only. It doesn't make much sense for Emacs 19.
  467. ;;; 
  468.  
  469. (defun tree-window-configuration (arg)
  470.   "Save the current window configuration when called with
  471. prefix.  Restore window configuration without prefix."
  472.   (interactive "P")
  473.   (cond (arg
  474.          (setf browse-window-configuration (current-window-configuration)))
  475.         (browse-window-configuration
  476.          (set-window-configuration browse-window-configuration))
  477.         (t
  478.          (error "No window configuration remembered!"))))
  479.  
  480. ;;;
  481. ;;; Setting the indentation width of the class tree
  482. ;;; 
  483.  
  484. (defun tree-set-indentation ()
  485.   "Set the indentation width of the tree display."
  486.   (interactive)
  487.   (let ((width (string-to-int (read-from-minibuffer
  488.                                (concat "Indentation ("
  489.                                        (int-to-string @indentation)
  490.                                        "): ")))))
  491.     (when (plusp width)
  492.       (setf @indentation width)
  493.       (tree-redisplay))))
  494.  
  495.  
  496. ;;;
  497. ;;; Display various kinds of member buffers.
  498. ;;;
  499.  
  500. (defun tree-show-vars (arg)
  501.   "Display member variables; with prefix arg in frozen member buffer."
  502.   (interactive "P")
  503.   (member-display 'tree-member-variables arg))
  504.  
  505. (defun tree-show-fns (&optional arg)
  506.   "Display member functions; with prefix arg in frozen member buffer."
  507.   (interactive "P")
  508.   (member-display 'tree-member-functions arg))
  509.  
  510. (defun tree-show-svars (arg)
  511.   "Display static member variables; with prefix arg in frozen member buffer."
  512.   (interactive "P")
  513.   (member-display 'tree-static-variables arg))
  514.  
  515. (defun tree-show-sfns (arg)
  516.   "Display static member functions; with prefix arg in frozen member buffer."
  517.   (interactive "P")
  518.   (member-display 'tree-static-functions arg))
  519.  
  520. (defun tree-show-friends (arg)
  521.   "Display friend functions; with prefix arg in frozen member buffer."
  522.   (interactive "P")
  523.   (member-display 'tree-friends arg))
  524.  
  525. (defun tree-show-types (arg)
  526.   "Display types defined in a class; with prefix arg in frozen member buffer."
  527.   (interactive "P")
  528.   (member-display 'tree-types arg))
  529.  
  530. ;;;
  531. ;;; Finding or viewing a class.
  532. ;;; 
  533.  
  534. (defun tree-find-source ()
  535.   "Find the file containing the class' declaration and position
  536. cursor on it."
  537.   (interactive)
  538.   (tree-goto-class nil))
  539.  
  540. ;;;
  541. ;;; View the file contaiing the class' declaration.
  542. ;;;
  543.  
  544. (defun tree-view-source ()
  545.   "View the file containing the class' declaration and position
  546. cursor on it."
  547.   (interactive)
  548.   (tree-goto-class t))
  549.  
  550. ;;;
  551. ;;; View or find the declaration of the class point is on.
  552. ;;; 
  553.  
  554. (defun tree-goto-class (view)
  555.   (let* ((class (tree-class (tree-get-tree-at-point)))
  556.          (file (class-file class))
  557.          (browse (make-browse
  558.                   :name (class-name class)
  559.                   :pattern (class-pattern class)
  560.                   :file (class-file class)
  561.                   :point (class-point class))))
  562.     (browse-find-pattern browse 
  563.              (list @header class nil)
  564.              file @tags-filename view)))
  565.  
  566. ;;;
  567. ;;; Return the CLASS structure for the class the cursor is on.
  568. ;;; This function reads the name of the class from the current
  569. ;;; buffer, and searches the class tree for a class with the
  570. ;;; name found.
  571. ;;; 
  572.  
  573. (defun tree-get-tree-at-point ()
  574.   (let (begin name tree)
  575.     (save-excursion
  576.       (save-restriction
  577.  
  578.         ;; Find the name in the buffer
  579.         (widen)
  580.         (move-to-column tree-left-margin)
  581.         (skip-chars-forward " \t")
  582.         (setf begin (point))
  583.         (skip-chars-forward "^ \t\n\r")
  584.  
  585.         ;; Get the class description
  586.         (setf name (buffer-substring begin (point))
  587.               tree (get (intern-soft name @tree-obarray) 'browse-root))
  588.  
  589.         (unless tree
  590.           (error "No information about %s found." name))
  591.  
  592.     tree))))
  593.  
  594. ;;;
  595. ;;; Find DESCRIPTION STRUC in file FILE.  If VIEW is non-NIL,
  596. ;;; view file else find the file. FILE is not taken out of
  597. ;;; STRUC here because the filename in STRUC may be NIL in which
  598. ;;; case the filename of the class description is used.
  599. ;;;
  600. ;;; INFO is a list (HEADER CLASS-OR-MEMBER MEMBER-LIST).
  601. ;;; 
  602.  
  603. (defun browse-find-pattern (struc info file tags-filename
  604.                                   &optional view)
  605.   (unless file
  606.     (error "Sorry, no file information available for %s." (browse-name struc)))
  607.  
  608.   ;; Expand the file name and check if it is valid. All file
  609.   ;; names are relative to the path of the tags file name.
  610.  
  611.   (setf file (expand-file-name file (file-name-directory tags-filename)))
  612.   (unless (file-readable-p file) (error "File %s isn't readable." file))
  613.  
  614.   ;; When viewing, set view-mode-hook, else simply find the file.
  615.  
  616.   (if view
  617.       (progn (setf browse-position-to-view struc
  618.            browse-info-to-view info)
  619.          (unless (boundp 'view-hook) (setq view-hook nil))
  620.          (push 'browse-view/find view-hook)
  621.          (view-file file))
  622.     (find-file file)
  623.     (browse-view/find struc info)))
  624.  
  625. ;;;
  626. ;;; Generate a suitable regular expression for a member or class
  627. ;;; name.  
  628.  
  629. (defun browse-quote-name (name)
  630.   (loop with regexp = (regexp-quote name)
  631.     with start = 0
  632.     finally return regexp
  633.     while (string-match "[ \t]+" regexp start)
  634.     do (setf (substring regexp (match-beginning 0) (match-end 0))
  635.          "[ \t]*"
  636.          start (+ (match-beginning 0) 5))))
  637.             
  638. ;;;
  639. ;;; Construct a regexp for a class declaration.
  640. ;;; 
  641.     
  642. (defmacro browse-construct-class-regexp (name)
  643.   (` (concat "^[ \t]*\\(template[ \t\n]*<.*>\\)?"
  644.          "[ \t\n]*\\(class\\|struct\\|union\\).*\\S_"
  645.          (browse-quote-name (, name))
  646.          "\\S_")))
  647.   
  648. ;;;
  649. ;;; Construct a regexp for matching a variable.
  650. ;;; 
  651.  
  652. (defmacro browse-construct-variable-regexp (name)
  653.   (` (concat "\\S_" (browse-quote-name (, name)) "\\S_")))
  654.  
  655. ;;;
  656. ;;; Construct a regexp for matching a function definition or declaration.
  657. ;;; 
  658.  
  659. (defun browse-construct-function-regexp (name)
  660.   (concat "^[a-zA-Z0-9_:*&<>, \t]*\\S_"
  661.           (browse-quote-name name)
  662.           "[ \t\n]*("))
  663.  
  664. ;;;
  665. ;;; Load a regexp from a separate regexp file.
  666. ;;; 
  667.  
  668. (defun browse-pattern-from-regexp-file (file point)
  669.   (save-excursion
  670.     (set-buffer (find-file-noselect file))
  671.     (goto-char point)
  672.     (let ((s (read (current-buffer))))
  673.       (if s (concat "^.*" (regexp-quote s))))))
  674.   
  675. ;;;
  676. ;;; Find a DESCRIPTION. This is a little hack: Class mode allows
  677. ;;; you to find or view a file containing a description.  To be
  678. ;;; able to do a search in a viewed buffer, view-mode-hook is
  679. ;;; temporarily set to this function (STRUC is NIL then,
  680. ;;; BROWSE-POSITION-TO-VIEW holds the DESCRIPTION to search for).
  681. ;;;
  682. ;;; INFO is a list (TREE-HEADER TREE-OR-MEMBER MEMBER-LIST).
  683. ;;; 
  684.  
  685. (defun* browse-view/find (&optional position info
  686.                     &aux viewing)
  687.   (unless position
  688.     (pop view-hook)
  689.     (setf viewing t
  690.       position browse-position-to-view
  691.           info browse-info-to-view))
  692.  
  693.   (widen)
  694.   (let* ((pattern (browse-pattern position))
  695.          (start (browse-point position))
  696.          (offset 100)
  697.          found)
  698.  
  699.     (destructuring-bind (header class-or-member member-list) info
  700.  
  701.       ;; If no pattern is specified, do your best to contruct
  702.       ;; one from the member name.  If the pattern is a number,
  703.       ;; it is the position of the pattern in the pattern file.
  704.  
  705.       (setq pattern
  706.         (typecase pattern
  707.           (string (concat "^.*" (regexp-quote pattern)))
  708.           (number (browse-pattern-from-regexp-file
  709.                (tree-header-regexp-file header) pattern))))
  710.  
  711.       (unless pattern
  712.     (typecase class-or-member
  713.       (member
  714.        (case member-list
  715.          ((tree-member-variables tree-static-variables tree-types)
  716.           (setf pattern (browse-construct-variable-regexp
  717.                  (browse-name position))))
  718.          (otherwise
  719.           (setf pattern (browse-construct-function-regexp
  720.                  (browse-name position))))))
  721.       (class
  722.        (setf pattern (browse-construct-class-regexp
  723.               (browse-name position))))))
  724.  
  725.       ;; Begin searching some OFFSET from the original point where the
  726.       ;; regular expression was found by the parse, and step forward.
  727.       ;; When there is no regular expression in the database and a member
  728.       ;; definition/declaration was not seen by the parser, START will
  729.       ;; be 0.
  730.  
  731.       (when (and (boundp 'browse-debug) browse-debug)
  732.     (y-or-n-p (format "start = %d" start))
  733.     (y-or-n-p pattern))
  734.  
  735.       (setf found
  736.         (loop do (goto-char (max (point-min) (- start offset)))
  737.           when (re-search-forward pattern (+ start offset) t) return t
  738.           never (bobp)
  739.           do (incf offset offset)))
  740.  
  741.       (cond (found
  742.          (beginning-of-line)
  743.          (run-hooks 'browse-find-hook))
  744.         
  745.         ((numberp (browse-pattern position))
  746.          (goto-char start)
  747.          (if browse-not-found-hook
  748.          (run-hooks 'browse-not-found-hook)
  749.            (message "Not found.")
  750.            (sit-for 2)))
  751.  
  752.         (t
  753.          (if browse-not-found-hook
  754.          (run-hooks 'browse-not-found-hook)
  755.            (unless viewing
  756.          (error "Not found."))
  757.            (message "Not found.")
  758.            (sit-for 2)))))))
  759.   
  760.  
  761. ;;;
  762. ;;; Display marks in the tree.
  763. ;;; 
  764.  
  765. (defun tree-redisplay-marks (start end)
  766.   (interactive)
  767.   (save-excursion
  768.     (browse-output
  769.       (catch 'end
  770.         (goto-char (point-min))
  771.         (dolist (root @tree)
  772.           (tree-display-tree-marks root start end))))
  773.     (tree-update-mode-line)))
  774.  
  775. (defun tree-display-tree-marks (tree start end)
  776.   (when (>= (point) start)
  777.     (delete-char 1)
  778.     (insert (if (tree-mark tree) ?> ? ))
  779.     (let ((start (1- (point)))
  780.       (end (point)))
  781.       (browse-put-text-property start end 'browser 'mark)
  782.       (browse-put-text-property start end 'mouse-face 'highlight)
  783.       (browse-set-face start end tree-mark-face)))
  784.   (forward-line 1)
  785.   (when (> (point) end) (throw 'end nil))
  786.   (dolist (sub (tree-subclasses tree))
  787.     (tree-display-tree-marks sub start end)))
  788.  
  789. ;;;
  790. ;;; Redisplay the complete tree.
  791. ;;; 
  792.  
  793. (defun tree-redisplay (&optional quiet)
  794.   (interactive)
  795.   (or quiet (message "Displaying..."))
  796.   (save-excursion
  797.     (browse-output
  798.       (erase-buffer)
  799.       (tree-display-tree)))
  800.   (tree-update-mode-line)
  801.   (or quiet (message "")))
  802.  
  803. ;;;
  804. ;;; Display a single class and recursively it's subclasses.
  805. ;;; 
  806.  
  807. (defun* tree-display-tree (&aux stack1 stack2 start)
  808.   (setq stack1 (make-list (length @tree) 0)
  809.     stack2 (copy-list @tree))
  810.  
  811.   (loop while stack2
  812.     as level = (pop stack1)
  813.     as tree = (pop stack2)
  814.     as class = (tree-class tree) do
  815.  
  816.     (let ((start-of-line (point))
  817.           start-of-class-name end-of-class-name)
  818.  
  819.       ;; Insert mark
  820.       (insert (if (tree-mark tree) ">" " "))
  821.       (browse-set-face (1- (point)) (point) tree-mark-face)
  822.       
  823.       ;; Indent and insert class name
  824.       (browse-move-to-column (+ (* level @indentation)
  825.                     tree-left-margin))
  826.       (setq start (point))
  827.       (insert (class-name class))
  828.       
  829.       (browse-set-face start (point) (if (zerop level)
  830.                          tree-root-class-face
  831.                        tree-normal-face))
  832.       (setf start-of-class-name start
  833.         end-of-class-name (point))
  834.       
  835.       ;; If filenames are to be displayed...
  836.       (when @show-filenames
  837.         (browse-move-to-column tree-source-file-column)
  838.         (setq start (point))
  839.         (insert "<" (or (class-file class) "unknown") ">")
  840.         (browse-set-face start (point) tree-filename-face))
  841.       
  842.       (browse-put-text-property start-of-line (1+ start-of-line)
  843.                     'mouse-face 'highlight)
  844.       (browse-put-text-property start-of-line (1+ start-of-line)
  845.                     'browser 'mark)
  846.       (browse-put-text-property start-of-class-name end-of-class-name
  847.                     'mouse-face 'highlight)
  848.       (browse-put-text-property start-of-class-name end-of-class-name
  849.                     'browser 'class-name)
  850.       (insert "\n"))
  851.     
  852.     ;; Push subclasses, if any.
  853.     (when (tree-subclasses tree)
  854.       (setq stack2 (nconc (copy-list (tree-subclasses tree)) stack2)
  855.         stack1 (nconc (make-list (length (tree-subclasses tree))
  856.                      (1+ level))
  857.                   stack1)))))
  858.  
  859. ;;;
  860. ;;; Return the buffer name of a tree which is associated with a
  861. ;;; file.
  862. ;;; 
  863.  
  864. (defun tree-frozen-buffer-name (tags-file)
  865.   (concat tree-buffer-name " (" tags-file ")"))
  866.  
  867. ;;;
  868. ;;; Update the tree buffer mode line.
  869. ;;; 
  870.  
  871. (defun tree-update-mode-line ()
  872.   (setf @mode-strings
  873.     (concat (if @frozen (or buffer-file-name @tags-filename))
  874.         (if (buffer-modified-p) "-**")))
  875.   (browse-rename-buffer-safe (if @frozen
  876.                  (tree-frozen-buffer-name @tags-filename)
  877.                    tree-buffer-name))
  878.   (set-buffer-modified-p (buffer-modified-p)))
  879.  
  880.  
  881. ;;;
  882. ;;; Collapse/ expand tree branches.
  883. ;;; 
  884.  
  885. (defun tree-expand-branch (arg)
  886.   "Expand a sub-tree that has been previously collapsed.
  887. With prefix arg, expand all sub-trees in buffer."
  888.   (interactive "P")
  889.   (if arg
  890.       (tree-expand-all arg)
  891.     (tree-collapse nil)))
  892.  
  893. (defun tree-collapse-branch (arg)
  894.   "Fold (do no longer display) the subclasses of the class
  895. the cursor is on.  With prefix, fold all trees in the buffer."
  896.   (interactive "P")
  897.   (if arg
  898.       (tree-expand-all (not arg))
  899.     (tree-collapse t)))
  900.  
  901. (defun tree-expand-all (collapse)
  902.   "Expand or fold (with prefix arg) all trees in the buffer."
  903.   (interactive "P")
  904.   (let ((line-end  (if collapse "^\n" "^\r"))
  905.         (insertion (if collapse "\r"  "\n")))
  906.     (browse-output
  907.       (save-excursion
  908.     (goto-char (point-min))
  909.     (while (not (progn (skip-chars-forward line-end)
  910.                (eobp)))
  911.       (when (or (not collapse)
  912.             (looking-at "\n "))
  913.         (delete-char 1)
  914.         (insert insertion))
  915.       (when collapse
  916.         (skip-chars-forward "\n ")))))))
  917.  
  918. (defun tree-unhide-bases ()
  919.   "Unhide the line the cursor is on and all lines belonging to
  920. base classes."
  921.   (browse-output
  922.     (save-excursion
  923.       (let (indent last-indent)
  924.         (skip-chars-backward "^\r\n")
  925.         (when (not (looking-at "[\r\n][^ \t]"))
  926.           (skip-chars-forward "\r\n \t")
  927.           (while (and (or (null last-indent) ;first time
  928.                           (> indent 1))    ;not root class
  929.                       (re-search-backward "[\r\n][ \t]*" nil t))
  930.             (setf indent (- (match-end 0)
  931.                             (match-beginning 0)))
  932.             (when (or (null last-indent)
  933.                       (< indent last-indent))
  934.               (setf last-indent indent)
  935.               (when (looking-at "\r")
  936.                 (delete-char 1)
  937.                 (insert 10)))
  938.             (backward-char 1)))))))
  939.  
  940. (defun tree-hide-line (collapse)
  941.   "Hide a single line in the tree."
  942.   (save-excursion
  943.     (browse-output
  944.       (skip-chars-forward "^\r\n")
  945.       (delete-char 1)
  946.       (insert (if collapse 13 10)))))
  947.  
  948. (defun tree-collapse (collapse)
  949.   "Collapse or expand a branch of the tree."
  950.   (browse-output
  951.     (save-excursion
  952.       (beginning-of-line)
  953.       (skip-chars-forward "> \t")
  954.       (let ((indentation (current-column)))
  955.         (while (and (not (eobp))
  956.                     (save-excursion (skip-chars-forward "^\r\n")
  957.                                     (goto-char (1+ (point)))
  958.                                     (skip-chars-forward "> \t")
  959.                                     (> (current-column) indentation)))
  960.           (tree-hide-line collapse)
  961.           (skip-chars-forward "^\r\n")
  962.           (goto-char (1+ (point))))))))
  963.  
  964.  
  965. ;;;
  966. ;;; Read a class name from the minibuffer and position point on
  967. ;;; the class read.
  968. ;;; 
  969.  
  970. (defun tree-position-on-class (&optional class)
  971.   "Read a class name from the minibuffer with completion and
  972. position cursor on it."
  973.   (interactive)
  974.   (browse-completion-ignoring-case
  975.     (browse-save-selective
  976.       ;; If no class specified, read the class name from mini-buffer
  977.       (unless class
  978.     (setf class (completing-read "Goto class: " (tree-alist) nil t)))
  979.  
  980.       ;; Goto buffer start and remove restrictions
  981.       (goto-char (point-min))
  982.       (widen)
  983.       (setf selective-display nil)
  984.  
  985.       ;;search for the class name in buffer
  986.       (setq browse-last-regexp (concat "[\r\n]?[ \t]*" class "[ \t\r\n]"))
  987.  
  988.       (unless (re-search-forward browse-last-regexp nil t)
  989.     (error "Not found."))
  990.  
  991.       (tree-unhide-bases)
  992.       (backward-char)
  993.       (skip-chars-backward "^ \t\n")
  994.       (when (looking-at "\n")
  995.     (forward-char 1)))))
  996.  
  997.  
  998. ;;;
  999. ;;; Mouse support.
  1000. ;;; 
  1001. ;;; Depending on the location of the click event and the number of
  1002. ;;; clicks do the following: 
  1003.  
  1004. ;;; Location    Button    Clicks        Action
  1005. ;;; ----------------------------------------------------------
  1006. ;;; Left margin    1    1    Mark/unmark class
  1007. ;;; class name    1    2    collapse/expand subtree
  1008. ;;; class name    2    1    View class declaration
  1009. ;;; class name    2    2    Find class declaration
  1010.  
  1011. ;;; The text property 'browser-field gives one of the following
  1012. ;;; symbols that indicate where we are
  1013.  
  1014. ;;; 'mark
  1015. ;;; 'class-name
  1016. ;;; 'file-name
  1017.  
  1018. (defun tree-class-object-menu (event)
  1019.   (let* ((menu '("Class"
  1020.          ("Functions" . tree-show-fns)
  1021.          ("Variables" . tree-show-vars)
  1022.          ("Static functions" . tree-show-sfns)
  1023.          ("Static variables" . tree-show-svars)
  1024.          ("Friends" . tree-show-friends)
  1025.          ("Types" . tree-show-types)
  1026.          ("--")
  1027.          ("View" . tree-view-source)
  1028.          ("Find" . tree-find-source)
  1029.          ("--")
  1030.          ("Mark" . tree-toggle-mark)
  1031.          ("--")
  1032.          ("Collapse" . tree-collapse-branch)
  1033.          ("Expand" . tree-expand-branch)))
  1034.      (selection (x-popup-menu event (list "Class2" menu))))
  1035.     (when selection
  1036.       (call-interactively selection))))
  1037.  
  1038. (defun tree-buffer-object-menu (event)
  1039.   (let* ((menu '("Buffer"
  1040.          ("Filenames" . tree-toggle-filenames)
  1041.          ("Indentation" . tree-set-indentation)
  1042.          ("Unmark" . tree-unmark)
  1043.          ("Expand all" . tree-expand-all)
  1044.          ("Statistics" . tree-show-statistics)
  1045.          ("Find class" . tree-position-on-class)
  1046.          ("Member buffer" . tree-pop-to-members)))
  1047.      (selection (x-popup-menu event (list "Buffer" menu))))
  1048.     (unless (null selection)
  1049.       (call-interactively selection))))
  1050.  
  1051. (defun tree-mouse-2 (event)
  1052.   "Show member functions member buffer for class mouse is on."
  1053.   (interactive "e")
  1054.   (let* ((where (posn-point (event-start event)))
  1055.      (property (get-text-property where 'browser)))
  1056.     (mouse-set-point event)
  1057.     (case (event-click-count event)
  1058.       (1
  1059.        (case property
  1060.      (class-name (tree-class-object-menu event))
  1061.      (t (tree-buffer-object-menu event))))
  1062.       (2
  1063.        (case property
  1064.      (class-name (tree-show-fns)))))))
  1065.  
  1066. (defun tree-mouse-1 (event)
  1067.   "Expand/ collapse a tree branch."
  1068.   (interactive "e")
  1069.   (mouse-set-point event)
  1070.   (case (event-click-count event)
  1071.     (2
  1072.      (let ((collapsed (save-excursion
  1073.             (skip-chars-forward "^\r\n")
  1074.             (looking-at "\r"))))
  1075.        (tree-collapse (not collapsed))))))
  1076.  
  1077.  
  1078. ;;;
  1079. ;;; Install WRITE-FILE hook that saves a tree buffer as Lisp
  1080. ;;; data structures to the file it was loaded from.
  1081. ;;; 
  1082.  
  1083. (defun* browse-write-tree-hook ()
  1084.   "Write current buffer as a tree. Return T to indicate that no
  1085. further actions have to be taken by WRITE-FILE. This function has to
  1086. be the first in WRITE-FILE-HOOKS. If it is not, it will display a
  1087. message."
  1088.   (unless (eq (car write-file-hooks) 'browse-write-tree-hook)
  1089.     (message "Please see documentation of browse-write-tree-hook.")
  1090.     (sit-for 4))
  1091.   (when (tree-buffer-p (current-buffer))
  1092.     (tree-save)
  1093.     (return-from browse-write-tree-hook t)))
  1094.  
  1095. (add-hook 'write-file-hooks 'browse-write-tree-hook)
  1096. (provide 'br-tree)
  1097.  
  1098. ;; end of `tree.el'.
  1099.