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

Text File | 1995-02-17 | 22KB | 600 lines

;;; CLASS BROWSER FOR C++
;;; $Id: br-brows.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 (at least as long as Emacs Lisp is dynamic :-)
;;; It requires the CL-19 Common Lisp compatibility package for Emacs 18
;;; and 19.
;;;
;;; This file contains the stub that is always loaded when you
;;; `(require 'br-browse)'.  It installs a FIND-FILE hook
;;; that loads a tree structure into memory.  It also contains utility
;;; functions used in various parts of the package.
;;;
;;; NAMING CONVENTIONS:
;;;
;;; * all buffer-local variables in this package start with `@'.
;;; * this package uses the prefixes `tree-', `browse-', `member-', and
;;;   `class-'.
;;;

;; IDEAS FOR IMPLEMENTATION:
;; * Prepare for name spaces.
;; * Edit member attributes like `virtual', `const' etc., edit regular
;;   expressions.
;; * When members are deleted/added add them to member obarray. Likewise
;;   for classes.
;; * In member buffers provide a `SuperGoto' which positions on any
;;   member defined in the tree.
;; * If 2 members with the same name exist in the same class and regexps
;;   are known for one member but not for the other, the function
;;   BROWSE-TAGS-READ-NAME will return just one member. It shpuld pop
;;   up a list of those members applicable, in a way so that the members
;;   are distinguishable.
;; * Make new functions available via menu.
;; * Write documentation.

;; NEWS
;; * find-file, write-file, save-buffer, revert-buffer and so on
;;   can now be used on trees. The function `browse' is gone.
;; * Classes in the tree can be marked for later operations.
;; * browse-search, browse-query-replace, browse-loop are work-alikes
;;   for their `tags-' counterparts with the following differences:
;;   (a) if classes are marked in the tree, only files from the marked
;;   classes are visited, and (b) files that aren't modified and
;;   weren't visited when the operation starts are discarded.
;; * Classes and members can be deleted, regions and buffers can be
;;   added to the tree. The tree can be saved.
;; * Regular expressions can optionally be placed in a separate file
;;   that is only loaded when needed.
;; * Files generated with ebrowse option `-n' (no regexps) are handled
;;   better, so that you can use `-n' most of the time.
;; * Global functions, variables, types are now part of the tree.
;; * Electric position stack display.
;; * Positioning will load file if not present in a buffer
;; * Code cleanup
;; * Symbol completion for members in the tree.
;; * Much faster operation of `browse-tags-find'.
;; * Electric tree buffer selection for operations on trees.
;; * Superclass lists built incrementally to improve load time and
;;   reduces memory consumption.
;; * list-tags and -apropos.
;; * Search for member usage.

;; 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 'backquote)                    ;to make life easier
(require 'cl-19 "cl")


;;;
;;;
;;;

;; (if (> (string-to-int emacs-version) 18)
;;     (progn
;;       (require 'cl-19 "cl")
;;       (eval-when-compile
;;         (progn
;;           (require 'cl-compat)
;;           (require 'view)
;;           (load "cl-extra")
;;           (load "cl-macs"))))
;;   (require 'cl))

(require 'br-struc)
(require 'br-macro)
(require 'br-rev)

;;;
;;; Autoloads.
;;;

(autoload 'tree-files-obarray "br-loop")
(autoload 'browse-next-file "br-loop" nil t)
(autoload 'browse-tags-find-member-buffer "br-tags" nil t)
(autoload 'member-goto "br-membe")
(autoload 'browse-electric-choose-tree "br-trees")
(autoload 'tree-choose-buffer "br-trees")
(autoload 'browse-find-tree "br-tags")
(autoload 'tree-marked-exist-p "br-tree")
(autoload 'browse-tags-read-name "br-tags")
(autoload 'tree-choose-buffer "br-trees")
(autoload 'browse-complete-symbol "br-compl"
      "Complete the symbol point is on." t)
(autoload 'browse-add-buffer "br-add"
      "Parse buffer and add result to tree." t)
(autoload 'browse-add-region "br-add"
      "Parse region and add result to tree." t)
(autoload 'browse-tags-back "br-posit"
      "Move backward in position stack." t)
(autoload 'browse-tags-forward "br-posit"
      "Move forward in position stack." t)
(autoload 'browse-electric-position-list "br-posit"
      "Display position stack in electric buffer." t)
(autoload 'browse-tags-find "br-tags" "Find member point is on." t)
(autoload 'browse-tags-view "br-tags" "View member point is on." t)
(autoload 'browse-tags-apropos "br-tags"
      "View list of members matching regular expression." t)
(autoload 'browse-tags-list "br-tags" "List members in a file." t)
(autoload 'browse-loop "br-loop" "Continue last tags operation." t)
(autoload 'browse-search "br-loop" "Search for regexp in tree files." t)
(autoload 'browse-search-member-usage "br-loop"
      "Search for call of given member." t)
(autoload 'browse-query-replace "br-loop"
      "Perform query replace over files in tree." t)
(autoload 'tree-save "br-save" "Save tree to disk." t)
(autoload 'tree-write "br-save" "Write tree to different file." t)
(autoload 'tree-statistics "br-stat" "Display tree statistics." t)
(autoload 'tree-write-regexps "br-save" "Write regular expressions to file." t)
(autoload 'member-display "br-membe")
(autoload 'tree-choose-buffer "br-trees")
(autoload 'browse-tags-push-position "br-posit")
(autoload 'browse-electric-choose-tree "br-trees")
(autoload 'tree-create-buffer "br-tree")
(autoload 'browse-tags-member-search "br-tags")


(defvar browse-options '(verbose)
  "A list of symbols each one describing an interesting aspect of the
system on which the browser is installed, or an option specified by
users. The following symbols can be included:

verbose         option; be verbose when loading files
emacs-19        system; if we are running under Emacs 19.")

;;;
;;; If we are running under Emacs 19, include the symbol 'emacs-19 in
;;; BROWSE-OPTIONS.
;;;

(when (> (string-to-int emacs-version) 18)
  (push 'emacs-19 browse-options))

;;;
;;; Increase size of stack.
;;;

(eval-when (compile)
  (setq max-lisp-eval-depth (max 300 max-lisp-eval-depth)))


;;; A string stored in the BROWSE file specifiying the Lisp package
;;; version required.
(defconst browse-version-string "GeM 3.00")

;;; The name used for the `global' class. This must be the same that
;;; `ebrowse' uses.
(defconst browse-global-tree-name "*Globals*")

;;; Last regular expression searched for in tree and member buffers.
;;; Automatically buffer local so that each tree and member buffer
;;; maitains its own search history.
(make-variable-buffer-local 'browse-last-regexp)
(defvar browse-last-regexp nil)

(defvar browse-find-hook nil
  "Hooks run after finding or viewing a definition or declaration.")

(defvar browse-not-found-hook nil
  "Hooks run when finding or viewing was not successfull.")

(defvar browse-window-configuration nil
  "Window configuration saved/restored in Emacs 18.")

(defvar browse-enable-menu-bar t
  "*T means show menu bar in Emacs 19.")

(defvar browse-fast-member-lookup t
  "T means build obarray of members to speed up member lookup.  This
cost additional memory, so it could be necessary to switch this option
off if working on large trees.")

(defvar browse-lazy-fast-members t
  "T means that the obarray of all members is only built when it is
needed the first time. This feature is for speeding up loading.")

(defvar browse-hilit-on-redisplay t
  "T means rehighlight buffer if redisplayed.")

(defvar member-lists '(tree-member-variables
                       tree-member-functions
                       tree-static-variables
                       tree-static-functions
                       tree-friends
                       tree-types)
  "A list of symbols each of which is an accessor for a member list
displayed in the browser.")

(defconst member-buffer-name "*Members*"
  "*The name of the temporary buffer for member display.")

;;;
;;; Completion with ignored case in Emacs 18 doesn't
;;; convert the minibuffer contents to the right case when
;;; the minibuffer is already a complete match (case insensitive).
;;; When this happens, VALUE will be nil.
;;;
;;; This function performs a completion with an ALIST and returns
;;; the VALUE part of the completion read.
;;;

(defun browse-completing-read-value (title alist initial)
  (browse-completion-ignoring-case
    (let ((key (completing-read title alist nil t initial)))
      (or (cdr (assoc key alist))
      (loop for x in alist
        with downcase-key = (downcase key)
        until (string= (downcase (car x)) downcase-key)
        finally return (cdr x))))))

;;;
;;; Return the value of the buffer-local variable SYM in BUFFER.
;;; Note that we cannot simply search for an association in the
;;; list of buffer-local variables since not all variables are kept
;;; in form of an association.
;;;

(defun* browse-@value
    (sym buffer &aux (old-buffer (current-buffer)))
  (unwind-protect
      (progn (set-buffer buffer) (symbol-value sym))
    (set-buffer old-buffer)))

;;;
;;; Return an ALIST of elements (CLASS-NAME . TREE) for all classes
;;; in the tree stored in the buffer-local variable @TREE-OBARRAY.
;;; Note that this function must be called in a buffer containing
;;; such a local variable.
;;;

(defun* tree-alist (&aux alist)
  (dotrees (tree @tree-obarray)
    (setq alist (acons (class-name (tree-class tree)) tree alist)))
  alist)

;;;
;;; Sort a list of TREE structures alphabetically.
;;;

(defun browse-sort-tree-list (list)
  (sort list (function
          (lambda (a b) (string< (class-name (tree-class a))
                     (class-name (tree-class b)))))))

;;;
;;; Rename current buffer to NEW-NAME.  If a buffer with
;;; name NEW-NAME already exists, delete it first.
;;;

(defun* browse-rename-buffer-safe
    (new-name &aux (old-buffer (get-buffer new-name)))
  (unless (eq old-buffer (current-buffer))
    (when old-buffer
      (save-excursion (kill-buffer old-buffer)))
    (rename-buffer new-name)))

;;;
;;; Return a copy of STRING with leading white space removed,
;;; and with newlines in it replaced with a single space.
;;;

(defun browse-trim (string)
  (when (string-match "^[ \t\n\r]+" string)
    (setf string (substring string (match-end 0))))
  (loop while (string-match "[\n]+" string)
    finally return string do
    (setf string (concat (substring string 0 (match-beginning 0)) " "
                 (substring string (match-end 0))))))

;;;
;;; Install a FIND-FILE hook that when finding a BROWSE structure file
;;; creates a new tree buffer. Note that ADD-HOOK in the Gillespie
;;; CL package has to be fixed to work properly.
;;;

(defun browse-find-tree-hook ()
  (when (looking-at "\\[cl-struct-tree-header")
    (browse-load-file buffer-file-name 'switch)))

(add-hook 'find-file-hooks 'browse-find-tree-hook)

;;;
;;; Search for a class with the same name as CLASS in TREE.
;;; Return the class found, if any. This function is used during the
;;; load phase where classes appended to a file replace older class
;;; information.
;;;

(defun* browse-find-root (class tree)
  (find class tree
        :test (function (lambda (class root)
                          (string= (class-name (tree-class root))
                                   (class-name (tree-class class)))))))

;;;
;;; Give some feedback for lengthy operations.
;;;

(defvar browse-progress-counter -1)
(defvar browse-progress-msgs '("--" "\\" "|" "/"))

(defun browse-indicate-progress (title &optional start)
  (when start (setq browse-progress-counter -1))
  (message (concat title " "
           (nth (logand 3 (incf browse-progress-counter))
            browse-progress-msgs)
           "  ")))

;;;
;;; Read TREE-HEADER and TREE structures the current buffer.
;;; Return as multiple values (HEADER TREE) where HEADER is the header
;;; read an TREE is a list of TREE structures making up the class
;;; tree.
;;;

(defun browse-read-class-list ()
  (when (progn (goto-char 1) (eobp))
    (error "File is empty."))

  (let ((header (read (current-buffer)))
        tree)
    ;; Check version
    (unless (and (tree-header-p header)
                 (string= (tree-header-version header)
                          browse-version-string))
      (error "File has wrong version number %s (%s expected)!"
             (tree-header-version header)
             browse-version-string))

    ;; Convert path of regexp file to absolute form.
    (unless (or (null (tree-header-regexp-file header))
                (file-name-absolute-p (tree-header-regexp-file header)))
      (setf (tree-header-regexp-file header)
            (expand-file-name (tree-header-regexp-file header))))

    ;; Read Lisp objects. Temporarily increase GC-CONS-THRESHOLD to
    ;; a large value to prevent garbage collections that would not
    ;; free any memory.

    (let ((old-threshold gc-cons-threshold))
      (unwind-protect
      (progn
        (setf gc-cons-threshold 1000000)

        ;; Read Lisp objects
        (while (not (eobp))
          (let* ((root (read (current-buffer)))
             (old-root (browse-find-root root tree)))
        (browse-indicate-progress "Reading data" (null tree))
        (if old-root
            (setf (car old-root) root)
          (push root tree))
        (skip-chars-forward " \t\n"))))

    (setf gc-cons-threshold old-threshold)))

    (garbage-collect)
    (values header tree)))

;;;
;;; Load a browser file into memory.  This function is normally called
;;; via a FIND-FILE hook.
;;;

(defun browse-load-file (file &optional switch)
  (let (tree
        header
        (buffer (get-file-buffer file))
        tree-buffer)
    (if buffer
        (multiple-value-setq (header tree) (browse-read-class-list))
      (save-excursion
        ;; Since find-file hooks may be involved, we must visit the
        ;; file in a way that these hooks are not called.
        (set-buffer (create-file-buffer file))
        (erase-buffer)
        (insert-file file)
        (set-buffer-modified-p nil)
        (unwind-protect
            (multiple-value-setq (header tree) (browse-read-class-list))
          (kill-buffer (current-buffer)))))

    (when tree
      (message "Sorting. Please be patient...")
      (setf tree (browse-sort-tree-list tree))

      ;; Create tree buffer
      (setf tree-buffer (tree-create-buffer tree
                                            file
                                            header
                                            (browse-build-tree-obarray tree)
                                            switch
                                            buffer))

      (message "")
      tree-buffer)))

;;;
;;; This function must be called with current buffer in tree mode.
;;; It constructs an obarray with a symbol for each member of all classes
;;; mentioned in the buffer-local OBARRAY @TREE-OBARRAY. Each symbol
;;; has its property 'INFO set to a list of (TREE MEMBER-LIST MEMBER) lists
;;; where TREE is the tree in which the member is defined in, MEMBER-LIST
;;; is a symbol describing the member list in which the member is found,
;;; and MEMBER is a MEMBER structure describing the member. The slot
;;; MEMBER-OBARRAY of the buffer-local structure TREE-HEADER is set to
;;; this obarray.
;;;

(defun tree-fill-member-obarray ()
  (let ((members (make-vector 127 0))
    (i -1))

    (setf (tree-header-member-obarray @header) nil)
    (garbage-collect)

    ;; For all classes...
    (dotrees (c @tree-obarray)
      (when (zerop (% (incf i) 10))
    (browse-indicate-progress "Preparing member lookup" (zerop i)))

      (loop for f in member-lists do
            (loop for m in (funcall f c) do
                  (let ((sym (intern (member-name m) members)))
                    (push (list c f m) (get sym 'info))))))

    ;; Set slot MEMBER-OBARRAY of local variable @HEADER.
    (setf (tree-header-member-obarray @header) members)))

;;;
;;; Make sure every TREE in the class tree is represented by a
;;; unique object. Build obarray of all classes in tree.
;;;

(defun* browse-build-tree-obarray (tree
                    &aux (classes (make-vector 127 0)))
  ;; Add root classes...
  (loop for root in tree
        as sym = (intern (class-name (tree-class root)) classes) do
        (unless (get sym 'browse-root)
          (setf (get sym 'browse-root) root)))

  ;; Process subclasses
  (br$insert-supers tree classes)
  classes)

;;;
;;; Helper function for BROWSE-BUILD-TREE-OBARRAY
;;; Superclasses should be ordered so that the immediate base
;;; comes first, then the base class of the immediate base class
;;; and so on.  This means that we must construct the superclass
;;; list top down with adding each level at the beginning of the
;;; superclass list.
;;;
;;; We have to be cautious here not to end up in an infinite
;;; recursion if for some reason a circle is in the inheritance
;;; graph.
;;;

(defun br$insert-supers (tree classes)
  (loop for class in tree
    as subclasses = (tree-subclasses class) do

    ;; Make sure every class is represented by a unique object
    (loop for subclass on subclasses
          as sym = (intern (class-name (tree-class (car subclass)))
                   classes)
          as next = nil
          do

          ;; Replace the subclass tree with the one found in
          ;; CLASSES if there is already an entry for that class
          ;; in it. Otherwise make a new entry.
          ;;
          ;; CAVEAT: If by some means (e.g., use of the
          ;; preprocessor in class declarations, a name is marked
          ;; as a subclass of itself on some path, we would end up
          ;; in an endless loop. We have to omit subclasses from
          ;; the recursion that already have been processed.

          (if (get sym 'browse-root)
          (setf (car subclass) (get sym 'browse-root))
        (setf (get sym 'browse-root) (car subclass))))

    ;; Process subclasses
    (br$insert-supers subclasses classes)))

;;;
;;; Kill all member buffers displaying TREE.
;;;

(defun browse-kill-member-buffers-displaying (tree)
  (loop for b in (member-buffers)
    as c = (browse-@value '@displayed-class b)
    when (eq c tree) do (kill-buffer b)))

;;;
;;; Remove a class from a tree. Kill all member buffers still containing
;;; a reference to the TREE.
;;;

(defun browse-remove-class (tree class)
  (let ((sym (intern-soft (class-name (tree-class class)) @tree-obarray)))
    (setf tree (delq class tree)
          (get sym 'browse-root) nil)
    (dolist (root tree)
      (setf (tree-subclasses root) (delq class (tree-subclasses root))
            (tree-superclasses root) nil)
      (browse-remove-class (tree-subclasses root) class))
    (browse-kill-member-buffers-displaying class)
    tree))

;;;
;;; Build the member obarray.
;;;

(defun browse-member-obarray (header)
  (when (and (null (tree-header-member-obarray header))
         browse-fast-member-lookup)
    (loop for buffer in (browse-buffers)
      until (eq header
            (browse-@value '@header buffer))
      finally do (save-excursion
               (set-buffer buffer)
               (tree-fill-member-obarray))))
  (tree-header-member-obarray header))

;;;
;;; Mouse support.
;;;
;;; The following function can be used to position point on the
;;; definition of a member under the mouse cursor.
;;;
;;; There is some problem with double clicks here.  If we change the
;;; window in the following function, the event will set the point
;;; in the new window. We would need to have a function that kills the
;;; event.
;;; ###FIXME Can use function brows-read-class-and-member.
;;;

(defun browse-mouse-member-find (event)
  (interactive "e")
  (mouse-set-point event)
  (let (start name)
    (save-excursion
      (skip-chars-backward "a-zA-Z0-9_")
      (setq start (point))
      (skip-chars-forward "a-zA-Z0-9_")
      (setq name (buffer-substring start (point))))
    (browse-tags-member-search nil t name)))

(provide 'browse)

;;; end of `browse.el'.