home *** CD-ROM | disk | FTP | other *** search
/ The CDPD Public Domain Collection for CDTV 3 / CDPDIII.bin / pd / programming / gnusmalltalk / browse.el < prev    next >
Lisp/Scheme  |  1992-02-17  |  10KB  |  347 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;;
  3. ;;; Copyright (C) 1988, 1989, 1990 Free Software Foundation, Inc.
  4. ;;; Written by Steve Byrne.
  5. ;;;
  6. ;;; This file is part of GNU Smalltalk.
  7. ;;;
  8. ;;; GNU Smalltalk is free software; you can redistribute it and/or modify it
  9. ;;; under the terms of the GNU General Public License as published by the Free
  10. ;;; Software Foundation; either version 1, or (at your option) any later 
  11. ;;; version.
  12. ;;;
  13. ;;; GNU Smalltalk is distributed in the hope that it will be useful, but
  14. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  15. ;;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16. ;;; for more details.
  17. ;;;
  18. ;;; You should have received a copy of the GNU General Public License along
  19. ;;; with GNU Smalltalk; see the file COPYING.  If not, write to the Free
  20. ;;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  21. ;;;
  22. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23.  
  24.  
  25. (provide 'browse)
  26.  
  27. (defvar smalltalk-indicator "=>"
  28.   "Used to mark the selected class or method when browsing")
  29.  
  30.  
  31. (defvar smalltalk-br-mode-map nil "Local keymap for smalltalk-br-mode buffers.")
  32.  
  33.  
  34. (if smalltalk-br-mode-map
  35.     nil
  36.   (setq smalltalk-br-mode-map (make-keymap))
  37.   (suppress-keymap smalltalk-br-mode-map)
  38.   (define-key smalltalk-br-mode-map " "  'smalltalk-br-browse-def))
  39.  
  40. ;; Smalltalk-Br mode is suitable only for specially formatted data.
  41. (put 'smalltalk-br-mode 'mode-class 'special)
  42.  
  43. (defun smalltalk-br-mode (func vec)
  44.   "Mode for browsing Smalltalk \"collections\"
  45. \\{smalltalk-br-mode-map}"
  46.   (interactive)
  47.   (kill-all-local-variables)    
  48.   (setq major-mode 'smalltalk-br-mode)
  49.   (setq mode-name "ST Browse")
  50.   (setq indent-tabs-mode nil)
  51.   (make-local-variable 'smalltalk-br-func)
  52.   (setq smalltalk-br-func func)
  53.   (make-local-variable 'smalltalk-br-vector)
  54.   (setq smalltalk-br-vector vec)
  55. ;;  (setq mode-line-buffer-identification '("Smalltalk-Br: %17b"))
  56.   (setq buffer-read-only t)
  57.   (use-local-map smalltalk-br-mode-map)
  58.   (run-hooks 'smalltalk-br-mode-hook))
  59.  
  60. (defun smalltalk-hier-br-mode (vec)
  61.   "Mode for browsing Smalltalk hierarchy
  62. \\{smalltalk-br-mode-map}"
  63.   (interactive)
  64.   (let (map)
  65.     (kill-all-local-variables)    
  66.     (setq major-mode 'smalltalk-br-mode
  67.       mode-name "Hier Browse"
  68.       buffer-read-only t
  69.       truncate-lines t
  70.       indent-tabs-mode nil
  71.       )
  72.     (make-local-variable 'smalltalk-br-func)
  73.     (setq smalltalk-br-func 'smalltalk-br-selected)
  74.     (make-local-variable 'smalltalk-br-vector)
  75.     (make-local-variable 'smalltalk-prev-indicator)
  76.     (setq smalltalk-br-vector vec)
  77.     (setq map (copy-keymap smalltalk-br-mode-map))
  78.     ;; old def'n
  79.     ;(define-key map " "  'smalltalk-arrow-br-browse-def)
  80.     (define-key map " "  'smalltalk-browse-all-methods)
  81.     (define-key map "d"  'smalltalk-browse-direct-methods)
  82.     (define-key map "i"  'smalltalk-browse-indirect-methods)
  83.     (define-key map "c"  'smalltalk-browse-class-methods)
  84.     (use-local-map map)
  85.     (delete-other-windows)
  86.     (run-hooks 'smalltalk-br-mode-hook)
  87.     )
  88.   )
  89.  
  90. (defun smalltalk-method-br-mode (vec)
  91.   "Mode for browsing Smalltalk hierarchy
  92. \\{smalltalk-br-mode-map}"
  93.   (interactive)
  94.   (let (map)
  95.     (kill-all-local-variables)    
  96.     (setq major-mode 'smalltalk-br-mode
  97.       mode-name "Method Browse"
  98.       buffer-read-only t
  99.       truncate-lines t
  100.       )
  101.     (make-local-variable 'smalltalk-br-func)
  102.     (setq smalltalk-br-func 'test-func)
  103.     (make-local-variable 'smalltalk-br-vector)
  104.     (setq smalltalk-br-vector vec)
  105.     (make-local-variable 'smalltalk-prev-indicator)
  106.     (setq smalltalk-prev-indicator nil)    ;in case we reused this buffer
  107.     (setq map (copy-keymap smalltalk-br-mode-map))
  108.     (define-key map " "  'smalltalk-arrow-br-browse-def)
  109.     (use-local-map map)
  110.     (run-hooks 'smalltalk-br-mode-hook)
  111.     )
  112.   )
  113.  
  114. (defun smalltalk-browse (name func sortp list)
  115.   ;; eventually sortp will be nil, t, or sort function
  116.   (let (buf vec (len (length list)))
  117.     (setq buf (current-buffer))
  118.     (switch-to-buffer (get-buffer-create name))
  119.     (setq buffer-read-only nil)
  120.     (erase-buffer)            ;in case we reused the buffer
  121.     (and sortp
  122.      (setq list
  123.            (sort list (function (lambda (x y)
  124.                       (string-lessp (car x) (car y))))))
  125.      )
  126.     (setq vec
  127.       (apply 'vector
  128.          (mapcar
  129.           (function (lambda (x)
  130.                   (cond ((consp x)
  131.                      (insert (car x))
  132.                      (newline)
  133.                      (cdr x))
  134.                     (t
  135.                    (insert x)
  136.                    (newline)
  137.                    x)
  138.                   )
  139.                   ))
  140.           list)
  141.          ))
  142.     (goto-char (point-min))
  143.     (smalltalk-br-mode func vec)
  144.     (set-buffer buf)
  145. ;;    (switch-to-buffer buf)
  146. ;;    (switch-to-buffer-other-window buf)
  147. ;;    (other-window 1)
  148.     )
  149.   )
  150.  
  151. (defun smalltalk-method-browse (buf-name list)
  152.   ;; eventually sortp will be nil, t, or sort function
  153.   (let (buf vec (len (length list)))
  154.     (setq buf (current-buffer))
  155.     (pop-to-buffer (get-buffer-create buf-name))
  156.     (setq buffer-read-only nil)
  157.     (erase-buffer)            ;in case we reused the buffer
  158.     (setq indent-tabs-mode nil)
  159.     (setq list
  160.       (sort list (function (lambda (x y)
  161.                  (string-lessp (car x) (car y))))))
  162.     (setq vec
  163.       (apply 'vector
  164.          (mapcar
  165.           (function (lambda (x)
  166.                   (cond ((consp x)
  167.                      (insert "   " (car x))
  168.                      (newline)
  169.                      (cdr x))
  170.                     (t
  171.                    (insert "   " x)
  172.                    (newline)
  173.                    x)
  174.                   )
  175.                   ))
  176.           list)
  177.          ))
  178.     (goto-char (point-min))
  179.     (smalltalk-method-br-mode vec)
  180. ;;    (set-buffer buf)
  181. ;;    (switch-to-buffer buf)
  182. ;;    (switch-to-buffer-other-window buf)
  183. ;;    (other-window 1)
  184.     )
  185.   )
  186.  
  187. (defun smalltalk-hier-browser (list)
  188.   ;; list is this way instead of &rest so that we don't need tons of quotes
  189.   (let (buf vec (len (length list)))
  190.     (setq buf (current-buffer))
  191.     (switch-to-buffer (get-buffer-create "ST Hierarchy"))
  192.     (setq buffer-read-only nil)
  193.     (setq indent-tabs-mode nil)
  194.     (erase-buffer)            ;in case we reused the buffer
  195.     (setq vec
  196.       (apply 'vector
  197.          (mapcar
  198.           (function (lambda (x)
  199.                   (indent-to (+ (* (cdr x) 2) 3))
  200.                   (insert (car x))
  201.                   (newline)
  202.                   (car x)
  203.                   ))
  204.           list)
  205.          ))
  206.     (goto-char (point-min))
  207.     (smalltalk-hier-br-mode vec)
  208. ;; this line removed to try to fix the char gobbling bug
  209. ;;    (set-buffer buf)
  210. ;;    (switch-to-buffer buf)
  211. ;;    (switch-to-buffer-other-window buf)
  212. ;;    (other-window 1)
  213.     )
  214.   )
  215.  
  216. (defun smalltalk-br-browse-def ()
  217.   (interactive)
  218.   (let (line)
  219.     (save-restriction
  220.       (widen)
  221.       (save-excursion
  222.     (beginning-of-line)
  223.     (setq line (count-lines 1 (point)))
  224.     )
  225.       )
  226.     (funcall smalltalk-br-func (aref smalltalk-br-vector line))
  227.     )
  228.   )
  229.  
  230. (defun smalltalk-arrow-br-browse-def (arg)
  231.   (interactive "p")
  232.   (let (line)
  233.     (save-restriction
  234.       (widen)
  235.       (save-excursion
  236.     (beginning-of-line)
  237.     (smalltalk-set-indicator)
  238.     (setq line (count-lines 1 (point)))
  239.     )
  240.       )
  241.     (funcall smalltalk-br-func (aref smalltalk-br-vector line) arg)
  242.     )
  243.   )
  244.  
  245. (defun smalltalk-browse-direct-methods (arg)
  246.   (interactive "p")
  247.   (let (line)
  248.     (setq line (smalltalk-prepare-method-browsing "*Direct Methods*"))
  249. ;    (smalltalk-show-direct-class-methods class-name)
  250.     (smalltalk-show-direct-instance-methods (aref smalltalk-br-vector line))
  251.     )
  252.   )
  253.  
  254. (defun smalltalk-browse-all-methods (arg)
  255.   (interactive "p")
  256.   (let (line)
  257.     (setq line (smalltalk-prepare-method-browsing "*All Methods*"))
  258. ;    (smalltalk-show-direct-class-methods class-name)
  259.     (smalltalk-show-all-instance-methods (aref smalltalk-br-vector line))
  260.     )
  261.   )
  262.  
  263. (defun smalltalk-browse-indirect-methods (arg)
  264.   (interactive "p")
  265.   (let (line)
  266.     (setq line (smalltalk-prepare-method-browsing "*Indirect Methods*"))
  267. ;    (smalltalk-show-direct-class-methods class-name)
  268.     (smalltalk-show-indirect-instance-methods (aref smalltalk-br-vector line))
  269.     )
  270.   )
  271.  
  272. (defun smalltalk-browse-class-methods (arg)
  273.   (interactive "p")
  274.   (let (line)
  275.     (setq line (smalltalk-prepare-method-browsing "*Direct Class Methods*"))
  276.     (smalltalk-show-direct-class-methods (aref smalltalk-br-vector line))
  277.     )
  278.   )
  279.  
  280. (defun smalltalk-prepare-method-browsing (buf-name)
  281.   (let (line buf cur-buf)
  282.     (setq cur-buf (current-buffer))
  283.     (beginning-of-line)
  284.     (smalltalk-set-indicator)
  285.     (setq line (count-lines 1 (point)))
  286.     (setq buf (get-buffer-create buf-name))
  287.     (delete-other-windows)
  288.     (split-window-vertically)
  289.     (split-window-horizontally)
  290.     (other-window 1)
  291.     (switch-to-buffer buf)
  292.     (let ((buffer-read-only nil))
  293.       (erase-buffer))
  294.     (other-window -1)
  295.     line)
  296.   )
  297.  
  298. (defun smalltalk-set-indicator ()
  299.   (let ((buffer-read-only nil))
  300.     (save-excursion
  301.       (and smalltalk-prev-indicator
  302.        (save-excursion
  303.          (goto-char smalltalk-prev-indicator)
  304.          (smalltalk-replace-chars
  305.           (make-string (length smalltalk-indicator) ? ))
  306.          )
  307.        )
  308.       (setq smalltalk-prev-indicator (point))
  309.       (smalltalk-replace-chars smalltalk-indicator)
  310.       )
  311.     )
  312.   )
  313.  
  314. (defun smalltalk-replace-chars (str)
  315.   (delete-char (length str))
  316.   (insert str))
  317.  
  318.  
  319. (defun smalltalk-br-selected (class-name arg)
  320.   (let (buf is-meta)
  321.     (setq is-meta (/= arg 1))
  322.     (setq buf (get-buffer-create (if is-meta "*Class Methods*" "*Methods*")))
  323.     (delete-other-windows)
  324.     (split-window-vertically)
  325.     (split-window-horizontally)
  326.     (other-window 1)
  327.     (switch-to-buffer buf)
  328.     (let ((buffer-read-only nil))
  329.       (erase-buffer))
  330.     (if is-meta
  331.     (smalltalk-show-direct-class-methods class-name)
  332.       (smalltalk-show-direct-instance-methods class-name)
  333.       )
  334.     )
  335.   )
  336.     
  337.     
  338.  
  339.  
  340. ;(smalltalk-browse
  341. ; "zoneball"
  342. ; 'test-func
  343. ; '(("foo:" . "bar")
  344. ;   ("quem:" . "zoneball")
  345. ;   ("ducks:" . "inARow"))
  346. ; )
  347.