home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 5 Edit
/
05-Edit.zip
/
browser2.zip
/
br-tags.el
< prev
next >
Wrap
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
;;; 100025.3303@COMPUSERVE.COM
;;; 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'.