OS/2 Shareware BBS: 5 Edit/05-Edit.zip/browser2.zip/br-membe.el

Lisp/Scheme | 1995-02-17 | 42KB | 1,296 lines

;;; CLASS BROWSER FOR C++
;;; $Id: br-membe.el,v 3.1 1995/02/17 18:19:36 mmann Exp $
;;;
;;; **********************************************************************
;;; Copyright (C) 1993, 1994 Gerd Moellmann. All rights reserved.
;;; Altenbergstr. 6, D-40235 Duesseldorf, Germany
;;; [e-mail]
;;; Suggestions, comments and requests for improvements are welcome.
;;; **********************************************************************
;;;
;;; This version works with both Emacs version 18 and 19, and I want
;;; to keep it that way. It requires the CL-19 Common Lisp compatibility
;;; package for Emacs 18 and 19.
;;;
;;; This file contains the code for member-mode.
;;;

;; This file may be made part of the Emacs distribution at the option
;; of the FSF.

;; This code is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.  Refer to the GNU Emacs General Public
;; License for full details.

;; Everyone is granted permission to copy, modify and redistribute
;; this code, but only under the conditions described in the
;; GNU Emacs General Public License.   A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities.  It should be in a
;; file named COPYING.  Among other things, the copyright notice
;; and this notice must be preserved on all copies.

(require 'cl-19 "cl")
(require 'backquote)
(require 'br-struc)
(require 'br-macro)

(defvar member-mode-map ()
  "The keymap used in the member buffers.")

(defvar member-default-decl-column 25
  "*The column in which member declarations are displayed in member
buffers.")

(defvar member-default-column-width 19
  "*The width of the columns in member buffers (short display form).")

(defvar member-mode-hook nil
  "Run in each new member buffer.")

;;;
;;; Define mode line titles for each member list.
;;;

(put 'tree-member-variables 'browse-title "Member Variables")
(put 'tree-member-functions 'browse-title "Member Functions")
(put 'tree-static-variables 'browse-title "Static Variables")
(put 'tree-static-functions 'browse-title "Static Functions")
(put 'tree-friends 'browse-title "Friends")
(put 'tree-types 'browse-title "Types")

(put 'tree-member-variables 'browse-global-title "Global Variables")
(put 'tree-member-functions 'browse-global-title "Global Functions")
(put 'tree-static-variables 'browse-global-title "Static Variables")
(put 'tree-static-functions 'browse-global-title "Static Functions")
(put 'tree-friends 'browse-global-title "Friends")
(put 'tree-types 'browse-global-title "Types")

;;;
;;; Faces used to hilight member mode buffers in Emacs 19.
;;;

(defvar member-attributes-faces 'red
  "*Face used to display member attributes.")

(defvar member-class-face 'purple
  "*Face used to display the class title in member buffers.")

(tree-make-face member-attributes-faces)
(tree-make-face member-class-face)

;;;
;;; Initialize the member mode keymap.
;;;

(unless member-mode-map
  (setf member-mode-map (make-keymap))
  (suppress-keymap member-mode-map)

  (when (and (browse-emacs-19-p) window-system)
    (define-key member-mode-map [mouse-2] 'member-mouse-2))

  (define-key member-mode-map "a" 'member-display-attributes)
  (define-key member-mode-map "c" 'member-show-some-class)
  (define-key member-mode-map "d" 'member-show-class-down)
  (define-key member-mode-map "f" 'member-find-definition)
  (define-key member-mode-map "g" 'member-position-over-all-members)
  (define-key member-mode-map "l" 'member-redisplay)
  (define-key member-mode-map "m" 'member-next-member-buffer)
  (define-key member-mode-map "n" 'member-show-next-sibling)
  (define-key member-mode-map "q" 'bury-buffer)
  (define-key member-mode-map "p" 'member-show-previous-sibling)
  (define-key member-mode-map "r" 'member-toggle-regexp)
  (define-key member-mode-map "t" 'member-show-class-in-tree)
  (define-key member-mode-map "u" 'member-show-class-up)
  (define-key member-mode-map "v" 'member-view-definition)
  (define-key member-mode-map "w" 'member-set-column-width)
  (define-key member-mode-map "F" 'member-find-declaration)
  (define-key member-mode-map "L" 'member-toggle-long-short)
  (define-key member-mode-map "V" 'member-view-declaration)
  (define-key member-mode-map "\M-g" 'member-position-on-member)
  (define-key member-mode-map "\C-d" 'member-kill)
  (define-key member-mode-map "\C-i" 'member-pop-to-tree)
  (define-key member-mode-map "\C-m" 'member-find-definition)
  (define-key member-mode-map "+" 'member-view-next)
  (define-key member-mode-map "-" 'member-view-previous)
  (define-key member-mode-map "*" 'member-toggle-superclasses)
  (define-key member-mode-map " " 'member-view-definition)
  (define-key member-mode-map "~" 'member-mark-stand-alone)
  (define-key member-mode-map "/" 'member-position-over-all-members)
  (define-key member-mode-map "?" 'describe-mode)
  (define-key member-mode-map "." 'browse-repeat-search)
  (define-key member-mode-map "0" 'member-all-visible)
  (define-key member-mode-map "1" 'member-public)
  (define-key member-mode-map "2" 'member-protected)
  (define-key member-mode-map "3" 'member-private)
  (define-key member-mode-map "4" 'member-virtual)
  (define-key member-mode-map "5" 'member-inline)
  (define-key member-mode-map "6" 'member-const)
  (define-key member-mode-map "7" 'member-pure))

;;;
;;; Switch on member-mode.
;;;

;;###autoload
(defun member-mode ()
  "Major mode in member buffers.
\\<member-mode-map>
\\[member-display-attributes] -- display member attributes.
\\[member-show-some-class] -- switch to some other class.
\\[member-show-class-down] -- switch to some derived class.
\\[member-find-definition] -- find file containing member definition.
\\[member-position-over-all-members] -- position point on some member.
\\[member-redisplay] -- redisplay buffer.
\\[member-next-member-buffer] -- switch to next member buffer for same tree.
\\[member-show-next-sibling] -- show next sibling class.
\\[bury-buffer] -- bury the buffer.
\\[member-show-previous-sibling] -- show previous sibling class.
\\[member-toggle-regexp] -- toggle declaration/definition regexp display.
\\[member-show-class-in-tree] -- show class in tree.
\\[member-show-class-up] -- switch to some base class.
\\[member-view-definition] -- view file containing member definition.
\\[member-set-column-width] -- set display column width.
\\[member-find-declaration] -- find file containing member declaration.
\\[member-toggle-long-short] -- toggle long/short display.
\\[member-view-declaration] -- view member declaration.
\\[member-view-next] -- switch to next member list.
\\[member-view-previous] -- switch to previous member list.
\\[member-toggle-superclasses] -- toggle inherited member display.
\\[member-mark-stand-alone] -- freeze buffer.
\\[describe-mode] -- describe mode.
\\[browse-repeat-search] -- repeat last search.
\\[member-all-visible] -- switch off all display filters.
\\[member-public] -- toggle display of public members.
\\[member-protected] -- toggle display of protected members.
\\[member-private] -- toggle display of private members.
\\[member-inline] -- toggle display of inline members.
\\[member-virtual] -- toggle display of virtual members.
\\[member-const] -- toggle display of const members.
\\[member-pure] -- toggle display of pure virtual members.
\\[member-kill] -- delete member from tree.
\\[member-position-on-member] -- go to some member.

\\{member-mode-map}"
  (kill-all-local-variables)
  (use-local-map member-mode-map)
  (setq major-mode 'member-mode)
  (setq mode-name "Member")
  (mapcar 'make-local-variable
      '(@decl-column        ;display column
        @n-columns            ;number of short columns
        @column-width        ;width of columns above
        @show-inherited-p        ;include inherited members?
        @filters            ;public, protected, private
        @accessor            ;vars, functions, friends
        @displayed-class        ;class displayed
        @long-display-p        ;display with regexps?
        @source-regexp-p        ;show source regexp?
        @attributes-p        ;show `virtual' and `inline'
        @member-list        ;list of members displayed
        @tree            ;the class tree
        @mode-line            ;part of mode line
        member-mode-strings        ;part of mode line
        @tags-filename        ;
        @header
        @tree-obarray
        @virtual-display-p
        @inline-display-p
        @const-display-p
        @pure-display-p
        @frozen))            ;buffer not automagically reused
  (setq mode-line-format (list "-- "
                   '@mode-line
                   " -- "
                   'member-mode-strings
                   " %-")
    buffer-read-only t)
  (setf @long-display-p nil
    @attributes-p t
    @show-inherited-p t
    @source-regexp-p nil
    @filters [0 1 2]
    @decl-column member-default-decl-column
    @column-width member-default-column-width
    @virtual-display-p nil
    @inline-display-p nil
    @const-display-p nil
    @pure-display-p nil)
  (run-hooks 'member-mode-hook))

;;;
;;; Return the name of the class displayed in the member buffer.
;;;

(defun member-class-name ()
  (class-name (tree-class @displayed-class)))

;;;
;;; Switch to the next member buffer in buffer list.
;;;

(defun member-next-member-buffer ()
  "Switch to next member buffer."
  (interactive)
  (let* ((list (member-buffers))
     (next-list (cdr (memq (current-buffer) list)))
     (next-buffer (if next-list (car next-list) (car list))))
    (if (eq next-buffer (current-buffer))
    (error "No next buffer!")
      (bury-buffer)
      (switch-to-buffer next-buffer))))

;;;
;;; Construct and update the mode line.     The mode line is made of two
;;; parts:
;;;
;;; |-- <Major part> -- <Minor part> --------------------------------|
;;;
;;; The major part displays what kinds of members are displayed in the
;;; buffer: instance vars, instance functions, static vars, static fns,
;;; or friends.     If the buffer is not a temporary buffer, the major
;;; part also includes the name of the class to which the members belong.
;;;
;;; The minor part displays the hiding

(defmacro member-list-name ()
  (` (get @accessor (if (browse-global-tree-p @displayed-class)
            'browse-global-title 'browse-title))))

(defun member-update-mode-line ()
  (let ((class-name (if @frozen (concat (member-class-name) " "))))

    ;; Major title set to class-name plus member list name
    (setq @mode-line
      (concat class-name (member-list-name)))

    ;; Strings for public, protected, private
    (setf member-mode-strings
      (cond ((notany 'null @filters) "(All)")
        ((every 'null @filters) "(None)")
        (t nil)))

    (unless member-mode-strings
      (dotimes (i 3)
    (when (aref @filters i)
      (when member-mode-strings
        (setq member-mode-strings (concat member-mode-strings ", ")))
      (setq member-mode-strings
        (concat member-mode-strings
            (aref ["public" "protected" "private"] i))))))

    ;; Inline and virtual
    (when @virtual-display-p
      (setf member-mode-strings (concat member-mode-strings " virtual")))
    (when @inline-display-p
      (setf member-mode-strings (concat member-mode-strings " inline")))
    (when @const-display-p
      (setf member-mode-strings (concat member-mode-strings " const")))
    (when @pure-display-p
      (setf member-mode-strings (concat member-mode-strings " pure")))

    ;; Long or short display form: add regexp displayed
    (when @long-display-p
      (setq member-mode-strings
        (concat member-mode-strings
            (if @source-regexp-p
            " (definitions)"
              " (declarations)"))))

    ;; Set buffer name
    (browse-rename-buffer-safe (if class-name
                   (concat class-name (member-list-name))
                 member-buffer-name))

    ;; Force mode line redisplay
    (set-buffer-modified-p (buffer-modified-p))))

;;;
;;; Toggle display of attributes.
;;;

(defun member-display-attributes ()
  "Toggle display of `virtual', `inline', `const'."
  (interactive)
  (setq @attributes-p (not @attributes-p))
  (member-redisplay))

;;;
;;; Toggle reusablity of member buffer.
;;;

(defun member-mark-stand-alone ()
  "Toggle frozen status of current buffer."
  (interactive)
  (setq @frozen (not @frozen))
  (member-redisplay))

;;;
;;; Show currently displayed class in tree.
;;;

(defun member-show-class-in-tree (arg)
  "Show the currently displayed class in the tree window. With prefix
arg switch to the tree buffer else pop to it."
  (interactive "P")
  (let ((class-name (member-class-name)))
    (when (member-pop-to-tree arg)
      (tree-position-on-class class-name))))

;;;
;;; Set width of display.
;;;

(defun member-set-column-width ()
  "Set the column width of the member display."
  (interactive)
  (let ((width (string-to-int
        (read-from-minibuffer
         (concat "Column width ("
             (int-to-string (if @long-display-p
                        @decl-column
                      @column-width))
             "): ")))))
    (when (plusp width)
      (if @long-display-p
      (setq @decl-column width)
    (setq @column-width width))
      (member-redisplay))))

;;;
;;; Switch buffer to next/previous member list.
;;;

(defun member-view-next ()
  "Switch buffer to next member list."
  (interactive)
  (brm$view 1))

(defun member-view-previous ()
  "Switch buffer to previous member list."
  (interactive)
  (brm$view -1))

;;;
;;; View the tree buffer belonging to the current member
;;; buffer.  First, a standalone tree buffer is searched
;;; corresponding to the tags filename of the member buffer.
;;; If such a buffer is not found, try the default tree
;;; buffer.  If this buffer doesn't exist either, create
;;; the default tree buffer with the tree of the member
;;; buffer.
;;;

(defun member-pop-to-tree (arg)
  "Pop to the buffer displaying the class tree. Switch
to the buffer if prefix arg. If no tree buffer exists,
make one."
  (interactive "P")
  (let ((buf (or (get-buffer (tree-frozen-buffer-name
                  @tags-filename))
         (get-buffer tree-buffer-name)
         (tree-create-buffer @tree
                     @tags-filename
                     @header
                     @tree-obarray
                     'pop))))
    (and buf
     (funcall (if arg 'switch-to-buffer 'pop-to-buffer) buf))
    buf))

;;;
;;; Helper routine for cyclic movement through member lists.
;;;

(defun* brm$view (incr
          &aux (index (position @accessor member-lists)))
  "Switch buffer to next/previous subsection of members."
  (setf @accessor
    (cond ((plusp incr) (or (nth (1+ index) member-lists)
                (first member-lists)))
          ((minusp incr) (or (and (>= (decf index) 0)
                      (nth index member-lists))
                 (first (last member-lists))))))
  (member-display-list @accessor))

;;;
;;; Show specific lists
;;;

(defun member-display-list (accessor)
  (setf @accessor accessor
    @member-list (funcall accessor @displayed-class))
  (member-redisplay))

(defun member-display-fns ()
  (interactive)
  (member-display-list 'tree-member-functions))

(defun member-display-vars ()
  (interactive)
  (member-display-list 'tree-member-variables))

(defun member-display-svars ()
  (interactive)
  (member-display-list 'tree-static-variables))

(defun member-display-sfns ()
  (interactive)
  (member-display-list 'tree-static-functions))

(defun member-display-friends ()
  (interactive)
  (member-display-list 'tree-friends))

(defun member-display-types ()
  (interactive)
  (member-display-list 'tree-types))

;;;
;;; Toggle display of inherited members.
;;;

(defun member-toggle-superclasses ()
  "Toggle the display of members inherited from base classes."
  (interactive)
  (setf @show-inherited-p (not @show-inherited-p))
  (member-redisplay))

;;;
;;; Toggle display of pure virtual members, const members etc.
;;;

(defun member-pure ()
  "Toggle display of pure virtual members."
  (interactive)
  (setf @pure-display-p (not @pure-display-p))
  (member-redisplay))

(defun member-const ()
  "Toggle display of const members."
  (interactive)
  (setf @const-display-p (not @const-display-p))
  (member-redisplay))

(defun member-inline ()
  "Toggle display of inline members."
  (interactive)
  (setf @inline-display-p (not @inline-display-p))
  (member-redisplay))

(defun member-virtual ()
  "Toggle display of virtual members."
  (interactive)
  (setf @virtual-display-p (not @virtual-display-p))
  (member-redisplay))

(defun member-all-visible ()
  "Remove all filters."
  (interactive)
  (dotimes (i 3)
    (aset @filters i i))
  (setq @pure-display-p nil
    @const-display-p nil
    @virtual-display-p nil
    @inline-display-p nil)
  (member-redisplay))

(defun member-public ()
  "Toggle visibility of public members."
  (interactive)
  (member-set-visibility 0)
  (member-redisplay))

(defun member-protected ()
  "Toggle visibility of protected members."
  (interactive)
  (member-set-visibility 1)
  (member-redisplay))

(defun member-private ()
  "Toggle visibility of private members."
  (interactive)
  (member-set-visibility 2)
  (member-redisplay))

(defun member-set-visibility (vis)
  (setf (aref @filters vis)
    (if (aref @filters vis) nil vis)))

;;;
;;; Toggle display form.
;;;

(defun member-toggle-long-short ()
  "Toggle between long and short display form."
  (interactive)
  (setf @long-display-p (not @long-display-p))
  (member-redisplay))

;;;
;;; Toggle regexp display.
;;;

(defun member-toggle-regexp ()
  "Toggle between display of declaration and definition
regular expressions in the long display form."
  (interactive)
  (setf @source-regexp-p (not @source-regexp-p))
  (member-redisplay))

;;;
;;; Find or view  declarations/ definitions. If the member list displayed
;;; cannot contain declarations, make declaration and definition
;;; equaivalent.
;;;

(defun member-find-definition ()
  "Find the file containing a member definition."
  (interactive)
  (member-goto nil t))

(defun member-view-definition ()
  "View the file containing a member definition."
  (interactive)
  (member-goto t t))

(defun member-find-declaration ()
  "Find the file containing a member's declaration."
  (interactive)
  (member-goto nil))

(defun member-view-declaration ()
  "View the file containing a member's declaration."
  (interactive)
  (member-goto t))

;;;
;;; INFO is (TREE MEMBER-LIST MEMBER) list.
;;;

(defun* member-goto (view
             &optional definition info
             (header @header)
             (tags-filename @tags-filename))
  (let (tree member accessor file on-class)

    ;; If not given as parameters, get the necessary information
    ;; out of the member buffer.

    (if info
    (setq tree (first info) accessor (second info) member (third info))
      (multiple-value-setq (tree member on-class) (member-get))
      (setq accessor @accessor))

    ;; View/find class if on a line containing a class name.

    (when on-class
      (return-from member-goto
    (browse-find-pattern (tree-class tree)
                 (list @header (tree-class tree) nil)
                 (class-file (tree-class tree))
                 tags-filename view)))

    ;; For some member lists, it doesn't make sense to search for
    ;; a definition. If this is requested, silently search for the
    ;; declaration.

    (when (and definition
           (eq accessor 'tree-member-variables))
      (setq definition nil))

    (when definition
      (setf member (make-member
            :name (member-name member)
            :file (member-definition-file member)
            :pattern (member-definition-pattern member)
            :point (member-definition-point member))))

    ;; When no file information in member, use that of the class

    (setf file (or (member-file member)
           (if definition
               (class-source-file (tree-class tree))
             (class-file (tree-class tree)))))

    ;; When we have no regular expressions in the database the only
    ;; indication that the parser hasn't seen a definition/declaration
    ;; is that the search start point will be zero.

    (if (or (null file) (zerop (member-point member)))
    (if (y-or-n-p (concat "No information about "
                  (if definition "definition" "declaration")
                  ".  Search for "
                  (if definition "declaration" "definition")
                  " of `"
                  (member-name member)
                  "'? "))
        (progn
          (message "")
          (member-goto view (not definition) info))
      (error "Search canceled."))

      (browse-find-pattern (make-browse :name (member-name member)
                    :pattern (member-pattern member)
                    :file (member-file member)
                    :point (member-point member))
               (list header member accessor)
               file tags-filename view))))

;;;
;;; Given the name of a class CLASS-NAME, return a pair
;;; of class structure and associated member list. Search space
;;; for the class name is the class displayed in the buffer
;;; and its superclasses.
;;;

(defun member-class-and-member (class-name)
  (if (string= class-name (member-class-name))
      (list @displayed-class @member-list)
    (some (function (lambda (s)
              (if (string= class-name (class-name (tree-class s)))
              (list s (funcall @accessor s)))))
      (browse-superclasses @displayed-class))))

;;;
;;; Get the MEMBER structure for the member point is on.
;;;

(defun* member-get (&aux on-class)
  (save-excursion
    (save-restriction
      (widen)
      (beginning-of-line)
      (when (looking-at "^[ \t]*$") (error "Nothing on this line."))
      (setq on-class (looking-at "class .*:"))))

  (let ((line (browse-current-line))
    class-name
    class-and-member
    class
    list-of-members
    index)
    (save-excursion
      (save-restriction
    (widen)
    (when on-class (forward-line 1))
    (unless (re-search-backward "class \\([*a-zA-Z0-9_]+\\):" nil t)
      (error "Class name not found."))
    (setf class-name (buffer-substring (match-beginning 1) (match-end 1)))
    (decf line (browse-current-line))))

    (setf index (if @long-display-p
            (- line 2)
          (+ (* (- line 2) @n-columns)
             (/ (current-column)
            (+ @column-width
               (if @attributes-p 7 0))))))

    ;; Get the class structure and the corresponding member list
    ;; displayed in the buffer
    (setf class-and-member (member-class-and-member class-name)
      list-of-members (second class-and-member)
      class (first class-and-member))

    (values class
        (nth index (delq nil (mapcar 'member-display-p list-of-members)))
        on-class)))


;;;
;;; Redisplay buffer.
;;;

(defun member-redisplay ()
  "Force buffer re-display."
  (interactive)
  (let ((display (if @long-display-p
             'member-long-display 'member-short-display)))
    (browse-output
      (erase-buffer)

      ;; Show this class
      (member-title)
      (funcall display @member-list)

      ;; Show inherited members if corresponding switch is on
      (when @show-inherited-p
    (mapcar (function
         (lambda (super)
           (goto-char (point-max))
           (unless (bolp)
             (insert "\n"))
           (insert "\n")
           (member-title super)
           (funcall display (funcall @accessor super))))
        (browse-superclasses @displayed-class)))

      ;; Update the mode line
      (member-update-mode-line)

      ;; Re-highlight buffer if Emacs 19 is running.

      (if (and (browse-emacs-19-p)
           browse-hilit-on-redisplay)
      (hilit-rehighlight-buffer t)))))

;;;
;;; Return a string to be used as the title for a class'
;;; section in the member buffer display.
;;;

(defun member-title (&optional class)
  (let ((start (point))
    class-name-start class-name-end)
    (insert "class ")
    (setq class-name-start (point))
    (insert (class-name (tree-class (or class @displayed-class))))
    (setq class-name-end (point))
    (insert ":\n\n")
    (browse-set-face start (point) member-class-face)
    (browse-put-text-property class-name-start class-name-end
                  'browser 'class-name)
    (browse-put-text-property class-name-start class-name-end
                  'mouse-face 'highlight)))


;;;
;;; Start point for member buffer creation.
;;;

(defun member-display (list &optional stand-alone class)
  (let* ((classes @tree-obarray)
     (tree @tree)
     (tags-filename @tags-filename)
     (header @header)
     (temp-buffer (get-buffer member-buffer-name)))

    ;; Get the class description from the name the cursor
    ;; is on if no specified as an argument.
    (unless class
      (setq class (tree-get-tree-at-point)))

    (with-output-to-temp-buffer member-buffer-name
      (save-excursion
    (set-buffer standard-output)

    ;; If new buffer, set the mode and initial values of locals
    (unless temp-buffer
      (member-mode))

    ;; Set local variables
    (setq @member-list (funcall list class)
          @displayed-class class
          @accessor list
          @tree-obarray classes
          @frozen stand-alone
          @tags-filename tags-filename
          @header header
          @tree tree
          buffer-read-only t)

    (member-redisplay)
    (current-buffer)))))

;;;
;;; This predicate function returns T if MEMBER must be
;;; displayed under the current filter settings.
;;;

(defun member-display-p (member)
  (if (and (aref @filters (member-visibility member))
       (or (null @const-display-p)
           (member-const-p member))
       (or (null @inline-display-p)
           (member-inline-p member))
       (or (null @pure-display-p)
           (member-pure-p member))
       (or (null @virtual-display-p)
           (member-virtual-p member)))
      member))

;;;
;;; Insert a string for the attributes of a member.
;;;

(defun member-insert-attributes (member)
  (insert (if (member-virtual-p member) "v" "-")
      (if (member-inline-p member)  "i" "-")
      (if (member-const-p member)   "c" "-")
      (if (member-pure-p member)    "0" "-")))

;;;
;;; Insert string for regular expression.
;;;

(defun member-insert-pattern (member-struc)
  (let ((pattern (if @source-regexp-p
             (member-definition-pattern member-struc)
           (member-pattern member-struc))))
    (cond ((stringp pattern)
       (insert (browse-trim pattern) "...\n")
       (beginning-of-line 0)
       (move-to-column (+ 4 @decl-column))
       (while (re-search-forward "[ \t]+" nil t)
         (delete-region (match-beginning 0) (match-end 0))
         (insert " "))
       (beginning-of-line 2))
      ((numberp pattern)
       (insert "[" (tree-header-regexp-file @header)
           " (" (int-to-string pattern) ")]\n"))
      (t
       (insert "[not recorded or unknown]\n")))))

;;;
;;; Display member buffer in long form.
;;;

(defun member-long-display (member-list)
  (mapcar (function
       (lambda (member-struc)
         (when member-struc
           (let ((name (member-name member-struc))
             (start (point)))
         ;; Insert member name truncated to the right length
         (insert (substring name
                    0
                    (min (length name)
                     (1- @decl-column))))
         (browse-put-text-property start (point)
                       'mouse-face 'highlight)
         (browse-put-text-property start (point)
                       'browser 'member-name)
         ;; Display virtual, inline, and const status
         (setf start (point))
         (browse-move-to-column @decl-column)
         (browse-put-text-property start (point) 'mouse-face nil)
         (when @attributes-p
           (let ((start (point)))
             (insert "<")
             (member-insert-attributes member-struc)
             (insert ">")
             (browse-set-face start (point) member-attributes-faces)))
         (insert " ")
         (member-insert-pattern member-struc)))))
      (mapcar 'member-display-p member-list))
  (insert "\n")
  (goto-char (point-min)))

;;;
;;; Return the width of the display to be able to adjust
;;; the number columns that must be drawn in the short
;;; display form.  This functions cycles thru the window
;;; window list to find the window displaying the current
;;; buffer, if any.  If none is found, the buffer isn't
;;; displayed, and the width of the screen is used for
;;; the display width.
;;;

(defun member-display-width ()
  (let* ((start-window (selected-window))
     done
     (window start-window))

    ;; Find the window displaying the current buffer
    (while (and (not (eq (window-buffer window) (current-buffer)))
        (not done))
      (setq window (next-window window)
        done (eq window start-window)))

    ;; If a window is found use its width, else screen width.
    (if (eq (window-buffer window) (current-buffer))
    (window-width window)
      (browse-frame-width))))

;;;
;;; Display the member list in short form.
;;;

(defun member-short-display (member-list)
  (let ((i 0)
    (column-width (+ @column-width (if @attributes-p 7 0))))

    ;; Get the number of columns to draw.
    (setq @n-columns
      (max 1 (/ (member-display-width) column-width)))

    (mapcar (function
         (lambda (member)
           (when member
         (let ((name (member-name member))
               (start (point)))
           (browse-move-to-column (* i column-width))
           (browse-put-text-property start (point)
                         'mouse-face nil)
           (when @attributes-p
             (let ((start (point)))
               (insert "<")
               (member-insert-attributes member)
               (insert "> ")
               (browse-set-face start (point)
                    member-attributes-faces)))

           (setf start (point))
           (insert (substring name 0
                      (min (length name) (1- @column-width))))
           (browse-put-text-property start (point)
                         'mouse-face 'highlight)
           (browse-put-text-property start (point)
                         'browser 'member-name)
           (incf i)
           (when (>= i @n-columns)
             (setf i 0)
             (insert "\n"))))))
        (mapcar 'member-display-p member-list))

    (when (plusp i)
      (insert "\n"))
    (goto-char (point-min))))


;;;
;;; Assign a new value to a member list.
;;;

(defun tree-set-member-list (class what newlist)
  (eval (` (setf ((, what) class) newlist))))

;;;
;;; Delete a member from the tree.
;;;

(defun member-kill ()
  "Delete member structure from tree."
  (interactive)
  (multiple-value-bind (class member) (member-get)
    (when (y-or-n-p (format "Delete member `%s' from tree? "
                (member-name member)))
      (let ((newlist (delq member (funcall @accessor class))))
    (tree-set-member-list class @accessor newlist))
      (member-redisplay))))


;;;
;;; Construct an ALIST containing all members visible in the buffer. Elements
;;; of the ALIST have the form (NAME . ACCESSOR).
;;;

(defmacro member-alist-from-list (tree accessor)
  (` (loop for m in (funcall (, accessor) (, tree))
       collect (cons (member-name m) (, accessor)))))

(defun member-member-completions ()
  (let ((list (member-alist-from-list @displayed-class @accessor)))
    (if @show-inherited-p
    (nconc list
           (loop for tree in (browse-superclasses @displayed-class)
             nconc (member-alist-from-list tree @accessor)))
      list)))

;;;
;;; The same as above but for all members of a class including
;;; those of superclasses if superclasses are shown in the
;;; member buffer.
;;;

(defun* member-all-member-completions (&aux list)
  (dolist (func member-lists list)
    (setq list (nconc list (member-alist-from-list @displayed-class func)))
    (when @show-inherited-p
      (dolist (class (browse-superclasses @displayed-class))
    (setq list (nconc list (member-alist-from-list class func)))))))

;;;
;;; Set point on a given member in the member buffer
;;;

(defun* member-set-point-to-member (name &optional repeat &aux member)
  (goto-char (point-min))
  (widen)
  (setq member
    (substring name 0 (min (length name) (1- @column-width)))
    browse-last-regexp
    (concat "[ \t\n]" (regexp-quote member) "[ \n\t]"))
  (if (re-search-forward browse-last-regexp nil t repeat)
      (goto-char (1+ (match-beginning 0)))
    (error "Not found.")))

;;;
;;; Let the user choose among all members of a class and its
;;; superclasses (optional), and position point on the
;;; member.
;;;

(defun member-position-over-all-members (prefix)
  "Read a member name from the minibuffer with completion and
position cursor on member. With prefix, position over all members
in the tree."
  (interactive "p")
  (browse-completion-ignoring-case
    (let* ((completion-list (member-all-member-completions))
       (member (completing-read "Goto member: " completion-list nil t))
       (accessor (cdr (assoc member completion-list))))
      (unless accessor (error "%s not found." member))
      (unless (eq accessor @accessor)
    (setf @accessor accessor
          @member-list (funcall accessor @displayed-class))
    (member-redisplay))
      (member-set-point-to-member member))))

;;;
;;; Simple positioning command on members only that are
;;; currently visible in the buffer.
;;;

(defun member-position-on-member (repeat)
  "Read a member name from the minibuffer with completion and
position cursor on member."
  (interactive "p")
  (browse-completion-ignoring-case
    ;; Read member name
    (let* ((completion-list (member-member-completions))
       (member (completing-read "Goto member: " completion-list nil t)))
      (member-set-point-to-member member repeat))))

;;;
;;; Read a class name from the minibuffer and switch this
;;; buffer to display that class.
;;;

(defun member-goto-other-class (title compl-list)
  (let* ((initial (unless (second compl-list)
            (first (first compl-list))))
     (class (browse-completing-read-value title compl-list initial)))
    (unless class
      (error "Not found."))
    (setf @displayed-class class
      @member-list (funcall @accessor @displayed-class))
    (member-redisplay)))

;;;
;;; Let the user choose an arbitrary class to be displayed
;;; in the current member buffer.
;;;

(defun member-show-some-class ()
  "Switch buffer to some other class read from the minibuffer."
  (interactive)
  (member-goto-other-class "Goto class: " (tree-alist)))

;;;
;;; Return the list of direct super classes for TREE.
;;;

(defun browse-direct-supers (tree)
  (remove-if-not (function (lambda (s) (memq tree (tree-subclasses s))))
         (browse-superclasses tree)))

;;;
;;; Let the user choose among the superclasses of the current
;;; class in the member buffer and redisplay the member buffer
;;; with the class chosen.
;;;

(defun member-show-class-up (arg)
  "Switch buffer to a base class."
  (interactive "P")
  (flet ((tree-alist () (loop for s in supers
                  collect (cons (class-name (tree-class s)) s)))
     (no-bases () (error "No base classes.")))
    (let ((supers (or (browse-direct-supers @displayed-class) (no-bases))))
      (if (and arg (second supers))
      (member-goto-other-class "Goto base class: " (tree-alist))
    (setq @displayed-class (first supers)
          @member-list (funcall @accessor @displayed-class))
    (member-redisplay)))))

;;;
;;; Switch the member to display a sibling class.  If a root class is
;;; currently displayed, a sibling is defined as another root class.
;;; If more than one base class exists for the class displayed, get
;;; the base class to position relative to from the minibuffer.
;;;

(defun member-show-next-sibling (arg)
  "Move to nth next sibling class; n given by prefix arg."
  (interactive "p")
  (member-show-sibling-class arg))

(defun member-show-previous-sibling (arg)
  "Move to nth previous sibling class; n given by prefix arg."
  (interactive "p")
  (member-show-sibling-class (- arg)))

(defun* member-show-sibling-class
  (inc &aux (containing-list @tree) index cls
       (supers (browse-direct-supers @displayed-class)))
  (interactive "p")
  (flet ((trees-alist (trees)
       (loop for tr in trees
         collect (cons (class-name (tree-class tr)) tr))))
    (when supers
      (let ((tree (if (second supers)
              (browse-completing-read-value
               "Relative to base class: " (trees-alist supers) nil)
            (first supers))))
    (unless tree (error "Not found."))
    (setq containing-list (tree-subclasses tree)))))
  (setq index (+ inc (position @displayed-class containing-list :test 'eq)))
  (cond ((minusp index) (message "No previous class."))
    ((null (nth index containing-list)) (message "No next class.")))
  (setq index (max 0 (min index (1- (length containing-list)))))
  (setq cls (nth index containing-list))
  (setf @displayed-class cls
    @member-list (funcall @accessor cls))
  (member-redisplay))

;;;
;;; Let the user choose among the subclasses of the current
;;; class in the member buffer and redisplay the member buffer
;;; with the class chosen.
;;;

(defun member-show-class-down (arg)
  "Switch buffer to the first derived class or to some other derived class
if called with prefix arg."
  (interactive "P")
  (flet ((no-derived () (error "No derived classes."))
     (tree-alist () (loop for s in (tree-subclasses @displayed-class)
                  collect (cons (class-name (tree-class s)) s))))
    (let ((subs (or (tree-subclasses @displayed-class) (no-derived))))
      (if (and arg (second subs))
      (member-goto-other-class "Goto derived class: " (tree-alist))
    (setq @displayed-class (first subs)
          @member-list (funcall @accessor @displayed-class))
    (member-redisplay)))))

;;;
;;; Repeat the search for the last regular expression.
;;;

(defun browse-repeat-search (repeat)
  "Repeat the last regular expression search."
  (interactive "p")
  (unless browse-last-regexp
    (error "No regular expression remembered!"))

  ;; Skip over word the point is on
  (skip-chars-forward "^ \t\n")

  ;; Search for regexp from point
  (if (re-search-forward browse-last-regexp nil t repeat)
      (progn
    (goto-char (match-beginning 0))
    (skip-chars-forward " \t\n"))

    ;; If not found above, repeat search from buffer start
    (goto-char (point-min))
    (if (re-search-forward browse-last-regexp nil t)
    (progn
      (goto-char (match-beginning 0))
      (skip-chars-forward " \t\n"))
      (error "Not found."))))


;;;
;;; Pop to a browser buffer from any other buffer.
;;;

(defun browse-pop-to-browser-buffer (arg)
  "Pop to a browser buffer from any other buffer. Pop to member
buffer if no prefix, to tree buffer otherwise."
  (interactive "P")
  (let ((buffer (get-buffer (if arg
                tree-buffer-name member-buffer-name))))
    (unless buffer
      (setq buffer
        (get-buffer (if arg member-buffer-name tree-buffer-name))))
    (unless buffer
      (error "No browser buffer found!"))
    (pop-to-buffer buffer)))


;;;
;;; Mouse support for Emacs 19. Find definition of member clicked on.
;;;

(defun member-name-object-menu (event)
  (let* ((menu '("" (""
            ("Find definition" . member-find-definition)
            ("Find declaration" . member-find-declaration)
            ("View definition" . member-view-definition)
            ("View declaration" . member-view-declaration))))
     (selection (x-popup-menu event menu)))
    (when selection
      (call-interactively selection))))

(defun member-class-object-menu (event)
  (let* ((menu '("" (""
            ("Find" . member-find-definition)
            ("View" . member-view-definition))))
     (selection (x-popup-menu event menu)))
    (when selection
      (call-interactively selection))))

(defun member-buffer-object-menu (event)
  (let* ((menu '("Member Buffer"
         ("List"
          ("Functions" . member-display-fns)
          ("Variables" . member-display-vars)
          ("Static variables" . member-display-svars)
          ("Static functions" . member-display-sfns)
          ("Types" . member-display-types)
          ("Friends" . member-display-friends))
         ("Class"
          ("Up" . member-show-class-up)
          ("Down" . member-show-class-down)
          ("Next sibling" . member-show-next-sibling)
          ("Previous sibling" . member-show-previous-sibling))
         ("Member"
          ("Show in tree" . member-show-class-in-tree)
          ("Find in this class" . member-position-on-member)
          ("Find in tree" . member-position-over-all-members))
         ("Display"
          ("Inherited" . member-toggle-superclasses)
          ("Attributes" . member-display-attributes)
          ("Long/short" . member-toggle-long-short)
          ("Column width" . member-set-column-width))
         ("Filter"
          ("Public" . member-public)
          ("Protected" . member-protected)
          ("Private" . member-private)
          ("Virtual" . member-virtual)
          ("Inline" . member-inline)
          ("Const" . member-const)
          ("Pure" . member-pure)
          ("--")
          ("Show all" . member-all-visible))
         ("Buffer"
          ("Tree" . member-pop-to-tree)
          ("Next member buffer" . member-next-member-buffer)
          ("Freeze" . member-mark-stand-alone))
          ))
     (selection (x-popup-menu event menu)))
    (when selection
      (call-interactively selection))))

(defun member-mouse-2 (event)
  (interactive "e")
  (mouse-set-point event)
  (case (event-click-count event)
    (2 (member-find-definition))
    (1
     (case (browse-get-text-property (posn-point (event-start event)) 'browser)
       (member-name (member-name-object-menu event))
       (class-name (member-class-object-menu event))
       (t (member-buffer-object-menu event))))))

(provide 'br-membe)

;; end of `member.el'