[slime-cvs] CVS slime/contrib
trittweiler
trittweiler at common-lisp.net
Wed Jul 23 14:27:36 UTC 2008
Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv6974/contrib
Modified Files:
ChangeLog
Added Files:
swank-package-fu.lisp slime-package-fu.el
Log Message:
* slime-package-fu.el, swank-package-fu.lisp: New contrib to
aumatically add symbols to the relevant DEFPACKAGE forms.
You can use `C-c x' to export the symbol at point, and
`C-u C-c x' to unexport it.
--- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/07/19 11:39:23 1.109
+++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/07/23 14:27:36 1.110
@@ -1,5 +1,12 @@
2008-07-19 Tobias C. Rittweiler <tcr at freebits.de>
+ * slime-package-fu.el, swank-package-fu.lisp: New contrib to
+ aumatically add symbols to the relevant DEFPACKAGE forms.
+ You can use `C-c x' to export the symbol at point, and
+ `C-u C-c x' to unexport it.
+
+2008-07-19 Tobias C. Rittweiler <tcr at freebits.de>
+
* slime-asdf.el (slime-oos): Use `slime-repl-shortcut-async'.
2008-07-16 Tobias C. Rittweiler <tcr at freebits.de>
--- /project/slime/cvsroot/slime/contrib/swank-package-fu.lisp 2008/07/23 14:27:36 NONE
+++ /project/slime/cvsroot/slime/contrib/swank-package-fu.lisp 2008/07/23 14:27:36 1.1
(in-package :swank)
(defslimefun package= (string1 string2)
(let* ((pkg1 (guess-package string1))
(pkg2 (guess-package string2)))
(and pkg1 pkg2 (eq pkg1 pkg2))))
(defslimefun export-symbol-for-emacs (symbol-str package-str)
(let ((package (guess-package package-str)))
(when package
(let ((*buffer-package* package))
(export `(,(from-string symbol-str)) package)))))
(defslimefun unexport-symbol-for-emacs (symbol-str package-str)
(let ((package (guess-package package-str)))
(when package
(let ((*buffer-package* package))
(unexport `(,(from-string symbol-str)) package)))))
(provide :swank-package-fu)--- /project/slime/cvsroot/slime/contrib/slime-package-fu.el 2008/07/23 14:27:36 NONE
+++ /project/slime/cvsroot/slime/contrib/slime-package-fu.el 2008/07/23 14:27:36 1.1
;;; slime-package-fu.el --- Exporting/Unexporting symbols at point.
;;
;; Author: Tobias C. Rittweiler <tcr at freebits.de>
;;
;; License: GNU GPL (same license as Emacs)
;;
(defvar slime-package-file-candidates
(mapcar #'file-name-nondirectory
'("package.lisp" "packages.lisp" "pkgdcl.lisp" "defpackage.lisp")))
(defvar slime-export-symbol-representation-function
#'(lambda (n) (format "#:%s" n)))
(defvar slime-defpackage-regexp
"^(\\(cl:\\|common-lisp:\\)?defpackage\\>[ \t']*")
(defun slime-find-package-definition-rpc (package)
(slime-eval `(swank:find-definition-for-thing (swank::guess-package ,package))))
(defun slime-find-package-definition-regexp (package)
(save-excursion
(save-match-data
(goto-char (point-min))
(block nil
(while (re-search-forward slime-defpackage-regexp nil t)
(when (slime-package-equal package (slime-sexp-at-point))
(return `(:location (:file ,(buffer-file-name))
;; Return position of |(DEFPACKAGE ...)
(:position ,(progn (backward-up-list 1) (point)))
(:hints)))))))))
(defun slime-package-equal (designator1 designator2)
;; First try to be lucky and compare the strings themselves (for the
;; case when one of the designated packages isn't loaded in the
;; image.) Then try to do it properly using the inferior Lisp which
;; will also resolve nicknames for us &c.
(or (equalp (slime-cl-symbol-name designator1)
(slime-cl-symbol-name designator2))
(slime-eval `(swank:package= ,designator1 ,designator2))))
(defun slime-export-symbol (symbol package)
(slime-eval `(swank:export-symbol-for-emacs ,symbol ,package)))
(defun slime-unexport-symbol (symbol package)
(slime-eval `(swank:unexport-symbol-for-emacs ,symbol ,package)))
(defun slime-find-possible-package-file (buffer-file-name)
(flet ((file-name-subdirectory (dirname)
(expand-file-name
(concat (file-name-as-directory (slime-to-lisp-filename dirname))
(file-name-as-directory ".."))))
(try (dirname)
(dolist (package-file-name slime-package-file-candidates)
(let ((f (slime-to-lisp-filename (concat dirname package-file-name))))
(when (file-readable-p f)
(return f))))))
(when buffer-file-name
(let ((buffer-cwd (file-name-directory buffer-file-name)))
(or (try buffer-cwd)
(try (file-name-subdirectory buffer-cwd))
(try (file-name-subdirectory (file-name-subdirectory buffer-cwd))))))))
(defun slime-goto-package-source-definition (package)
(flet ((try (location)
(when (slime-location-p location)
(slime-pop-to-location location 'excursion)
t)))
(or (try (slime-find-package-definition-rpc package))
(try (slime-find-package-definition-regexp package))
(try (when-let (package-file (slime-find-possible-package-file (buffer-file-name)))
(with-current-buffer (find-file-noselect package-file t)
(slime-find-package-definition-regexp package))))
(error "Couldn't find source definition of package: %s" package))))
(defun slime-goto-next-export-clause ()
(let ((point))
(save-excursion
(block nil
(while (ignore-errors (slime-forward-sexp) t)
(when (slime-at-expression-p '(:export *) :skip-blanks)
(slime-forward-blanks)
(setq point (point))
(return)))))
(if point
(goto-char point)
(error "No next (:export ...) clause found"))))
(defun slime-search-exports-in-defpackage (symbol-name)
(save-excursion
(block nil
(while (ignore-errors (slime-goto-next-export-clause) t)
(let ((clause-end (save-excursion (forward-sexp) (point))))
(when (and (search-forward symbol-name clause-end t)
(equal (slime-symbol-name-at-point) symbol-name))
(return (point))))))))
(defun slime-frob-defpackage-form (current-package do-what symbol &optional batch)
(let ((symbol-name (slime-cl-symbol-name symbol)))
(save-excursion
(slime-goto-package-source-definition current-package)
(down-list 1) ; enter DEFPACKAGE form
(forward-sexp) ; skip DEFPACKAGE symbol
(forward-sexp) ; skip package name
(let ((already-exported-p (slime-search-exports-in-defpackage symbol-name)))
(ecase do-what
(:export
(if already-exported-p
(unless batch (message "Symbol `%s' already exported in `%s'"
symbol-name current-package))
(slime-insert-export symbol-name)))
(:unexport
(if already-exported-p
(slime-remove-export symbol-name)
(unless batch (message "Symbol `%s' not exported from `%s'"
symbol-name current-package)))))))))
(defun slime-insert-export (symbol-name)
(flet ((goto-last-export-clause ()
(let (point)
(save-excursion
(while (ignore-errors (slime-goto-next-export-clause) t)
(setq point (point))))
(when point (goto-char point))
point)))
(let ((defpackage-point (point))
(symbol-name (funcall slime-export-symbol-representation-function
symbol-name)))
(cond ((goto-last-export-clause)
(down-list) (slime-end-of-list)
(unless (looking-back "^\\s-*")
(newline-and-indent))
(insert symbol-name))
(t
(slime-end-of-list)
(newline-and-indent)
(insert (format "(:export %s)" symbol-name)))))))
(defun slime-remove-export (symbol-name)
(let ((point))
(while (setq point (slime-search-exports-in-defpackage symbol-name))
(save-excursion
(goto-char point)
(backward-sexp)
(delete-region (point) point)
(beginning-of-line)
(when (looking-at "^\\s-*$")
(join-line))))))
(defun slime-export-symbol-at-point ()
"Add the symbol at point to the defpackage source definition
belonging to the current buffer-package. With prefix-arg, remove
the symbol again. Additionally performs an EXPORT/UNEXPORT of the
symbol in the Lisp image if possible."
(interactive)
(let ((package (slime-current-package))
(symbol (slime-symbol-name-at-point)))
(unless symbol (error "No symbol at point."))
(cond (current-prefix-arg
(slime-frob-defpackage-form package :unexport symbol)
(slime-unexport-symbol symbol package))
(t
(slime-frob-defpackage-form package :export symbol)
(slime-export-symbol symbol package)))))
(defun slime-package-fu-init ()
(define-key slime-mode-map "\C-cx" 'slime-export-symbol-at-point))
(slime-require :swank-package-fu)
(provide 'slime-package-fu)
More information about the slime-cvs
mailing list