slynk-package-fu.lisp (2768B)
1 2 (in-package :slynk) 3 4 (defslyfun package= (string1 string2) 5 (let* ((pkg1 (guess-package string1)) 6 (pkg2 (guess-package string2))) 7 (and pkg1 pkg2 (eq pkg1 pkg2)))) 8 9 (defslyfun export-symbol-for-emacs (symbol-str package-str) 10 (let ((package (guess-package package-str))) 11 (when package 12 (let ((*buffer-package* package)) 13 (export `(,(from-string symbol-str)) package))))) 14 15 (defslyfun import-symbol-for-emacs (symbol-str 16 destination-package-str 17 origin-package-str) 18 (let ((destination (guess-package destination-package-str)) 19 (origin (guess-package origin-package-str))) 20 (when (and destination origin) 21 (let* ((*buffer-package* origin) 22 (symbol (from-string symbol-str))) 23 (when symbol 24 (import symbol destination)))))) 25 26 (defslyfun unexport-symbol-for-emacs (symbol-str package-str) 27 (let ((package (guess-package package-str))) 28 (when package 29 (let ((*buffer-package* package)) 30 (unexport `(,(from-string symbol-str)) package))))) 31 32 #+sbcl 33 (defun list-structure-symbols (name) 34 (let ((dd (sb-kernel:find-defstruct-description name ))) 35 (list* name 36 (sb-kernel:dd-default-constructor dd) 37 (sb-kernel:dd-predicate-name dd) 38 (sb-kernel::dd-copier-name dd) 39 (mapcar #'sb-kernel:dsd-accessor-name 40 (sb-kernel:dd-slots dd))))) 41 42 #+ccl 43 (defun list-structure-symbols (name) 44 (let ((definition (gethash name ccl::%defstructs%))) 45 (list* name 46 (ccl::sd-constructor definition) 47 (ccl::sd-refnames definition)))) 48 49 (defun list-class-symbols (name) 50 (let* ((class (find-class name)) 51 (slots (slynk-mop:class-direct-slots class))) 52 (labels ((extract-symbol (name) 53 (if (and (consp name) (eql (car name) 'setf)) 54 (cadr name) 55 name)) 56 (slot-accessors (slot) 57 (nintersection (copy-list (slynk-mop:slot-definition-readers slot)) 58 (copy-list (slynk-mop:slot-definition-readers slot)) 59 :key #'extract-symbol))) 60 (list* (class-name class) 61 (mapcan #'slot-accessors slots))))) 62 63 (defslyfun export-structure (name package) 64 (let ((*package* (guess-package package))) 65 (when *package* 66 (let* ((name (from-string name)) 67 (symbols (cond #+(or sbcl ccl) 68 ((or (not (find-class name nil)) 69 (subtypep name 'structure-object)) 70 (list-structure-symbols name)) 71 (t 72 (list-class-symbols name))))) 73 (export symbols) 74 symbols)))) 75 76 (provide :slynk/package-fu)