(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)