;;; defpkg.lisp --- defpackage extension macro

 ;;; Commentary:

 ;;

 ;;; Code:

 (defpackage :std/defpkg

   (:use :cl)

   (:nicknames :pkg)

   (:export :defpkg

    :find-package* :find-symbol* :symbol-call :intern*

    :export* :import* :shadowing-import* :shadow* 

    :symbol-shadowing-p :home-package-p :make-symbol* :unintern*

    :symbol-package-name :standard-common-lisp-symbol-p

    :reify-package :unreify-package :reify-symbol :unreify-symbol

 (in-package :std/defpkg)

 (eval-when (:load-toplevel :compile-toplevel :execute)

   (defun find-package* (package-designator &optional (error t))

     (let ((package (find-package package-designator)))

       (cond

         (package package)

         (error (error "No package named ~S" (string package-designator)))

         (t nil))))

   (defun find-symbol* (name package-designator &optional (error t))

     "Find a symbol in a package of given string'ified NAME;

 unlike CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax

 by letting you supply a symbol or keyword for the name;

 also works well when the package is not present.

 If optional ERROR argument is NIL, return NIL instead of an error

 when the symbol is not found."

     (block nil

       (let ((package (find-package* package-designator error)))

         (when package ;; package error handled by find-package* already

           (multiple-value-bind (symbol status) (find-symbol (string name) package)

             (cond

               (status (return (values symbol status)))

               (error (error "There is no symbol ~S in package ~S" name (package-name package))))))

         (values nil nil))))

   (defun symbol-call (package name &rest args)

     "Call a function associated with symbol of given name in given package,

 with given ARGS. Useful when the call is read before the package is loaded,

 or when loading the package is optional."

     (apply (find-symbol* name package) args))

   (defun intern* (name package-designator &optional (error t))

     (intern (string name) (find-package* package-designator error)))

   (defun export* (name package-designator)

     (let* ((package (find-package* package-designator))

            (symbol (intern* name package)))

       (export (or symbol (list symbol)) package)))

   (defun import* (symbol package-designator)

     (import (or symbol (list symbol)) (find-package* package-designator)))

   (defun shadowing-import* (symbol package-designator)

     (shadowing-import (or symbol (list symbol)) (find-package* package-designator)))

   (defun shadow* (name package-designator)

     (shadow (list (string name)) (find-package* package-designator)))

   (defun make-symbol* (name)

     (etypecase name

       (string (make-symbol name))

       (symbol (copy-symbol name))))

   (defun unintern* (name package-designator &optional (error t))

     (block nil

       (let ((package (find-package* package-designator error)))

         (when package

           (multiple-value-bind (symbol status) (find-symbol* name package error)

             (cond

               (status (unintern symbol package)

                       (return (values symbol status)))

               (error (error "symbol ~A not present in package ~A"

                             (string symbol) (package-name package))))))

         (values nil nil))))

   (defun symbol-shadowing-p (symbol package)

     (and (member symbol (package-shadowing-symbols package)) t))

   (defun home-package-p (symbol package)

     (and package (let ((sp (symbol-package symbol)))

                    (and sp (let ((pp (find-package* package)))

                              (and pp (eq sp pp))))))))

 (eval-when (:load-toplevel :compile-toplevel :execute)

   (defun symbol-package-name (symbol)

     (let ((package (symbol-package symbol)))

       (and package (package-name package))))

   (defun standard-common-lisp-symbol-p (symbol)

     (multiple-value-bind (sym status) (find-symbol* symbol :common-lisp nil)

       (and (eq sym symbol) (eq status :external))))

   (defun reify-package (package &optional package-context)

     (if (eq package package-context) t

         (etypecase package

           (null nil)

           ((eql (find-package :cl)) :cl)

           (package (package-name package)))))

   (defun unreify-package (package &optional package-context)

     (etypecase package

       (null nil)

       ((eql t) package-context)

       ((or symbol string) (find-package package))))

   (defun reify-symbol (symbol &optional package-context)

     (etypecase symbol

       ((or keyword (satisfies standard-common-lisp-symbol-p)) symbol)

       (symbol (vector (symbol-name symbol)

                       (reify-package (symbol-package symbol) package-context)))))

   (defun unreify-symbol (symbol &optional package-context)

     (etypecase symbol

       (symbol symbol)

       ((simple-vector 2)

        (let* ((symbol-name (svref symbol 0))

               (package-foo (svref symbol 1))

               (package (unreify-package package-foo package-context)))

          (if package (intern* symbol-name package)

              (make-symbol* symbol-name)))))))

 (eval-when (:load-toplevel :compile-toplevel :execute)

   (defvar *all-package-happiness* '())

   (defvar *all-package-fishiness* (list t))

   (defun record-fishy (info)

     ;;(format t "~&FISHY: ~S~%" info)

     (push info *all-package-fishiness*))

   (defmacro when-package-fishiness (&body body)

     `(when *all-package-fishiness* ,@body))

   (defmacro note-package-fishiness (&rest info)

     `(when-package-fishiness (record-fishy (list ,@info)))))

 (eval-when (:load-toplevel :compile-toplevel :execute)

   #+(or clisp clozure)

   (defun get-setf-function-symbol (symbol)

     #+clisp (let ((sym (get symbol 'system::setf-function)))

               (if sym (values sym :setf-function)

                   (let ((sym (get symbol 'system::setf-expander)))

                     (if sym (values sym :setf-expander)

                         (values nil nil)))))

     #+clozure (gethash symbol ccl::%setf-function-names%))

   #+(or clisp clozure)

   (defun set-setf-function-symbol (new-setf-symbol symbol &optional kind)

     #+clisp (assert (member kind '(:setf-function :setf-expander)))

     #+clozure (assert (eq kind t))

     #+clisp

     (cond

       ((null new-setf-symbol)

        (remprop symbol 'system::setf-function)

        (remprop symbol 'system::setf-expander))

       ((eq kind :setf-function)

        (setf (get symbol 'system::setf-function) new-setf-symbol))

       ((eq kind :setf-expander)

        (setf (get symbol 'system::setf-expander) new-setf-symbol))

       (t (error "invalid kind of setf-function ~S for ~S to be set to ~S"

                 kind symbol new-setf-symbol)))

     #+clozure

     (progn

       (gethash symbol ccl::%setf-function-names%) new-setf-symbol

       (gethash new-setf-symbol ccl::%setf-function-name-inverses%) symbol))

   #+(or clisp clozure)

   (defun create-setf-function-symbol (symbol)

     #+clisp (system::setf-symbol symbol)

     #+clozure (ccl::construct-setf-function-name symbol))

   (defun set-dummy-symbol (symbol reason other-symbol)

     (setf (get symbol 'dummy-symbol) (cons reason other-symbol)))

   (defun make-dummy-symbol (symbol)

     (let ((dummy (copy-symbol symbol)))

       (set-dummy-symbol dummy 'replacing symbol)

       (set-dummy-symbol symbol 'replaced-by dummy)

       dummy))

   (defun dummy-symbol (symbol)

     (get symbol 'dummy-symbol))

   (defun get-dummy-symbol (symbol)

     (let ((existing (dummy-symbol symbol)))

       (if existing (values (cdr existing) (car existing))

           (make-dummy-symbol symbol))))

   (defun nuke-symbol-in-package (symbol package-designator)

     (let ((package (find-package* package-designator))

           (name (symbol-name symbol)))

       (multiple-value-bind (sym stat) (find-symbol name package)

         (when (and (member stat '(:internal :external)) (eq symbol sym))

           (if (symbol-shadowing-p symbol package)

               (shadowing-import* (get-dummy-symbol symbol) package)

               (unintern* symbol package))))))

   (defun nuke-symbol (symbol &optional (packages (list-all-packages)))

     #+(or clisp clozure)

     (multiple-value-bind (setf-symbol kind)

         (get-setf-function-symbol symbol)

       (when kind (nuke-symbol setf-symbol)))

     (loop :for p :in packages :do (nuke-symbol-in-package symbol p)))

   (defun rehome-symbol (symbol package-designator)

     "Changes the home package of a symbol, also leaving it present in its old home if any"

     (let* ((name (symbol-name symbol))

            (package (find-package* package-designator))

            (old-package (symbol-package symbol))

            (old-status (and old-package (nth-value 1 (find-symbol name old-package))))

            (shadowing (and old-package (symbol-shadowing-p symbol old-package) (make-symbol name))))

       (multiple-value-bind (overwritten-symbol overwritten-symbol-status) (find-symbol name package)

         (unless (eq package old-package)

           (let ((overwritten-symbol-shadowing-p

                   (and overwritten-symbol-status

                        (symbol-shadowing-p overwritten-symbol package))))

             (note-package-fishiness

              :rehome-symbol name

              (when old-package (package-name old-package)) old-status (and shadowing t)

              (package-name package) overwritten-symbol-status overwritten-symbol-shadowing-p)

             (when old-package

               (if shadowing

                   (shadowing-import* shadowing old-package))

               (unintern* symbol old-package))

             (cond

               (overwritten-symbol-shadowing-p

                (shadowing-import* symbol package))

               (t

                (when overwritten-symbol-status

                  (unintern* overwritten-symbol package))

                (import* symbol package)))

             (if shadowing

                 (shadowing-import* symbol old-package)

                 (import* symbol old-package))

             #+(or clisp clozure)

             (multiple-value-bind (setf-symbol kind)

                 (get-setf-function-symbol symbol)

               (when kind

                 (let* ((setf-function (fdefinition setf-symbol))

                        (new-setf-symbol (create-setf-function-symbol symbol)))

                   (note-package-fishiness

                    :setf-function

                    name (package-name package)

                    (symbol-name setf-symbol) (symbol-package-name setf-symbol)

                    (symbol-name new-setf-symbol) (symbol-package-name new-setf-symbol))

                   (when (symbol-package setf-symbol)

                     (unintern* setf-symbol (symbol-package setf-symbol)))

                   (setf (fdefinition new-setf-symbol) setf-function)

                   (set-setf-function-symbol new-setf-symbol symbol kind))))

             #+(or clisp clozure)

             (multiple-value-bind (overwritten-setf foundp)

                 (get-setf-function-symbol overwritten-symbol)

               (when foundp

                 (unintern overwritten-setf)))

             (when (eq old-status :external)

               (export* symbol old-package))

             (when (eq overwritten-symbol-status :external)

               (export* symbol package))))

         (values overwritten-symbol overwritten-symbol-status))))

   (defun ensure-package-unused (package)

     (loop :for p :in (package-used-by-list package) :do

       (unuse-package package p)))

   (defun delete-package* (package &key nuke)

     (let ((p (find-package package)))

       (when p

         (when nuke (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s))))

         (ensure-package-unused p)

         (delete-package package))))

   (defun package-names (package)

     (cons (package-name package) (package-nicknames package)))

   (defun packages-from-names (names)

     (remove-duplicates (remove nil (mapcar #'find-package names)) :from-end t))

   (defun fresh-package-name (&key (prefix :%TO-BE-DELETED)

                                separator

                                (index (random most-positive-fixnum)))

     (loop :for i :from index

           :for n = (format nil "~A~@[~A~D~]" prefix (and (plusp i) (or separator "")) i)

             :thereis (and (not (find-package n)) n)))

   (defun rename-package-away (p &rest keys &key prefix &allow-other-keys)

     (let ((new-name

             (apply 'fresh-package-name

                    :prefix (or prefix (format nil "__~A__" (package-name p))) keys)))

       (record-fishy (list :rename-away (package-names p) new-name))

       (rename-package p new-name))))

 ;;; Communicable representation of symbol and package information

 (eval-when (:load-toplevel :compile-toplevel :execute)

   (defun package-definition-form (package-designator

                                   &key (nicknamesp t) (usep t)

                                     (shadowp t) (shadowing-import-p t)

                                     (exportp t) (importp t) internp (error t))

     (let* ((package (or (find-package* package-designator error)

                         (return-from package-definition-form nil)))

            (name (package-name package))

            (nicknames (package-nicknames package))

            (use (mapcar #'package-name (package-use-list package)))

            (shadow ())

            (shadowing-import (make-hash-table :test 'equal))

            (import (make-hash-table :test 'equal))

            (export ())

            (intern ()))

       (when package

         (loop :for sym :being :the :symbols :in package

               :for status = (nth-value 1 (find-symbol* sym package)) :do

                 (ecase status

                   ((nil :inherited))

                   ((:internal :external)

                    (let* ((name (symbol-name sym))

                           (external (eq status :external))

                           (home (symbol-package sym))

                           (home-name (package-name home))

                           (imported (not (eq home package)))

                           (shadowing (symbol-shadowing-p sym package)))

                      (cond

                        ((and shadowing imported)

                         (push name (gethash home-name shadowing-import)))

                        (shadowing

                         (push name shadow))

                        (imported

                         (push name (gethash home-name import))))

                      (cond

                        (external

                         (push name export))

                        (imported)

                        (t (push name intern)))))))

         (labels ((sort-names (names)

                    (sort (copy-list names) #'string<))

                  (table-keys (table)

                    (loop :for k :being :the :hash-keys :of table :collect k))

                  (when-relevant (key value)

                    (when value (list (cons key value))))

                  (import-options (key table)

                    (loop :for i :in (sort-names (table-keys table))

                          :collect `(,key ,i ,@(sort-names (gethash i table))))))

           `(defpackage ,name

              ,@(when-relevant :nicknames (and nicknamesp (sort-names nicknames)))

              (:use ,@(and usep (sort-names use)))