[slime-cvs] CVS slime/contrib

[CVS User sboukarev]

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv26829

Modified Files:
	ChangeLog slime-package-fu.el swank-package-fu.lisp 
Log Message:
* slime-package-fu.el (slime-export-structure): New function,
export all constructors, accessors, etc.
* swank-package-fu.lisp (export-structure): Lisp side of the above
function, works only on SBCL for now.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2010/07/23 01:46:34	1.398
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2010/07/24 12:15:13	1.399
@@ -1,3 +1,10 @@
+2010-07-24  Stas Boukarev  <stassats at gmail.com>
+
+	* slime-package-fu.el (slime-export-structure): New function,
+	export all constructors, accessors, etc.
+	* swank-package-fu.lisp (export-structure): Lisp side of the above
+	function, works only on SBCL for now.
+
 2010-07-23  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-arglists.lisp (arglist-dispatch): Export it, so it may be
--- /project/slime/cvsroot/slime/contrib/slime-package-fu.el	2010/05/28 14:15:30	1.10
+++ /project/slime/cvsroot/slime/contrib/slime-package-fu.el	2010/07/24 12:15:13	1.11
@@ -208,4 +208,13 @@
 	       (message "Symbol `%s' already exported from `%s'" symbol package))
 	   (slime-export-symbol symbol package)))))
 
+(defun slime-export-structure (name)
+  (interactive (list (slime-read-from-minibuffer "Export structure named: "
+                                                 (slime-symbol-at-point))))
+  (let* ((package (slime-current-package))
+         (symbols (slime-eval `(swank:export-structure ,name ,package))))
+    (dolist (symbol symbols)
+      (slime-frob-defpackage-form package :export symbol))
+    (message "%s symbols exported from `%s'" (length symbols) package)))
+
 (provide 'slime-package-fu)
--- /project/slime/cvsroot/slime/contrib/swank-package-fu.lisp	2008/07/23 14:27:36	1.1
+++ /project/slime/cvsroot/slime/contrib/swank-package-fu.lisp	2010/07/24 12:15:13	1.2
@@ -8,7 +8,7 @@
 
 (defslimefun export-symbol-for-emacs (symbol-str package-str)
   (let ((package (guess-package package-str)))
-    (when package
+    (when packagep
       (let ((*buffer-package* package))
 	(export `(,(from-string symbol-str)) package)))))
 
@@ -18,6 +18,17 @@
       (let ((*buffer-package* package))
 	(unexport `(,(from-string symbol-str)) package)))))
 
+#+sbcl
+(defslimefun export-structure (name package)
+  (let ((*package* (guess-package package)))
+    (when *package*
+     (let* ((dd (sb-kernel:find-defstruct-description (from-string name)))
+            (symbols (list* (sb-kernel:dd-default-constructor dd)
+                            (sb-kernel:dd-predicate-name dd)
+                            (sb-kernel::dd-copier-name dd)
+                            (mapcar #'sb-kernel:dsd-accessor-name
+                                    (sb-kernel:dd-slots dd)))))
+       (export symbols)
+       symbols))))
 
-
-(provide :swank-package-fu)
\ No newline at end of file
+(provide :swank-package-fu)