;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
;; ALL RIGHTS RESERVED.
;;
;; $Id: package.lisp,v 1.17 2004/02/20 07:23:42 yuji Exp $
;; 
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;; 
;;  * Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;;  * Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in
;;    the documentation and/or other materials provided with the
;;    distribution.
;; 
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(defstruct (package
             (:constructor %make-package)
             (:print-object print-package)
             (:predicate packagep))
  ""
  (%name nil :type (or string null))
  (%nicknames nil :type list)
  (%shadowing-symbols nil :type list)
  (%use-list nil :type list)
  (%used-by-list nil :type list)
  (internal-symbols (make-hash-table :test 'equal) :type hash-table)
  (external-symbols (make-hash-table :test 'equal) :type hash-table))

(defun print-package (package stream)
  (format stream "#<~A package (sumire)>" (package-%name package)))

(defvar *keyword-package* (%make-package :%name "KEYWORD" :%nicknames '())
  "")

(defvar *cl-package* (%make-package :%name "COMMON-LISP" :%nicknames (list "CL"))
  "")

(defvar *cl-user-package*
  (%make-package :%name "COMMON-LISP-USER" :%nicknames (list "CL-USER")
                 :%use-list (list *cl-package*))
  "")

(setf (package-%used-by-list *cl-package*) (list *cl-user-package*))

(defvar *package* *cl-user-package*
  "The current package.")

(defvar *all-packages* (list *cl-user-package* *cl-package* *keyword-package*)
  "")

(define-condition package-error (error)
  ((package :type package-designator
            :reader package-error-package :initarg :package)))

(defun %package (designator)
  (or (find-package designator)
      (and (typep designator 'package-designator)
           (error 'non-existent-package-name-error :package designator))
      (error 'type-error :datum designator :expected-type 'package-designator)))

(defun %package-list (designator)
  (mapcar #'%package (%list designator)))

(defmacro in-package (name)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
    (setq *package* (%package ',name))))

(defun list-all-packages ()
  (copy-list *all-packages*))

(defun find-registered-package (name)
  (block this
    (dolist (package *all-packages* nil)
      (when (string= name (package-%name package))
        (return-from this package))
      (dolist (nickname (package-%nicknames package))
        (when (string= name nickname)
          (return-from this package))))))

(defun find-package (name)
  (if (packagep name)
      name
      (find-registered-package (string name))))

(defun unuse-package (packages-to-unuse &optional (package *package*))
  (let ((packages-to-unuse (%package-list packages-to-unuse))
        (package (%package package)))
    (dolist (unuse packages-to-unuse t)
      (setf (package-%use-list package)
            (remove unuse (package-%use-list package)))
      (setf (package-%used-by-list unuse)
            (remove package (package-%used-by-list unuse))))))

(defun package-name (package)
  (copy-seq (package-%name (%package package))))

(defun package-nicknames (package)
  (copy-list (package-%nicknames (%package package))))

(defun package-shadowing-symbols (package)
  (copy-list (package-%shadowing-symbols (%package package))))

(defun package-use-list (package)
  (copy-list (package-%use-list (%package package))))

(defun package-used-by-list (package)
  (copy-list (package-%used-by-list (%package package))))

(define-condition package-name-error (simple-error)
  ((name :type string :reader package-name-error-name :initarg :name))
  (:report  (lambda (condition stream)
              (format stream "A package named ~S already exists."
                      (package-name-error-name condition)))))

(defun rename-package (package new-name &optional new-nicknames)
  (let* ((package (%package package))
         (new-name (string new-name))
         (new-nicknames (%string-list new-nicknames)))
    (dolist (name (cons new-name new-nicknames))
      (let ((found (find-package name)))
        (when (and found (not (eq package found)))
          (error 'package-name-error :name name))))
    (setf (package-%name package) new-name
          (package-%nicknames package) new-nicknames)
    package))

(defun find-symbol (name &optional (package *package*))
  (let ((name (string name))
        (package (%package package)))
    (multiple-value-bind (symbol registered-p)
        (gethash name (package-external-symbols package))
      (if registered-p
          (values symbol :external)
          (multiple-value-bind (symbol registered-p)
              (gethash name (package-internal-symbols package))
            (if registered-p
                (values symbol :internal)
                (dolist (used (package-use-list package) (values nil nil))
                  (multiple-value-bind (symbol registered-p)
                      (gethash name (package-external-symbols used))
                    (when registered-p
                      (return (values symbol :inherited)))))))))))

(defun find-all-symbols (name)
  (let ((name (string name))
        (all-symbols nil))
    (dolist (package (list-all-packages) (remove-duplicates all-symbols))
      (multiple-value-bind (symbol status) (find-symbol name package)
        (case status ((:internal :external) (push symbol all-symbols)))))))

(defun accessible-symbol-p (symbol package)
  (multiple-value-bind (symbol-found status)
      (find-symbol (symbol-name symbol) package)
    (and (eq symbol symbol-found) status)))

(defun present-symbol-p (symbol package)
  (multiple-value-bind (symbol-found status)
      (find-symbol (symbol-name symbol) package)
    (and (eq symbol-found symbol) (find status '(:internal :external)))))

(define-condition unintern-would-reveal-name-conflict-error (package-error)
  ((symbol :type symbol :reader unintern-error-symbol :initarg :symbol)))

(defun unintern (symbol &optional (package *package*))
  (flet ((conflicting-inherited-symbols (name package)
           (let ((symbols nil))
             (dolist (used-package (package-use-list package))
               (multiple-value-bind (symbol-found foundp)
                   (gethash name (package-external-symbols used-package))
                 (when foundp
                   (pushnew symbol-found symbols))))
             (if (cdr symbols) symbols nil))))
    (let* ((name (symbol-name symbol))
           (package (%package package))
           (present-p (present-symbol-p symbol package)))
      (when present-p
        (when (member symbol (package-shadowing-symbols package))
          (when (conflicting-inherited-symbols name package)
            (error 'unintern-would-reveal-name-conflict-error
                   :symbol symbol :package package))
          (setf (package-%shadowing-symbols package)
                (remove symbol (package-%shadowing-symbols package))))
        (remhash name (ecase present-p
                        (:internal (package-internal-symbols package))
                        (:external (package-external-symbols package))))
        (when (eq (symbol-package symbol) package)
          (setf (symbol-package symbol) nil))
        t))))


(defun shadowing-import (symbol-list &optional (package *package*))
  (let ((symbol-list (%symbol-list symbol-list))
        (package (%package package)))
    (dolist (symbol symbol-list t)
      (let ((name (symbol-name symbol)))
        (multiple-value-bind (symbol-found status) (find-symbol name package)
          (let ((present-p (member status '(:internal :external))))
            (when (and present-p (not (eq symbol symbol-found)))
              (unintern symbol-found package))
            (unless (and present-p (eq symbol symbol-found))
              (setf (gethash name (package-internal-symbols package)) symbol))
            (pushnew symbol (package-%shadowing-symbols package))))))))

(define-condition import-would-cause-shadowing-error (package-error)
  ((symbol :type symbol :reader import-error-symbol :initarg :symbol)))

(defun import (symbol-list &optional (package *package*))
  (let ((symbol-list (%symbol-list symbol-list))
        (package (%package package)))
    (dolist (symbol symbol-list t)
      (let ((name (symbol-name symbol)))
        (multiple-value-bind (symbol-found status) (find-symbol name package)
          (cond
            ((and status (not (eq symbol symbol-found)))
             (cerror "Import this symbol with shadowing-import."
                     'import-would-cause-shadowing-error
                     :package package :symbol symbol)
             (shadowing-import symbol package))
            ((and (member status '(:internal :external))
                  (eq symbol symbol-found))
             ;; The spec says `If the symbol is already present
             ;; in the importing package, import has no effect.'
             )
            (t
             (setf (gethash name (package-internal-symbols package)) symbol)
             (when (null (symbol-package symbol))
               (setf (symbol-package symbol) package)))))))))

(define-condition use-package-would-cause-name-conflict-error (package-error)
  ((names :type list :reader use-package-error-names :initarg :names)
   (package-to-use :type package :reader use-package-error-package-to-use
                   :initarg :package-to-use)))

(defun check-use-package-name-conflict (using-package package-to-use)
  (let* ((conflicting-names nil)
         (shadows (package-shadowing-symbols using-package))
         (user-tables (cons (package-internal-symbols using-package)
                            (cons (package-external-symbols using-package)
                                  (mapcar #'package-external-symbols
                                          (package-use-list using-package)))))
         (fat-user
          (> (reduce #'+ user-tables :key #'hash-table-count)
             (hash-table-count (package-external-symbols package-to-use))))
         (tables (if fat-user
                     (list (package-external-symbols package-to-use))
                     user-tables))
         (package (if fat-user using-package package-to-use)))
    (mapc #'(lambda (table)
              (maphash
               #'(lambda (name symbol)
                   (multiple-value-bind (symbol-found status)
                       (find-symbol name package)
                     (when (and status
                                (not (eq symbol symbol-found))
                                (not (member name shadows :test #'string=)))
                       (push name conflicting-names))))
               table))
          tables)
    (when conflicting-names
      (restart-case (error 'use-package-would-cause-name-conflict-error
                           :names conflicting-names :package package
                           :package-to-use package-to-use)
        (continue ()
          :report "Shadowing-import the conflicting symbols."
          (shadowing-import (mapcar #'(lambda (name)
                                        (find-symbol name package-to-use))
                                    conflicting-names)
                            package))))))

(defun use-package (package-to-use-list &optional (package *package*))
  (let ((package-to-use-list (%package-list package-to-use-list))
        (package (%package package)))
    (dolist (package-to-use package-to-use-list t)
      (cond
        ((member package-to-use (package-use-list package)))
        ((eq package-to-use *keyword-package*)
         (warn "The keyword package cannot be used by other packages."))
        ((eq package-to-use package)
         (warn "A package cannot use-package itself."))
        (t (check-use-package-name-conflict package package-to-use)
           (push package-to-use (package-%use-list package))
           (push package (package-%used-by-list package-to-use)))))))

(defun make-package (name &key nicknames use)
  (let ((package
         (%make-package
          :%name (cond
                   ((not (find-package name)) (string name))
                   (t (cerror "Return the existing package."
                              'package-name-error :name name)
                      (return-from make-package (find-package name))))
          :%nicknames (mapcan
                       #'(lambda (nickname)
                           (cond
                             ((string= nickname name) nil)
                             ((find-package nickname)
                              (cerror "Don't use this nickname."
                                      'package-name-error :name nickname))
                             (t (list (string nickname)))))
                       nicknames))))
    (use-package use package)
    (pushnew package *all-packages*)
    package))

(define-condition non-accessible-symbol-error (package-error)
  ((symbol :type symbol
           :reader non-accessible-symbol-error-symbol :initarg :symbol)))
(define-condition export-would-cause-conflict-in-user-package-error
    (package-error)
  ((symbol :type symbol :reader export-error-symbol :initarg :symbol)
   (user-package :type package
                 :reader export-error-user-package :initarg :user-package)))

(defun export (symbol-list &optional (package *package*))
  (let ((symbol-list (%symbol-list symbol-list))
        (package (%package package))
        status)
    (dolist (symbol symbol-list t)
      (loop until (setq status (accessible-symbol-p symbol package))
            do
            (cerror "Import this symbol." 'non-accessible-symbol-error
                    :package package :symbol symbol)
            (import (list symbol) package))
      (unless (eq status :external)
        (let ((name (symbol-name symbol)))
          (dolist (user (package-used-by-list package))
            (loop
             (multiple-value-bind (symbol-found status) (find-symbol name user)
               (when (or (null status) (eq symbol symbol-found))
                 (return))
               (cerror "Shadowing-import the symbol in the user package."
                       'export-would-cause-conflict-in-user-package-error
                       :package package :user-package user :symbol symbol)
               (shadowing-import (list symbol) user))))
          (when (eq status :inherited)
            (import (list symbol) package))
          (remhash name (package-internal-symbols package))
          (setf (gethash name (package-external-symbols package)) symbol))))))
    
(defun unexport (symbol-list &optional (package *package*))
  (let ((symbol-list (%symbol-list symbol-list))
        (package (%package package))
        status)
    (dolist (symbol symbol-list t)
      (unless (setq status (accessible-symbol-p symbol package))
        (cerror "Import this symbol." 'non-accessible-symbol-error
                :package package :symbol symbol))
      (when (eq status :external)
        (remhash (symbol-name symbol) (package-external-symbols package))
        (setf (gethash (symbol-name symbol) (package-internal-symbols package))
              symbol)))))

(defun intern (name &optional (package *package*))
  (let ((name (string name))
        (package (%package package)))
    (multiple-value-bind (symbol status) (find-symbol name package)
      (if status
          (values symbol status)
          (let ((symbol (make-symbol name)))
            (import (list symbol) package)
            (when (eq package *keyword-package*)
              (export (list symbol) package)
              (setf (symbol-value symbol) symbol))
            (values symbol nil))))))

(defun shadow (symbol-names &optional (package *package*))
  (let ((symbol-names (%string-list symbol-names))
        (package (%package package)))
    (dolist (name symbol-names t)
      (multiple-value-bind (symbol status) (find-symbol name package)
        (when (or (not status) (eq status :inherited))
          (setq symbol (make-symbol name))
          (setf (symbol-package symbol) package)
          (setf (gethash name (package-internal-symbols package)) symbol))
        (pushnew symbol (package-%shadowing-symbols package))))))

(defun hash-table-values (table)
  (let ((values nil))
    (with-hash-table-iterator (get table)
      (loop (multiple-value-bind (more k v) (get)
              (declare (ignore k))
              (unless more (return))
              (push v values))))
    values))
  
(defun package-symbol-tables (package type)
  (ecase type
    (:internal (list (package-internal-symbols package)))
    (:external (list (package-external-symbols package)))
    (:inherited (mapcar #'package-external-symbols
                        (package-use-list package)))))

(define-condition package-symbol-types-error (program-error)
  ((types :reader symbol-types-error-types :initarg :types)))

(defun shadowed-name-p (name package)
  (member name (package-shadowing-symbols package) :test #'string=))

(defun package-iterator (package &rest symbol-types)
  (unless symbol-types (error 'package-symbol-types-error :types symbol-types))
  (unless package (return-from package-iterator (constantly nil)))
  (let* ((package-list (%package-list package))
         (package (pop package-list))
         (type (first symbol-types))
         (type-list (rest symbol-types))
         (iterator (hash-table-iterator (package-symbol-tables package type))))
    #'(lambda ()
        (loop
         (multiple-value-bind (more name symbol) (funcall iterator)
           (cond
             (more
              (unless (and (eq type :inherited) (shadowed-name-p name package))
                (return (values more symbol type package))))
             (t
              (cond
                (type-list (setq type (pop type-list)))
                (package-list (setq type      (first symbol-types)
                                    type-list (rest symbol-types)
                                    package (pop package-list)))
                (t (return nil)))
              (setq iterator
                    (hash-table-iterator (package-symbol-tables package
                                                                type))))))))))

(defmacro with-package-iterator ((name package-list-form &rest symbol-types)
                                 &body body)
  (unless symbol-types (error 'package-symbol-types-error :types symbol-types))
  (let ((iterator (gensym)))
    `(let ((,iterator (package-iterator ,package-list-form ,@symbol-types)))
      (macrolet ((,name () '(funcall ,iterator)))
        ,@body))))

(defmacro do-package-symbols ((var package result-form &rest type-list)
                              &body body)
  (let ((get (gensym))
        (more (gensym))
        (type (gensym))
        (pkg (gensym)))
    (multiple-value-bind (declarations forms)
        (split-into-declarations-and-forms body)
      `(with-package-iterator (,get ,package ,@type-list)
        (loop
         (multiple-value-bind (,more ,var ,type ,pkg) (,get)
           (declare (ignore ,type ,pkg))
           ,@declarations
           (unless ,more (return ,result-form))
           (tagbody
              ,@forms)))))))

(defmacro do-symbols ((var &optional (package-form '*package*)
                           result-form)
                      &body body)
  (let ((package (gensym)))
    `(let ((,package (%package ,package-form)))
      (do-package-symbols (,var ,package ,result-form
                           :external :internal :inherited)
        ,@body))))

(defmacro do-external-symbols ((var &optional (package-form '*package*)
                                    result-form)
                               &body body)
  (let ((package (gensym)))
    `(let ((,package (%package ,package-form)))
      (do-package-symbols (,var ,package ,result-form :external)
        ,@body))))

(defmacro do-all-symbols ((var &optional result-form) &body body)
  (let ((package (gensym))
        (body-function (gensym)))
    (multiple-value-bind (declarations forms)
        (split-into-declarations-and-forms body)
      `(block nil
        (flet ((,body-function (,var)
                 (declare (ignorable ,var))
                 ,@declarations
                 (tagbody ,@forms)))
          (dolist (,package (list-all-packages) (let ((,var nil))
                                                  (declare (ignorable ,var))
                                                  ,@declarations
                                                  ,result-form))
            (do-symbols (,var ,package nil)
              (,body-function ,var))))))))

(define-condition deleting-package-used-by-others-error (package-error)
  ())

(defun delete-package (package)
  (let ((package (or (find-package package)
                     (return-from delete-package
                       (cerror "Return NIL." 'non-existent-package-name-error
                               :package package)))))
    (when (package-name package)
      (when (package-used-by-list package)
           (cerror "Remove dependency in other packages."
                   'deleting-package-used-by-others-error :package package)
           (dolist (user (package-used-by-list package))
             (unuse-package package user)))
      (unuse-package (package-use-list package) package)
      (do-symbols (symbol package)
        (unintern symbol package))
      (setf (package-%name package) nil)
      (setq *all-packages* (remove package *all-packages*))
      t)))

(define-condition unsupported-defpackage-option-error (program-error)
  ((option :reader unsupported-defpackage-option-error-option :initarg :option)))

(define-condition non-accessible-symbol-name-error (package-error)
  ((name :type string
         :reader non-accessible-symbol-name-error-name :initarg :name)))

(defun %accessible-symbols (name-list package)
  (mapcar #'(lambda (name)
              (loop
               (multiple-value-bind (symbol status)
                   (find-symbol name package)
                 (when status
                   (return symbol))
                 (cerror "Intern this symbol." 'non-accessible-symbol-name-error
                         :package package :name name)
                 (intern (string name) package))))
          name-list))

(defun check-disjoint(&rest args)
  ;; An arg is (:key . set)
  (do ((list args (cdr list)))
      ((endp list))
    (loop
      with x = (car list)
      for y in (rest list)
      for z = (remove-duplicates (intersection (cdr x)(cdr y) :test #'string=))
      when z do (error 'program-error
                       :format-control "Parameters ~S and ~S must be disjoint ~
                                        but have common elements ~%   ~S"
                       :format-arguments (list (car x)(car y) z)))))

(defmacro defpackage (package-name &rest options)
  (let ((package-name (string package-name))
        forms nicknames shadow shadowing-import-from use import-from intern
        export documentation size)
    (loop
     for (key . values) in options
     do
     (case key
       (:nicknames     (setq nicknames (append nicknames values)))
       (:documentation (setq documentation (first values)))
       (:shadow        (setq shadow (append shadow values)))
       (:shadowing-import-from (push values shadowing-import-from))
       (:use           (setq use (append use values)))
       (:import-from   (push values import-from))
       (:intern        (setq intern (append intern values)))
       (:export        (setq export (append export values)))
       (:size          (setq size (first values)))
       (t (error 'unsupported-defpackage-option :option (cons key values)))))
    (check-disjoint `(:intern ,@intern)
                    `(:import-from ,@(apply #'append (mapcar #'rest
                                                             import-from)))
                    `(:shadow ,@shadow)
                    `(:shadowing-import-from
                      ,@(apply #'append (mapcar #'rest shadowing-import-from))))
    (check-disjoint `(:intern ,@intern) `(:export  ,@export))
    
    (push `(let ((package (find-package ,package-name)))
            (if package
                (rename-package package
                                ,package-name (union ',(%string-list nicknames)
                                                     (package-nicknames package)
                                                     :test #'string=))
                (make-package ,package-name :nicknames ',nicknames :use nil)))
          forms)
    (when documentation
      (push `(setf (documentation ,package-name 'package) ,documentation) forms))
    (when shadow (push `(shadow ',(%string-list shadow) ,package-name) forms))
    (when shadowing-import-from
      (loop for (from . names) in shadowing-import-from
            do (push `(let ((names ',(%string-list names)))
                       (shadowing-import (%accessible-symbols names ',from)
                        ,package-name))
                     forms)))
    (when use (push `(use-package ',use ,package-name) forms))
    (when import-from
      (loop for (from . names) in import-from
            do (push `(let ((names ',(%string-list names)))
                       (import (%accessible-symbols names ',from) ,package-name))
                     forms)))
    (when intern
      (dolist (symbol intern)
        (push `(intern ',symbol ,package-name) forms)))
    (when export
      (push `(export
              (mapcar #'(lambda (name) (intern name ,package-name)) ',export)
              ,package-name)
            forms))
    (push `(find-package ,package-name) forms)
    `(eval-when (:load-toplevel :compile-toplevel :execute)
      ,@(nreverse forms))))

;;;
(defun clone-package-system ()
  (let ((src-list (mapcar #'cl:find-package
                          '("CL" "CL-USER" "KEYWORD" "TESTBED"))))
    (dolist (src src-list)
      (format t "Cloning the package ~S~%" src)
      (let* ((name (cl:package-name src))
             (nicknames (cl:package-nicknames src))
             (dest (or (tb::find-package name)
                       (tb::make-package name :nicknames nicknames))))
        (cl:with-package-iterator (get src :internal :external)
          (loop
           (multiple-value-bind (more symbol status package) (get)
             (declare (ignore status package))
             (unless more (return))
             ;;(format t "shadowing symbols = ~S~%" (cl:package-shadowing-symbols src))
             (if (member symbol (cl:package-shadowing-symbols src))
                 (shadowing-import (list symbol) dest)
                 (progn
                   ;;(format t "calling import~%")
                   (import (list symbol) dest)
                   ;;(format t "called import~%"
                   )))))
        (cl:do-external-symbols (symbol src)
          (export (list symbol) dest))))
    (setq *package* (find-package (cl:package-name cl:*package*)))))