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

Lisp/Scheme | 1995-02-17 | 13KB | 367 lines

;;; CLASS BROWSER FOR C++
;;; $Id: br-tags.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 tags like functions.
;;;

;; 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-macro)
(require 'br-struc)


;;;
;;; Return a list (CLASS INDEX MEMBER) if CLASS contains a member
;;; named NAME.     INDEX is the index of the member list in which
;;; the member is found.
;;; ###FIXME
;;; This can now be done much more efficient.
;;;

(defun browse-contains-member (class name)
  (do ((list member-lists (cdr list))
       (found))
      ((or (null list) found) found)
    (do ((mlist (funcall (car list) class) (cdr mlist)))
    ((null mlist))
      (and (string= name (member-name (car mlist)))
       (setq found (list class (car list) (car mlist)))))))

;;;
;;; Return an ALIST with elements (CLASS-NAME . (CLASS LIST NAME))
;;; where each element describes on occurrence of member NAME in
;;; tree TREE.    CLASS-NAME is the name of the class in which
;;; the member was found.  The CDR of the ACONS is described
;;; above in function BROWSE-CONTAINS-MEMBER.
;;;

(defun browse-member-alist (tree tree-header name)
  (cond (browse-fast-member-lookup
     (browse-fast-member-alist tree-header name))
    (t
     (browse-slow-member-alist tree name))))

(defun browse-fast-member-alist (tree-header name)
  (let* ((sym (intern-soft name (browse-member-obarray tree-header)))
     class-list
     alist)
    (when sym
      (dolist (info (get sym 'info) alist)
    (unless (memq (first info) class-list)
      (setf alist (acons (class-name (tree-class (first info)))
                 info
                 alist)
        class-list (cons (first info) class-list)))))))

(defun browse-slow-member-alist (tree name &optional alist)
  (do* ((list tree (cdr list))
    (root (car list) (car list)))
      ((null list) alist)
    (let ((found (browse-contains-member root name)))
      (and found
       (not (assoc (class-name (tree-class root)) alist))
       (setq alist (acons (class-name (tree-class root)) found alist)))
      (setq alist
        (browse-slow-member-alist (tree-subclasses root) name alist)))))

;;;
;;; Find a buffer containing a class tree.  First, the tree
;;; buffer is searched.     If found, the tree stored there is returned.
;;; Second, the default member buffer is searched and its tree
;;; returned.
;;;

(defun browse-find-tree ()
  "Find a buffer containing of class tree and return it."
  (let* ((buffer (tree-choose-buffer)))
    (if buffer (values (browse-@value '@tree buffer)
               (browse-@value '@header buffer)
               buffer))))

;;;
;;; Read a C identifier from the current buffer like the
;;; tags facility does. Return the string read.  This functions relies
;;; on dynamic scoping (COMPLETION-IGNORE-CASE).
;;;

(defun* browse-tags-read-name (header prompt)
  "Read a C++ identifier from point and return it as string."
  (save-excursion
    (let* (start
       (members (browse-member-obarray header)))
      (multiple-value-bind (class-name member-name)
      (browse-tags-read-member-and-class-name)
    (unless member-name (error "No member name at point."))
    (if members
        (let* ((name (browse-completion-ignoring-case
              (completing-read prompt members nil
                       nil member-name))))
          (unless (eq t (try-completion name members))
        (if (y-or-n-p (concat "No exact match found. Try substrings? "))
            (progn
              (setq name
                (symbol-name
                 (or (first (browse-tags-match-list
                     members (regexp-quote name) name))
                 (error "Sorry, nothing found.")))))
          (error "Canceled.")))
          (values class-name name))
      (values class-name (read-from-minibuffer prompt member-name)))))))

;;;
;;; Return (CLASS-NAME MEMBER-NAME) from point. If there is no
;;; CLASS-NAME, return NIL for this.
;;;

(defun browse-tags-read-member-and-class-name ()
  (save-excursion
    (skip-chars-backward "a-zA-Z0-9_: \t")
    (skip-chars-forward " \t")

    (let* ((start (point))
       (name (progn (skip-chars-forward "a-zA-Z0-9_")
            (buffer-substring start (point))))
       class)

      (while (looking-at "[ \t]*::")
    (skip-chars-forward " \t:")
    (setq start (point))
    (skip-chars-forward "a-zA-Z0-9_")
    (shiftf class name (buffer-substring start (point))))

      (values class name))))

;;;
;;; Choose a class from a list of classes. Return an INFO list
;;; (TREE MEMBER-LIST MEMBER).
;;;

(defun browse-tags-choose-class (tree header name initial-class-name)
  (let ((alist (or (browse-member-alist tree header name)
           (error "No classes with member `%s' found!" name))))
    (browse-completion-ignoring-case
      (if (null (second alist))
      (cdr (first alist))
    (if (browse-emacs-19-p) (push ?\? unread-command-events)
      (setq unread-command-char ?\?))
    (cdr (assoc (completing-read "In class: "
                     alist nil t initial-class-name)
            alist))))))

;;;
;;; If VIEW is T, view, else find the an occurrence of a member.
;;; If DEFINITION is T find or view the member definition else
;;; its declaration.  This function reads the member's name from
;;; the current buffer like FIND-TAG.  It then prepares a
;;; completion list of all classes containing a member with the
;;; given name and lets the user choose the class to use.  As a
;;; last step, a tags search is performed that positions point
;;; on the member declaration or definition.
;;;

(defun browse-tags-member-search (view definition &optional fix-name)
  (multiple-value-bind
      (tree header tree-buffer) (browse-find-tree)
    (unless tree (error "No class tree."))

    (let* ((marker (point-marker)) class-name (name fix-name) info)
      (unless name
    (multiple-value-setq (class-name name)
      (browse-tags-read-name
       header
       (concat (if view "View" "Find") " member "
           (if definition "definition" "declaration") ": "))))

      (setq info (browse-tags-choose-class tree header name class-name))
      (browse-tags-push-position marker info)

      ;; Goto the occurrence of the member
      (member-goto view definition info
           header (browse-@value '@tags-filename tree-buffer))

      ;; Record position jumped to
      (browse-tags-push-position (point-marker) info t))))

;;;
;;; View definition or declaration of member at point.
;;;

;;###autoload
(defun browse-tags-view (arg)
  "View definition for member at point (declaration with prefix)."
  (interactive "P")
  (browse-tags-member-search t (not arg)))

;;;
;;; Find definition or declaration for member at point.
;;;

;;###autoload
(defun browse-tags-find (arg)
  "Find definition for member at point (declaration with prefix)."
  (interactive "P")
  (browse-tags-member-search nil (not arg)))

;;;
;;; Select or create member buffer described by INFO.
;;;

(defun browse-tags-display-member-buffer (tree-buffer info)
  (let ((buffer (get-buffer member-buffer-name)))
    (cond ((null buffer)
       (set-buffer tree-buffer)
       (switch-to-buffer (member-display (second info) nil (first info))))
      (t
       (switch-to-buffer buffer)
       (setq @displayed-class (first info)
         @accessor (second info)
         @member-list (funcall @accessor @displayed-class))
       (member-redisplay)))
    (member-set-point-to-member (member-name (third info)))))

;;;
;;; Display a member buffer for the identifier under the cursor.
;;;

(defun browse-tags-find-member-buffer (&optional fix-name)
  (interactive)
  (multiple-value-bind
      (tree header tree-buffer) (browse-find-tree)
    (unless tree (error "No class tree."))
    (let* ((marker (point-marker)) class-name (name fix-name) info)
      (unless name
    (multiple-value-setq (class-name name)
      (browse-tags-read-name header (concat "Find member list of: "))))
      (setq info (browse-tags-choose-class tree header name class-name))
      (browse-tags-push-position marker info)
      (browse-tags-display-member-buffer tree-buffer info))))

;;;
;;; Build a list of all member symbols matching NAME or REGEXP in the
;;; obarray MEMBERS.  Both NAME and REGEXP may be NIL in which case
;;; exact or regexp matches are not performed.
;;;

(defun browse-tags-match-list (members regexp &optional name)
  (nconc (when name
       (loop for s being the symbols of members
         when (string= name s) collect s))
     (when regexp
       (loop for s being the symbols of members
         when (string-match regexp (symbol-name s))
         collect s))))

;;;
;;; Display a list of all members matched by a regular expression.
;;;

(defun browse-tags-apropos ()
  "Display a list of all members matched by REGEXP."
  (interactive)
  (let* ((buffer (or (tree-choose-buffer) (error "No tree buffer.")))
     (header (browse-@value '@header buffer))
     (members (browse-member-obarray header))
     (regexp (read-from-minibuffer "List members matching regexp: ")))
    (with-output-to-temp-buffer (concat "*Apropos Members*")
      (set-buffer standard-output)
      (erase-buffer)
      (insert "Members matching \"" regexp "\":\n")
      (loop for s in (browse-tags-match-list members regexp) do
        (loop for info in (get s 'info) do
          (browse-tags-insert-member-info info))))))

;;;
;;; Display a lists of members in FILENAME. Prepare a file list,
;;; let user select a file, get member list and check member declaration
;;; and definition file against file.
;;;

(defun browse-tags-list ()
  (interactive)
  (let* ((buffer (or (tree-choose-buffer)
             (error "No tree buffer.")))
     (files (save-excursion (set-buffer buffer)
                (tree-files-obarray)))
     (file (completing-read "List members in file: " files nil t))
     (header (browse-@value '@header buffer))
     (members (browse-member-obarray header)))

    (with-output-to-temp-buffer (concat "*Members in file " file "*")
      (set-buffer standard-output)
      (loop for s being the symbols of members
        as list = (get s 'info) do
        (loop for info in list
          as member = (third info)
          as class = (tree-class (first info))
          when (or (and (null (member-file member))
                (string= (class-file class) file))
               (string= file (member-file member)))
          do (browse-tags-insert-member-info info "decl.")
          when (or (and (null (member-definition-file member))
                (string= (class-source-file class) file))
               (string= file (member-definition-file member)))
          do (browse-tags-insert-member-info info "defn."))))))

;;;
;;; Print an info
;;;

(defun* browse-tags-insert-member-info (info &optional (kind ""))
  (insert (class-name (tree-class (first info)))
      "::"
      (member-name (third info)))
  (indent-to 40)
  (insert kind)
  (indent-to 50)
  (insert (case (second info)
        ('tree-member-functions "member function")
        ('tree-member-variables "member variable")
        ('tree-static-functions "static function")
        ('tree-static-variables "static variable")
        ('tree-friend "friend")
        ('tree-types "type"))
      "\n"))

;;;
;;; Building a list of all matches of a given string in the member obarray
;;; in the order of match quality (exact matches, then substring matches).
;;; The only question remaining is what to do with members that are defined
;;; in more than one class with the same name.
;;;
;;; We must give the user the chance of directly jumping to a (member class).
;;; On the other hand we must make it easy to traverse the list of members.
;;; I.e. we build a complete list of all (member class) pairs that we need
;;; to jump to the member.
;;;


;;; end of `tags.el'.