diff options
Diffstat (limited to 'vim/bundle/slimv/slime/contrib/swank-package-fu.lisp')
-rw-r--r-- | vim/bundle/slimv/slime/contrib/swank-package-fu.lisp | 65 |
1 files changed, 65 insertions, 0 deletions
diff --git a/vim/bundle/slimv/slime/contrib/swank-package-fu.lisp b/vim/bundle/slimv/slime/contrib/swank-package-fu.lisp new file mode 100644 index 0000000..a22807a --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-package-fu.lisp @@ -0,0 +1,65 @@ + +(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))))) + +#+sbcl +(defun list-structure-symbols (name) + (let ((dd (sb-kernel:find-defstruct-description name ))) + (list* name + (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))))) + +#+ccl +(defun list-structure-symbols (name) + (let ((definition (gethash name ccl::%defstructs%))) + (list* name + (ccl::sd-constructor definition) + (ccl::sd-refnames definition)))) + +(defun list-class-symbols (name) + (let* ((class (find-class name)) + (slots (swank-mop:class-direct-slots class))) + (labels ((extract-symbol (name) + (if (and (consp name) (eql (car name) 'setf)) + (cadr name) + name)) + (slot-accessors (slot) + (nintersection (copy-list (swank-mop:slot-definition-readers slot)) + (copy-list (swank-mop:slot-definition-readers slot)) + :key #'extract-symbol))) + (list* (class-name class) + (mapcan #'slot-accessors slots))))) + +(defslimefun export-structure (name package) + (let ((*package* (guess-package package))) + (when *package* + (let* ((name (from-string name)) + (symbols (cond #+(or sbcl ccl) + ((or (not (find-class name nil)) + (subtypep name 'structure-object)) + (list-structure-symbols name)) + (t + (list-class-symbols name))))) + (export symbols) + symbols)))) + +(provide :swank-package-fu) |