66 lines
2.3 KiB
Common Lisp
66 lines
2.3 KiB
Common Lisp
|
|
||
|
|
(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)
|