ソースコードで利用している特定のパッケージのシンボルの一覧を表示する。 #xyzzy

gistfile1.cl

;; ソースコードで利用している特定のパッケージのシンボルの一覧を表示する。
;;
;; 例) 
;; xl-github が利用している editor パッケージの何かの一覧を表示
;; (show-inherited-symbols-dir "site-lisp/github" :editor)



(defun show-inherited-symbols-file (file inherited-from)
  (interactive "fFile: \nSPackage: ")
  (show-inherited-symbols-internal (list file)
                                   (default-directory)
                                   inherited-from))

(defun show-inherited-symbols-dir (dir inherited-from)
  (interactive "DDirectory: \nSPackage: ")
  (show-inherited-symbols-internal (directory dir :wild "*.l" :recursive t :file-only t)
                                   dir inherited-from))

(defun show-inherited-symbols-internal (files dir inherited-from)
  (when (and inherited-from (not (packagep inherited-from)))
    (setf inherited-from (find-package inherited-from)))
  (with-output-to-temp-buffer ("*Help*")
    (set-default-directory dir)
    (save-window-excursion
      (lisp-mode)
      (dolist (file files)
        (dolist (syms (find-symbols-in-source (merge-pathnames file dir)))
          (let ((file (car syms))
                (lineno (cadr syms))
                (symbols (caddr syms))
                (basedir-pattern (format nil "^~A/" (regexp-quote (map-backslash-to-slash dir)))))
            (dolist (sym symbols)
              (setf sym (find-symbol (symbol-name sym)
                                     (if (package-name (symbol-package sym))
                                         (symbol-package sym)
                                       *package*)))
              (when (eql (symbol-package sym) inherited-from)
                (format t "~A:~A: ~A~%"
                        (substitute-string file basedir-pattern "" :case-fold nil)
                        lineno sym)))))))))

(defun find-symbols-in-source (file)
  (let (package result buffer)
    (unwind-protect
        (progn
          (do ((i 0 (+ i 1)))
              ((let ((name (format nil "FIND-SYMBOLS-IN-SOURCE-~D" i)))
                 (unless (find-package name)
                   (setq package (make-package name :external-size 0))))))
          (setf buffer (ed::find-file-internal file))
          (with-input-from-buffer (buffer)
            (set-buffer buffer)
            (let ((*package* package))
              (handler-case
                  (while (peek-char t nil nil nil)
                    (let ((form (read nil nil '#1=#:eof)))
                      ;; read した form の先頭の行番号を記録する。
                      ;; read したあとは form の最後にいるので、
                      ;; goto-matched-parenthesis で先頭に戻る。
                      ;; stream の読み出し位置とカーソル位置は独立している。
                      (goto-line (si:*stream-line-number *standard-input*))
                      (goto-column (si:*stream-column *standard-input*))
                      (backward-char)
                      (goto-matched-parenthesis)
                      (let ((linenum (current-line-number)))
                        (when (eq form '#1#)
                          (return))
                        (push (list file linenum (find-symbols-in-forms form)) result))))
                (package-error () nil)
                (reader-error () nil))
              )))
      (when buffer
        (delete-buffer buffer))
      (when package
        (delete-package package)))
    (nreverse result)))

(defun find-symbols-in-forms (form)
  (if (atom form)
      (when (and form
                 (symbolp form)
                 (not (keywordp form)))
        (list form))
    (append (find-symbols-in-forms (car form))
            (find-symbols-in-forms (cdr form)))))