home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 5 Edit / 05-Edit.zip / browser2.zip / br-add.el next >
Lisp/Scheme  |  1995-02-17  |  8KB  |  235 lines
  1. ;;; CLASS BROWSER FOR C++
  2. ;;; $Id: br-add.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 code for adding regions and buffers to a tree.
  16. ;;; The regions are parsed by `ebrowse'; the result is merged into an
  17. ;;; existing tree.
  18. ;;; 
  19.  
  20. ;; This file may be made part of the Emacs distribution at the option
  21. ;; of the FSF.
  22.  
  23. ;; This code is distributed in the hope that it will be useful,
  24. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  25. ;; accepts responsibility to anyone for the consequences of using it
  26. ;; or for whether it serves any particular purpose or works at all,
  27. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  28. ;; License for full details.
  29.  
  30. ;; Everyone is granted permission to copy, modify and redistribute
  31. ;; this code, but only under the conditions described in the
  32. ;; GNU Emacs General Public License.   A copy of this license is
  33. ;; supposed to have been given to you along with GNU Emacs so you
  34. ;; can know your rights and responsibilities.  It should be in a
  35. ;; file named COPYING.  Among other things, the copyright notice
  36. ;; and this notice must be preserved on all copies.
  37.  
  38. (require 'cl-19 "cl")
  39. (require 'backquote)
  40. (require 'br-macro)
  41. (require 'br-struc)
  42.  
  43. ;;;
  44. ;;; The program used to parse regions. For MS-DOS and OS/2, a
  45. ;;; silly extension has to be supplied.
  46. ;;; 
  47.  
  48. (defvar browse-ebrowse-path
  49.   (concat "ebrowse" (if (memq system-type '(ms-dos OS/2)) ".exe"))
  50.   "The name and path of the EBROWSE program.")
  51.  
  52.  
  53. ;;;
  54. ;;; Given a list of TREE structures, merge this list with the list of TREEs
  55. ;;; in the current buffer (in buffer-local variable @tree).
  56. ;;; 
  57.  
  58. (defun browse-merge-tree-list (tree-list)
  59.   (dolist (tree tree-list) (browse-merge-tree tree))
  60.   (setq @tree (browse-sort-tree-list @tree)
  61.     @tree-obarray (browse-build-tree-obarray @tree))
  62.   (set-buffer-modified-p t))
  63.  
  64. ;;;
  65. ;;; Merge a single TREE structure with an existing tree in the
  66. ;;; current buffer (@tree). #### What if the inheritance structure changes?
  67. ;;; 
  68.  
  69. (defun browse-merge-tree (tree &optional derived-tree-p)
  70.   (let* ((sym (intern-soft (class-name (tree-class tree)) @tree-obarray))
  71.      (existing-tree (get sym 'browse-root)))
  72.  
  73.     (if existing-tree
  74.     (let ((old-tree existing-tree))
  75.       (browse-merge-subclasses tree old-tree)
  76.       (dolist (func member-lists)
  77.         (let* ((new-list (funcall func tree)))
  78.           (when new-list
  79.         (if (null (funcall func old-tree))
  80.             (tree-set-member-list old-tree func new-list)
  81.           (browse-merge-member-list old-tree tree func))))))
  82.       ;; Add to root tree list if TREE isn't a derived class. 
  83.       (unless derived-tree-p
  84.     (setq @tree (list* tree @tree)))))
  85.  
  86.   ;; Merge subclasses.
  87.   (dolist (c (tree-subclasses tree))
  88.     (browse-merge-tree c t)))
  89.  
  90. ;;;
  91. ;;; Return T is CLASS is a superclass of SUBCLASS
  92. ;;; 
  93.  
  94. (defun browse-superclass-p (class subclass)
  95.   (loop for c in (tree-subclasses class)
  96.     with subclass-name = (class-name (tree-class subclass))
  97.     if (string= subclass-name (class-name (tree-class c))) return t))
  98.  
  99. ;;;
  100. ;;; Add new subclasses defined in NEW but not in OLD to OLD.
  101. ;;; 
  102.  
  103. (defun browse-merge-subclasses (new old)
  104.   (let ((new-list (loop for s in (tree-subclasses new)
  105.             unless (browse-superclass-p old s) collect s)))
  106.     (setf (tree-subclasses old)
  107.       (browse-sort-tree-list (nconc (tree-subclasses old)
  108.                     new-list)))))
  109.  
  110. ;;;
  111. ;;; Merge member list with accessor FUNC of two TREE structures
  112. ;;; OLD-CLASS and NEW-CLASS.
  113. ;;; 
  114.  
  115. (defun browse-merge-member-list (old-class new-class func)
  116.   (let ((list (funcall func old-class)))
  117.     ;; Add members
  118.     (loop for m in (funcall func new-class) do
  119.       (setq list (browse-merge-member old-class new-class list m)))
  120.  
  121.     ;; Insert new member list into class structure.
  122.     (tree-set-member-list old-class
  123.               func 
  124.               (sort list (function
  125.                       (lambda (m1 m2)
  126.                     (string< (member-name m1)
  127.                          (member-name m2))))))))
  128.  
  129. ;;;
  130. ;;; Merge a single member that has different settings in OLD and
  131. ;;; NEW class.
  132. ;;; 
  133.  
  134. (defun browse-merge-member (old-class new-class member-list member)
  135.   (let* (found
  136.      (list (loop for m in member-list
  137.              with name = (member-name member)
  138.              with hash = (member-hash member)
  139.              when (and (= (member-hash m) hash)
  140.                    (string= (member-name m) name))
  141.              do (progn
  142.               (setq found t)
  143.               (browse-merge-member-structs old-class
  144.                                new-class m member))
  145.              collect m)))
  146.     (if found
  147.     list
  148.       (cons member member-list))))
  149.  
  150. ;;;
  151. ;;; Given two member structures OLD-MEMBER and MEMBER, replace
  152. ;;; information in OLD-MEMBER with new information in MEMBER."
  153. ;;;
  154.  
  155. (defun browse-merge-member-structs (old-tree new-tree old-member new-member)
  156.   (let ((old-class (tree-class old-tree))
  157.     (new-class (tree-class new-tree))
  158.     (new-name (member-name new-member))
  159.     (file (member-file new-member))
  160.     (pattern (member-pattern new-member))
  161.     (flags (member-flags new-member))
  162.     (point (member-point new-member)))
  163.  
  164.     ;; When we know something about the member declaration...
  165.     (when (member-pattern pattern)
  166.       (setf (member-name old-member) new-name
  167.         (member-file old-member) (or file (class-file new-class))
  168.         (member-pattern old-member) pattern
  169.         (member-point old-member) point
  170.         (member-flags old-member) flags))
  171.     
  172.     (when (member-definition-pattern new-member)
  173.       (setf (member-definition-file old-member)
  174.         (or (member-definition-file new-member)
  175.         (class-source-file new-class)))
  176.       (setf (member-definition-pattern old-member)
  177.         (member-definition-pattern new-member))
  178.       (setf (member-definition-point old-member) 
  179.         (member-definition-point new-member)))))
  180.  
  181. ;;;
  182. ;;; Add a buffer to some class tree.
  183. ;;; 
  184.  
  185. ;;;###autoload
  186. (defun browse-add-buffer (&optional buffer)
  187.   "Parse BUFFER (default current buffer), and add result to some class
  188. tree. If more than one tree exists, ask which one to use."
  189.   (interactive)
  190.   (save-excursion
  191.     (when buffer (set-buffer buffer))
  192.     (browse-add-region (point-min) (point-max))))
  193.  
  194. ;;;
  195. ;;; Add a region to some class tree.
  196. ;;; 
  197.  
  198. ;;;###autoload
  199. (defun browse-add-region (region-begin region-end)
  200.   "Parse current region and add result to a class tree."
  201.   (interactive "r")
  202.   (let* ((buffer (get-buffer-create " *Temp*"))
  203.      (region-buffer (current-buffer))
  204.      (tree-buffer (tree-choose-buffer))
  205.      (header (browse-@value '@header tree-buffer))
  206.      (options (read-from-minibuffer
  207.            "Ebrowse options: "
  208.            (tree-header-command-line-options header))))
  209.  
  210.     (save-excursion
  211.       (unwind-protect
  212.       (progn
  213.         (message "Parsing...")
  214.         (call-process-region region-begin
  215.                  region-end
  216.                  browse-ebrowse-path
  217.                  nil
  218.                  buffer
  219.                  nil
  220.                  options
  221.                  " "
  222.                  "-e"
  223.                  (or (buffer-file-name) "unknown"))
  224.         (set-buffer buffer)
  225.         (goto-char (point-min))
  226.         (multiple-value-bind
  227.         (options class-list) (browse-read-class-list)
  228.           (set-buffer tree-buffer)
  229.           (browse-merge-tree-list class-list)
  230.           (tree-redisplay 'quietly)))
  231.     (message "Parsing...done.")
  232.     (kill-buffer buffer)))))
  233.  
  234. ;; end of `br-add.el'.
  235.