;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               package.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;    This package is a CLOS wrapper over the Common Lisp package system.
;;;;
;;;;    This file contains the generic functions and methods wrapping
;;;;    over the CL package functions.
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;;    2013-11-30 <PJB> cl:package wrapper for LispOS.
;;;;BUGS
;;;;
;;;;    make-load-form for packages should probably return two forms, since
;;;;    packages can have circular dependencies.
;;;;
;;;;    Are missing some standard restarts to correct
;;;;    conflicts. (choosing one or the other symbol, doing the same
;;;;    for all conflicts, etc).
;;;;
;;;;LEGAL
;;;;    AGPL3
;;;;
;;;;    Copyright Pascal J. Bourguignon 2013 - 2013
;;;;
;;;;    This program is free software: you can redistribute it and/or modify
;;;;    it under the terms of the GNU Affero General Public License as published by
;;;;    the Free Software Foundation, either version 3 of the License, or
;;;;    (at your option) any later version.
;;;;
;;;;    This program is distributed in the hope that it will be useful,
;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;;    GNU Affero General Public License for more details.
;;;;
;;;;    You should have received a copy of the GNU Affero General Public License
;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************



(cl:in-package "COM.INFORMATIMAGO.COMMON-LISP.LISPOS.PACKAGE")


;;; Pack management

(defgeneric accessiblep (sym pack))
(defgeneric externalp (sym pack))
(defgeneric shadowingp (sym pack))
(defgeneric presentp (sym pack))

(defgeneric check-import-conflict (sym pack))
(defgeneric check-inherit-conflict (used-pack using-pack))
(defgeneric check-export-conflict (sym pack))
(defgeneric check-unintern-conflict (sym-name pack))

;;; Clone of the CL symbol/package interface

(defgeneric symbol-package (sym)
  ;; We need this wrapper to return our PACKAGE instead of CL:PACKAGE
  (:documentation "
RETURN: the home package of the symbol.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_symb_3.htm>
"))

(defgeneric make-package (pack-name &key nicknames use)
  (:documentation "
DO:     Make a new package.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_mk_pkg.htm>
"))

(defgeneric find-package (pack-name)
  (:documentation "
RETURN: The package designated by PACK-NAME, or NIL if none.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_find_p.htm>
"))

(defgeneric delete-package (pack-name)
  (:documentation "
DO:     Delete the package.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_del_pk.htm>
"))

(defgeneric find-symbol (sym-name &optional pack)
  (:documentation "
RETURN: the symbol named SYM-NAME in the package PACK, if found and a status keyword.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_find_s.htm>
"))

(defgeneric import (symbols &optional pack)
  (:documentation "
DO:     Import the symbols into the package.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_import.htm>
"))

(defgeneric intern (sym-name &optional pack)
  (:documentation "
DO:     Intern the symbol name in the package.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_intern.htm>
"))

(defgeneric shadow (symbol-names &optional pack)
  (:documentation "
DO:     Shadow the designated symbols.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_shadow.htm>
"))

(defgeneric shadowing-import (symbols &optional pack)
  (:documentation "
DO:     Shadow and import the designated symbols.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_shdw_i.htm>
"))

(defgeneric export (sym &optional pack)
  (:documentation "
DO:     Export the designated symbols from the package.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_export.htm>
"))

(defgeneric unexport (sym &optional pack)
  (:documentation "
DO:     Unexport the designated symbols from the package.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_unexpo.htm>
"))

(defgeneric unintern (sym &optional pack)
  (:documentation "
DO:     Unintern the designated symbols from the package.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_uninte.htm>
"))

(defgeneric use-package (pack &optional using-pack)
  (:documentation "
DO:     Make the USING-PACK use the package PACK.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_use_pk.htm>
"))

(defgeneric unuse-package (pack &optional using-pack)
  (:documentation "
DO:     Make the USING-PACK unuse the package PACK
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_unuse_.htm>
"))

(defgeneric package-name (pack)
  (:documentation "
RETURN: The package name.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_pkg_na.htm>
"))

(defgeneric package-nicknames (package)
  (:documentation "RETURN: The list of nicknames of the package."))

(defgeneric package-use-list (pack)
  (:documentation "
RETURN: The list of packages used by PACK.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_pkg_us.htm>
"))

(defgeneric package-used-by-list (pack)
  (:documentation "
RETURN: The list of packages that use PACK.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_pkg__1.htm>
"))

(defgeneric package-shadowing-symbols (pack)
  (:documentation "
RETURN: The list of shadowing symbols of the package.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_pkg_sh.htm>
"))

(defgeneric find-all-symbols (name)
  (:documentation "
RETURN: The list of all symbols named NAME in all packages.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_find_a.htm>
"))

(defgeneric rename-package (package new-name &optional new-nicknames)
  (:documentation "
DO:     Rename the package giving it the NEW-NAME and NEW-NICKNAMES.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_rn_pkg.htm>
"))


;; an additionnal function:

(defgeneric package-documentation (package)
  (:documentation "RETURN: The documentation string of the package."))




;;; Variables

(defparameter *keyword-package*           nil)
(defparameter *common-lisp-package*       nil)
(defparameter *common-lisp-user-package*  nil)
(defvar *package* nil
  "
The current package.

URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/v_pkg.htm>
")



;;; Conditions

(define-condition simple-error-mixin (condition)
  ((format-control   :initarg :format-control   :reader format-control
                     :initform "Simple error.")
   (format-arguments :initarg :format-arguments :reader format-arguments
                     :initform '()))
  (:report (lambda (condition stream)
             (format stream "~?"
                     (format-control condition)
                     (format-arguments condition)))))

(define-condition simple-program-error (simple-error-mixin program-error)
  ())

(define-condition simple-type-error (simple-error-mixin type-error)
  ())


(defgeneric package-error-package (package-error)
  (:documentation "
RETURN: The package in error.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_pkg_er.htm>
"))

(define-condition package-error (error)
  ((package :initarg :package :reader package-error-package))
  (:report (lambda (condition stream)
             (format stream "Package error with ~A" (package-error-package condition))))
(:documentation "
The type package-error consists of error conditions related to operations on packages.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/e_pkg_er.htm>
"))


(define-condition simple-package-error (package-error simple-error-mixin)
  ())

(define-condition package-exists-error (simple-package-error)
  ()
  (:documentation "The error condition signaling that a package with the same name already exists."))

(define-condition package-does-not-exist-error (simple-package-error)
  ()
  (:documentation "The error condition signaling that no package with that name exists."))

(defgeneric symbol-conflict-existing-symbol (error)
  (:documentation "RETURN: The existing symbol in conflict."))

(defgeneric symbol-conflict-imported-symbol (error)
  (:documentation "RETURN: The imported symbol in conflict."))

(define-condition symbol-conflict-error (simple-package-error)
  ((existing-symbol :initarg :existing-symbol :reader symbol-conflict-existing-symbol)
   (imported-symbol :initarg :imported-symbol :reader symbol-conflict-imported-symbol))
  (:report (lambda (condition stream)
             (format stream "The would-be imported symbol ~S conflicts with the existing symbol ~S in the package ~S"
                     (symbol-conflict-imported-symbol condition)
                     (symbol-conflict-existing-symbol condition)
                     (package-name (package-error-package condition)))))
(:documentation "The error condition signaling a symbol conflict."))

(define-condition symbol-does-not-exist-error (simple-package-error)
  ((symbol-name :initarg :symbol-name :reader symbol-does-not-exist-symbol-name))
  (:report (lambda (condition stream)
             (format stream "There exists no symbol named ~S in the package ~S"
                     (symbol-does-not-exist-symbol-name condition)
                     (package-name (package-error-package condition))))))

(define-condition symbol-inaccessible-error (simple-package-error)
  ((symbol :initarg :symbol :reader symbol-inaccessible-symbol))
  (:report (lambda (condition stream)
             (format stream "~S is not accessible in ~S"
                     (symbol-inaccessible-symbol condition)
                     (package-name (package-error-package condition))))))



(defun query-string ()
  (format *query-io* "Enter a new string: ")
  (finish-output *query-io*)
  (list (read-line *query-io*)))

(defun query-symbol ()
  (list (loop
          :for sym = (progn
                       (format *query-io* "Enter a new symbol (current package is ~A): "
                               (package-name *package*))
                       (finish-output *query-io*)
                       (read *query-io*))
          :until (symbolp sym)
          :finally (return sym))))

(defun query-package-name ()
  (format *query-io* "Enter a package name (string or symbol): ")
  (finish-output *query-io*)
  (list (read *query-io*)))

(defun query-package-nickname ()
  (format *query-io* "Enter a package nickname (string or symbol): ")
  (finish-output *query-io*)
  (list (read *query-io*)))




;;; Implementation of packs & CL clone interface

(defparameter *packages* (make-hash-table :test 'equal))


(defun list-all-packages ()
  "
RETURN: A fresh list of all registered packages.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_list_a.htm>
"
  (let ((packages '()))
    (maphash (lambda (k v) (declare (ignore k)) (pushnew v packages)) *packages*)
    packages))

(defclass package ()
  ())


(defclass cl-package (package)
  ())


(defclass lispos-package (package)
  ((name
    :initarg :name
    :reader package-name
    :writer (setf name))
   (external-table
    :initarg :external-table
    :reader external-table)
   (present-table
    :initarg :present-table
    :reader present-table)
   (shadowing-table
    :initarg :shadowing-table
    :reader shadowing-table)
   (used-packs
    :initarg :used-packs
    :reader package-use-list
    :writer (setf used-packs))
   (used-by-packs
    :initarg :used-by-packs
    :reader package-used-by-list
    :writer (setf used-by-packs))
   (nicknames
    :initarg :nicknames
    :reader package-nicknames
    :writer (setf nicknames))
   (documentation
    :initarg :documentation
    :initform nil
    :accessor package-documentation))
  (:default-initargs
   :name (error "A package name is required")
    :external-table (make-sym-table)
    :present-table (make-sym-table)
    :shadowing-table (make-sym-table)
    :used-packs nil
    :used-by-packs nil)
  (:documentation "
The package class.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/t_pkg.htm>
"))

(defmacro define-normalize-package-methods (name &key (if-package-does-not-exist :replace) (type-error nil))
  `(progn
     ,@ (when type-error
          `((defmethod ,name ((name t))  (error 'simple-type-error
                                                :datum name
                                                :expected-type 'package-designator
                                                :format-control "~S called with a non ~S: ~S"
                                                :format-arguments (list ',name 'package-designator name)))))
        (defmethod ,name ((name string))    (,name (normalize-package-designator name :if-package-does-not-exist ,if-package-does-not-exist)))
        (defmethod ,name ((name character)) (,name (normalize-package-designator name :if-package-does-not-exist ,if-package-does-not-exist)))
        (defmethod ,name ((name cl:symbol)) (,name (normalize-package-designator name :if-package-does-not-exist ,if-package-does-not-exist)))
        (defmethod ,name ((name symbol))    (,name (normalize-package-designator (symbol-name name) :if-package-does-not-exist ,if-package-does-not-exist)))))

(define-normalize-package-methods package-name            :type-error t)
(define-normalize-package-methods package-use-list        :type-error t)
(define-normalize-package-methods package-used-by-list    :type-error t)
(define-normalize-package-methods package-nicknames       :type-error t)
(define-normalize-package-methods package-shadowing-symbols)



(defgeneric packagep (package)
  (:method ((object t)) nil)
  (:method ((package package)) t)
  (:documentation "
RETURN: Whether the object is a package.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_pkgp.htm>
"))


(defmethod print-object ((pack package) stream)
  (if *print-readably*
      (error 'print-not-readable :object pack)
      (format stream "#<~S ~S>" 'package (package-name pack)))
  pack)

(defmethod package-shadowing-symbols (pack)
  (tmembers (shadowing-table pack)))


(defmethod accessiblep (sym pack)
  (let ((existing-sym (find-symbol (symbol-name sym) pack)))
    (eq existing-sym sym)))

(defmethod externalp (sym pack)
  (tmember sym (external-table pack)))

(defmethod shadowingp (sym pack)
  (tmember sym (shadowing-table pack)))

(defmethod presentp (sym pack)
  (tmember sym (present-table pack)))








(defun ensure-list (object)
  (if (listp object)
      object
      (list object)))

(deftype string-designator ()
  '(or string character symbol cl:symbol))


(defun normalize-string-designator (object &key (if-not-a-string-designator :error))
  (check-type if-not-a-string-designator (member nil :error :ignore :replace :ignore-or-replace))
  (typecase object
    (string     object)
    (character  (string object))
    (cl:symbol  (string object))
    (symbol     (symbol-name object))
    (otherwise
     (case if-not-a-string-designator
       ((:error) (error 'type-error
                        :datum object
                        :expected-type 'string-designator))
       ((nil)    nil)
       ((:ignore :replace :ignore-or-replace)
        (restart-case (error 'type-error
                             :datum object
                             :expected-type 'string-designator)
          (ignore ()
            :test (lambda (condition)
                    (declare (ignore condition))
                    (member if-not-a-string-designator '(:ignore :ignore-or-replace)))
            :report "Ignore it."
            nil)
          (read-a-new-string-designator (new-string)
            :test (lambda (condition)
                    (declare (ignore condition))
                    (member if-not-a-string-designator '(:replace :ignore-or-replace)))
            :interactive query-string
            :report "Enter a string"
            (normalize-string-designator
             new-string
             :if-not-a-string-designator if-not-a-string-designator))))))))



(defun normalize-weak-designator-of-list-of-string-designator (object)
  (mapcan (lambda (nickname)
            (ensure-list (normalize-string-designator
                          nickname
                          :if-not-a-string-designator :ignore-or-replace)))
          (ensure-list object)))



(deftype package-designator ()
  '(or package string-designator))


(defun normalize-package-designator (object &key
                                            (if-package-does-not-exist :string)
                                            (if-package-exists :package)
                                            (if-not-a-package-designator :error))
  "
Normalize the given PACKAGE-DESIGNATOR.  Objects of type
PACKAGE-DESIGNATOR are either PACKAGE or objects of type
STRING-DESIGNATOR.

RETURN: either NIL, a STRING designating a non-existent package, or an
        existing PACKAGE.


IF-NOT-A-PACKAGE-DESIGNATOR The default is :ERROR.

    NIL                     If the OBJECT is not a PACKAGE-DESIGNATOR
                            then return NIL.

    :ERROR                  If the OBJECT is not a PACKAGE-DESIGNATOR
                            then signal a TYPE-ERROR.

    :IGNORE                 If the OBJECT is not a PACKAGE-DESIGNATOR
                            then signal a TYPE-ERROR, with an IGNORE
                            restart that when chosen returns NIL.

    :REPLACE                If the OBJECT is not a PACKAGE-DESIGNATOR
                            then signal a TYPE-ERROR, with a replace
                            restart that when chosen let the user
                            input another PACKAGE-DESIGNATOR.

    :IGNORE-OR-REPLACE      If the OBJECT is not a PACKAGE-DESIGNATOR
                            then signal a TYPE-ERROR, with the two
                            previous restarts.

If the object is a PACKAGE-DESIGNATOR, then the results depends on the
following parameters and whether the designated package exists or not.


IF-PACKAGE-DOES-NOT-EXIST   The default is :STRING

    NIL                     If the OBJECT designates a PACKAGE that
                            doesn't exist then return NIL.

    :STRING                 If the OBJECT designates a PACKAGE that
                            doesn't exist then (it would be a
                            STRING-DESIGNATOR) return the designated
                            STRING.

    :ERROR                  If the OBJECT designates a PACKAGE that
                            doesn't exist then signal a
                            PACKAGE-DOES-NOT-EXIST-ERROR.

    :IGNORE                 If the OBJECT designates a PACKAGE that
                            doesn't exist then signal a
                            PACKAGE-DOES-NOT-EXIST-ERROR with an
                            IGNORE restart that when chosen returns
                            NIL.

    :REPLACE                If the OBJECT designates a PACKAGE that
                            doesn't exist then signal a
                            PACKAGE-DOES-NOT-EXIST-ERROR with a
                            replace restart that when chosen let the
                            user input another PACKAGE-DESIGNATOR.

    :IGNORE-OR-REPLACE      If the OBJECT designates a PACKAGE that
                            doesn't exist then signal a
                            PACKAGE-DOES-NOT-EXIST-ERROR with the two
                            previous restarts.


IF-PACKAGE-EXISTS           The default is :PACKAGE

    :PACKAGE                If the OBJECT designates a PACKAGE that
                            does exist then return the designated
                            PACKAGE.

    :STRING                 If the OBJECT designates a PACKAGE that
                            does exist then return the designated
                            package name.

    :ERROR                  If the OBJECT designates a PACKAGE that
                            does exist then signal a
                            PACKAGE-EXISTS-ERROR.

    :IGNORE                 If the OBJECT designates a PACKAGE that
                            does exist then signal a
                            PACKAGE-EXISTS-ERROR with an IGNORE
                            restart that when chosen returns NIL.

    :REPLACE                If the OBJECT designates a PACKAGE that
                            does exist then signal a
                            PACKAGE-EXISTS-ERROR with a replace
                            restart that when chosen let the user
                            input another PACKAGE-DESIGNATOR.

    :IGNORE-OR-REPLACE      If the OBJECT designates a PACKAGE that
                            does exist then signal a
                            PACKAGE-EXISTS-ERROR with the two previous
                            restarts.

"
  (check-type if-not-a-package-designator (member :error :ignore :replace :ignore-or-replace         nil))
  (check-type if-package-does-not-exist   (member :error :ignore :replace :ignore-or-replace :string nil))
  (check-type if-package-exists           (member :error :ignore :replace :ignore-or-replace :string :package))

  (flet ((retry-string-designator (restarts condition &rest arguments)
           (check-type restarts (member :ignore :replace :ignore-or-replace))
           (restart-case (apply (function error) condition arguments)
             (ignore ()
               :test (lambda (condition)
                       (declare (ignore condition))
                       (member restarts '(:ignore :ignore-or-replace)))
               :report "Ignore it."
               nil)
             (read-a-new-package-designator (new-package)
               :test (lambda (condition)
                       (declare (ignore condition))
                       (member restarts '(:replace :ignore-or-replace)))
               :interactive query-package-name
               :report "Enter a package name"
               (normalize-package-designator
                new-package
                :if-not-a-package-designator if-not-a-package-designator
                :if-package-does-not-exist if-package-does-not-exist
                :if-package-exists if-package-exists))))
         (retry-package-designator (restarts condition &rest arguments)
           (check-type restarts (member :ignore :replace :ignore-or-replace))
           (restart-case (apply (function error) condition arguments)
             (ignore ()
               :test (lambda (condition)
                       (declare (ignore condition))
                       (member restarts '(:ignore :ignore-or-replace)))
               :report "Ignore it."
               nil)
             (read-a-new-package-designator (new-package)
               :test (lambda (condition)
                       (declare (ignore condition))
                       (member restarts '(:replace :ignore-or-replace)))
               :interactive query-package-name
               :report "Enter a package name"
               (normalize-package-designator
                new-package
                :if-not-a-package-designator if-not-a-package-designator
                :if-package-does-not-exist if-package-does-not-exist
                :if-package-exists if-package-exists)))))

    (typecase object

      (string-designator
       (let* ((normalized  (normalize-string-designator object))
              (package     (find-package normalized)))
         (if package
             (normalize-package-designator package :if-package-exists if-package-exists)
             (case if-package-does-not-exist
               ((nil)         nil)
               ((:string)     normalized)
               ((:error)      (error
                               'package-does-not-exist-error
                               :package normalized
                               :format-control "There is no package named ~S"
                               :format-arguments (list normalized)))
               ((:ignore :replace :ignore-or-replace)
                (retry-package-designator if-package-does-not-exist
                                          'package-does-not-exist-error
                                          :package normalized
                                          :format-control "There is no package named ~S"
                                          :format-arguments (list normalized)))))))

      (package
       (case if-package-exists
         ((:package) object)
         ((:string)  (package-name object))
         ((:error)   (error
                      'package-exists-error
                      :package object
                      :format-control "There is already a package named ~S"
                      :format-arguments (list (package-name object))))
         ((:ignore :replace :ignore-or-replace)
          (retry-package-designator if-package-exists
                                    'package-exists-error
                                    :package object
                                    :format-control "There is already a package named ~S"
                                    :format-arguments (list (package-name object))))))

      (otherwise
       (case if-not-a-package-designator
         ((nil)     nil)
         ((:error)  (error 'type-error
                           :datum object
                           :expected-type 'package-designator))
         ((:ignore :replace :ignore-or-replace)
          (retry-string-designator if-not-a-package-designator
                                   'type-error
                                   :datum object
                                   :expected-type 'package-designator)))))))




(defun make-package-iterator (packages symbol-types)
  (let ((packages (mapcan (lambda (package-designator)
                            (list (normalize-package-designator
                                   package-designator :if-package-does-not-exist :ignore-or-replace)))
                          (ensure-list packages)))
        (package  nil)
        (stypes   nil)
        (stype    nil)
        (symbols  '()))
    (labels ((iterator ()
               (cond
                 (symbols    (let ((sym (pop symbols)))
                               (values t
                                       sym
                                       (cond
                                         ((externalp sym package) :external)
                                         ((eq stype :inherited)   stype)
                                         (t                       :internal))
                                       package)))
                 (stypes     (setf stype (pop stypes))
                             (ecase stype
                               ((:internal)
                                (tmap-syms (lambda (sym)
                                             (unless (externalp sym package)
                                               (push sym symbols)))
                                           (present-table package)))
                               ((:external)
                                (tmap-syms (lambda (sym) (push sym symbols))
                                           (external-table package)))
                               ((:inherited)
                                (dolist (pack (package-use-list package))
                                  (tmap-syms (lambda (sym)
                                               (let ((shadow (find-symbol (symbol-name sym) package)))
                                                 (unless (and shadow
                                                              (shadowingp shadow package)
                                                              (not (eq sym shadow)))
                                                   (push sym symbols))))
                                             (external-table (find-package pack)))))
                               ((:present)
                                (tmap-syms (lambda (sym) (push sym symbols))
                                           (present-table package)))
                               ((:shadowing)
                                (tmap-syms (lambda (sym) (push sym symbols))
                                           (shadowing-table package))))
                             (iterator))
                 (packages   (setf package (pop packages)
                                   stypes  symbol-types)
                             (iterator))
                 (t          nil))))
      (function iterator))))




(defmethod check-import-conflict (sym pack)
  (let ((existing-sym (find-symbol (symbol-name sym) pack)))
    (if (and existing-sym (not (eq existing-sym sym)))
        (restart-case (error 'symbol-conflict-error
                             :package pack
                             :format-control "Conflict: importing ~A into ~A conflicts with ~A"
                             :format-arguments (list sym pack existing-sym)
                             :existing-symbol existing-sym
                             :imported-symbol sym)
          (enter-new-name (new-symbol)
            :interactive query-symbol
            :report "Enter a new symbol, instead"
            (check-import-conflict new-symbol pack))
          (ignore-symbol ()
            :report (lambda (stream) (format stream "Ignore the symbol ~S" sym))
            (values nil nil)))
        (values sym t))))


(defmacro zdo-external-symbols ((var pack) &body body)
  `(tmap-syms (lambda (,var)
                ,@body)
              (external-table ,pack)))

(defmethod check-inherit-conflict (used-pack using-pack)
  (zdo-external-symbols (inherited-sym used-pack)
                        (let ((existing-sym (find-symbol (symbol-name inherited-sym)
                                                         using-pack)))
                          (when (and existing-sym
                                     (not (eq inherited-sym existing-sym))
                                     (not (shadowingp existing-sym using-pack)))
                            (error "Conflict: Inheriting ~A from ~A conflicts with ~A in ~A"
                                   inherited-sym
                                   used-pack
                                   existing-sym
                                   using-pack)))))

(defmethod check-export-conflict (sym pack)
  (let ((sym-name (symbol-name sym)))
    (dolist (using-pack (package-used-by-list pack))
      (let ((existing-sym (find-symbol sym-name using-pack)))
        (when (and existing-sym
                   (not (member existing-sym (package-shadowing-symbols using-pack))))
          (unless (eq existing-sym sym)
            (error "Conflict: exporting ~A conflicts with ~A in ~A"
                   sym existing-sym using-pack)))))))

(defmethod check-unintern-conflict (sym pack)
  (let ((sym-name (symbol-name sym))
        (first-existing-sym nil))
    (dolist (used-pack (package-use-list pack))
      (let ((existing-sym (find-symbol sym-name used-pack)))
        (when existing-sym
          (if first-existing-sym
              (unless (eq existing-sym first-existing-sym)
                (error "Conflict: uninterning ~A would lead to conflict ~
                      between ~A and ~A"
                       sym first-existing-sym existing-sym))
              (setf first-existing-sym existing-sym)))))))


(defmethod zimport-without-checks (sym pack)
  (tput sym (present-table pack))
  (unless (symbol-package sym)
    (setf (sym-pack sym) pack)))

(defmethod zunintern-without-checks (sym pack)
  (tremove sym (external-table pack))
  (tremove sym (shadowing-table pack))
  (tremove sym (present-table pack))
  (when (eq (symbol-package sym) pack)
    (setf (sym-pack sym) nil)))



(defun check-new-names (pack-name nicknames &key renaming-package)
  (loop
    :with result = '()
    :for name :in (cons pack-name nicknames)
    :do (loop
          :for pack = (find-package name)
          :while (if renaming-package
                     (and pack (not (eq pack renaming-package)))
                     pack)
          :do (restart-case (error 'package-exists-error
                                   :package name
                                   :format-control "A package named ~S already exists"
                                   :format-arguments (list name))
                (enter-new-name (new-name)
                  :test (lambda (condition) (declare (ignore condition)) (eq name pack-name))
                  :interactive query-package-name
                  :report "Enter a new package name, instead"
                  (setf name new-name))
                (enter-new-name (new-name)
                  :test  (lambda (condition) (declare (ignore condition)) (not (eq name pack-name)))
                  :report "Enter a new package nickname, instead"
                  :interactive query-package-nickname
                  (setf name new-name))
                (ignore-nickname ()
                  :test (lambda (condition) (declare (ignore condition)) (not (eq name pack-name)))
                  :report (lambda (stream) (format stream "Ignore the nickname ~S" name))
                  (return)))
          :finally (push name result))
    :finally (let ((result (nreverse result)))
               (return (values (car result) (cdr result))))))


(defmethod make-package (pack-name &key (nicknames '()) (use '()))
  (let ((pack-name (normalize-string-designator pack-name :if-not-a-string-designator :replace))
        (nicknames (normalize-weak-designator-of-list-of-string-designator nicknames))
        (use       (mapcan (lambda (package-designator)
                             (list (normalize-package-designator
                                    package-designator :if-package-does-not-exist :ignore-or-replace)))
                           use)))
    (multiple-value-setq (pack-name nicknames) (check-new-names pack-name nicknames))
    (let ((package (make-instance 'package
                       :name (copy-seq pack-name)
                       :nicknames (mapcar (function copy-seq) nicknames))))
      (dolist (upack use)
        (use-package upack package))
      (dolist (name (cons pack-name nicknames) package)
        (setf (gethash name *packages*) package)))))


(defmethod find-package (pack-name)
  (etypecase pack-name
    (string-designator
     (values (gethash (normalize-string-designator pack-name) *packages*)))
    (package pack-name)))


(defmethod delete-package (pack)
  (let ((pack (normalize-package-designator
               pack :if-package-does-not-exist :replace)))
    (when (and pack (package-name pack))
      (dolist (used (package-used-by-list pack))
        (unuse-package pack used))
      (dolist (puse (package-use-list pack))
        (unuse-package puse pack))
      (do-symbols (sym pack)
        (when (eq (symbol-package sym) pack)
          (zunintern-without-checks sym pack)))
      (dolist (name (cons (package-name pack) (package-nicknames pack)))
        (remhash name *packages*))
      (setf (name pack) nil)
      pack)))



(defmethod find-symbol (sym-name &optional (pack *package*))
  (let ((pack (normalize-package-designator
               pack :if-package-does-not-exist :replace))
        sym)
    (cond ((setf sym (tget sym-name (external-table pack)))
           (values sym :external))
          ((setf sym (tget sym-name (shadowing-table pack)))
           (values sym :internal))
          ((setf sym (some (lambda (used-pack)
                             (tget sym-name (external-table used-pack)))
                           (package-use-list pack)))
           (values sym :inherited))
          ((setf sym (tget sym-name (present-table pack)))
           (values sym :internal))
          (t
           (values nil nil)))))



(defmethod import (symbols &optional (pack *package*))
  (let ((pack (normalize-package-designator
               pack :if-package-does-not-exist :error)))
    (flet ((do-import (sym)
             (check-type sym symbol)
             (multiple-value-bind (sym good) (check-import-conflict sym pack)
               (when (and good (not (presentp sym pack)))
                 (if (and (null (symbol-package sym))
                          (eql pack *keyword-package*))
                     (progn
                       (zimport-without-checks sym pack)
                       (change-class sym 'keyword)
                       (make-constant sym sym)
                       (export sym pack))
                     (zimport-without-checks sym pack))))))
      (mapc (function do-import) (ensure-list symbols)))
    t))


(defmethod intern (sym-name &optional (pack *package*))
  (check-type sym-name string)
  (let ((pack (normalize-package-designator
               pack :if-package-does-not-exist :error)))
    (multiple-value-bind (sym status) (find-symbol sym-name pack)
      (if status
          (values sym status)
          (values (let ((sym (make-symbol sym-name)))
                    (import sym pack)
                    (when (eql pack *keyword-package*)
                      (change-class sym 'keyword)
                      (make-constant sym sym)
                      (export sym pack))
                    sym)
                  nil)))))


(defmethod shadow (symbol-names &optional (pack *package*))
  (let ((pack (normalize-package-designator
               pack :if-package-does-not-exist :error)))
    (flet ((do-shadow (sym-name)
             (let ((sym (tget sym-name (present-table pack))))
               (unless sym
                 (setf sym (make-symbol sym-name))
                 (zimport-without-checks sym pack))
               (tput sym (shadowing-table pack)))))
      (mapc (function do-shadow)
            (normalize-weak-designator-of-list-of-string-designator symbol-names)))
    t))


(defmethod shadowing-import (symbols &optional (pack *package*))
  (let ((pack (normalize-package-designator
               pack :if-package-does-not-exist :error)))
    (flet ((do-shadowing-import (sym)
             (check-type sym symbol)
             (let ((sym-name (symbol-name sym)))
               (multiple-value-bind (existing-sym type) (find-symbol sym-name pack)
                 (case type
                   ((nil :inherited)
                    (zimport-without-checks sym pack))
                   ((:external :internal)
                    (unless (eq existing-sym sym)
                      (zunintern-without-checks existing-sym pack)
                      (import sym pack))))
                 (tput sym (shadowing-table pack))))))
      (mapc (function do-shadowing-import) (ensure-list symbols))
      t)))


(defmethod export (symbols &optional (pack *package*))
  (let ((pack (normalize-package-designator
               pack :if-package-does-not-exist :error)))
    (flet ((do-export (sym)
             (check-type sym symbol)
             (unless (accessiblep sym pack)
               (error 'symbol-inaccessible-error :package pack :symbol sym))
             (check-export-conflict sym pack)
             (unless (presentp sym pack)
               (import sym pack))
             (tput sym (external-table pack))))
      (mapc (function do-export) (ensure-list symbols))
      t)))


(defmethod unexport (symbols &optional (pack *package*))
  (let ((pack (normalize-package-designator
               pack :if-package-does-not-exist :error)))
    (flet ((do-unexport (sym)
             (check-type sym symbol)
             (unless (accessiblep sym pack)
               (error 'symbol-inaccessible-error :package pack :symbol sym))
             (tremove sym (external-table pack))))
      (mapc (function do-unexport) (ensure-list symbols))
      t)))


(defmethod unintern (sym &optional (pack *package*))
  (let ((pack (normalize-package-designator
               pack :if-package-does-not-exist :error)))
    (when (accessiblep sym pack)
      (check-unintern-conflict sym pack)
      (zunintern-without-checks sym pack)
      t)))


(defmethod use-package (packs &optional (using-pack *package*))
  (dolist (pack (ensure-list packs) t)
    (let* ((pack       (normalize-package-designator pack :if-package-does-not-exist :error))
           (using-pack (normalize-package-designator using-pack :if-package-does-not-exist :error))
           (use-list   (package-use-list using-pack)))
      (unless (member pack use-list)
        (check-inherit-conflict pack using-pack)
        (setf (used-packs using-pack) (cons pack use-list))
        (setf (used-by-packs    pack) (cons using-pack (package-used-by-list pack)))))))

(defmethod unuse-package (packs &optional (using-pack *package*))
  (dolist (pack (ensure-list packs) t)
    (let ((pack       (normalize-package-designator pack :if-package-does-not-exist :error))
          (using-pack (normalize-package-designator using-pack :if-package-does-not-exist :error)))
      (setf (used-packs using-pack) (remove pack (package-use-list using-pack)))
      (setf (used-by-packs pack)    (remove using-pack (package-used-by-list pack))))))


(defmethod find-all-symbols (name)
  (let ((name (normalize-string-designator name))
        (symbols '()))
    (dolist (pack (list-all-packages) (delete-duplicates symbols))
      (multiple-value-bind (sym found) (find-symbol name pack)
        (when found
          (push sym symbols))))))


(defmethod rename-package (package new-name &optional new-nicknames)
  (let ((package       (normalize-package-designator
                        package :if-package-does-not-exist :error))
        (new-name      (normalize-string-designator new-name))
        (new-nicknames (normalize-weak-designator-of-list-of-string-designator new-nicknames)))
    (multiple-value-setq (new-name new-nicknames) (check-new-names new-name new-nicknames
                                                                   :renaming-package package))
    ;; remove old names:
    (dolist (name (cons (package-name package) (package-nicknames package)))
      (remhash name *packages*))
    ;; set new names:
    (setf (name package) (copy-seq new-name)
          (nicknames package) (mapcar (function copy-seq) new-nicknames))
    (dolist (name (cons new-name new-nicknames) package)
      (setf (gethash name *packages*) package))))





(defun check-disjoints (shadows shadowing-import-froms import-froms
                        interns exports)
  (loop
    :for sets :in (list (append (list shadows interns)
                                (mapcar (function second) import-froms)
                                (mapcar (function second) shadowing-import-froms))
                        (list interns exports))
    :do (loop
          :for lefts :on sets
          :for left = (first lefts)
          :while (rest lefts)
          :do (loop
                :for rights :on (rest lefts)
                :for right = (first rights)
                :for inter = (intersection left right :test (function string=))
                :do (when inter
                      (flet ((set-name (set)
                               (let ((name (cdr (assoc set (list (cons shadows :shadow)
                                                                 (cons interns :intern)
                                                                 (cons exports :export))))))
                                 (or name
                                     (let ((name (first (find set shadowing-import-froms :key (function rest)))))
                                       (when name (list :shadowing-import-from name)))
                                     (let ((name (first (find set import-froms :key (function rest)))))
                                       (when name (list :import-from name)))))))
                        (error 'simple-program-error
                               :format-control "Symbol names in common between ~S and ~S: ~S"
                               :format-arguments (list (set-name left) (set-name right) inter)))))))
  nil)


(assert (null (check-disjoints (list "S1" "S2" "S3")
                               (list (list "P1" (list "P1A" "P1B" "P1C"))
                                     (list "P2" (list "P2A" "P2B" "P2C")))
                               (list (list "P3" (list "I1A" "I1B" "I1C"))
                                     (list "P4" (list "I2A" "I2B" "I2C")))
                               (list "I1" "I2" "I3")
                               (list "E1" "E2" "E3"))))

(assert (null (check-disjoints (list "S1" "S2" "S3")
                               '()
                               (list (list "P3" (list "I1A" "I1B" "I1C"))
                                     (list "P4" (list "I2A" "I2B" "I2C")))
                               '()
                               (list "E1" "E2" "E3"))))

(assert (nth-value 1 (ignore-errors (check-disjoints (list "S1" "S2" "S3")
                                                     (list (list "P1" (list "P1A" "P1B" "P1C"))
                                                           (list "P2" (list "P2A" "P2B" "P2C" "S3")))
                                                     (list (list "P3" (list "I1A" "I1B" "I1C"))
                                                           (list "P4" (list "I2A" "I2B" "I2C")))
                                                     (list "I1" "I2" "I3")
                                                     (list "E1" "E2" "E3")))))

(assert (null (check-disjoints (list "S1" "S2" "S3")
                               (list (list "P1" (list "P1A" "P1B" "P1C"))
                                     (list "P2" (list "P2A" "P2B" "P2C")))
                               (list (list "P3" (list "I1A" "I1B" "I1C"))
                                     (list "P4" (list "I2A" "I2B" "I2C")))
                               (list "I1" "I2" "I3")
                               (list "E1" "E2" "E3" "S2"))))


(defun %define-package (name shadows shadowing-imports
                        uses imports interns exports
                        documentation nicknames)
  (flet ((find-symbols (import-package names option)
           (mapcan (lambda (name)
                     (multiple-value-bind (symbol status) (find-symbol name import-package)
                       (if (null status)
                           (progn
                             (cerror (format nil "Ignore (~S  ~~*~~S ~~*~~S)" option)
                                     'symbol-does-not-exist-error
                                     :package import-package
                                     :symbol-name name)
                             '())
                           (list symbol))))
                   names)))
    (let ((package (find-package name)))
      (if package
          (let ((unuse-list (set-difference (package-use-list package) uses)))
            (rename-package package name nicknames)
            (unuse-package unuse-list package))
          (setf package (make-package name :nicknames nicknames :use '())))
      (setf (package-documentation package) documentation)
      ;; 1. :shadow and :shadowing-import-from.
      (shadow shadows package)
      (loop
        :for (import-package symbols) :in shadowing-imports
        :do (shadowing-import (find-symbols import-package symbols
                                            :shadowing-import-from)
                              package))
      ;; 2. :use.
      (dolist (upack uses)
        (use-package upack package))
      ;; 3. :import-from and :intern.
      (loop
        :for (import-package symbols) :in imports
        :do (import (find-symbols import-package symbols
                                  :import-from)
                    package))
      (dolist (name interns)
        (intern name package))
      ;; 4. :export.
      (export (mapcar (lambda (name) (intern name package)) exports) package)
      package)))








(defun classify-per-package (symbols)
  (let ((table (make-hash-table))
        (result '()))
    (dolist (sym symbols)
      (push (symbol-name sym) (gethash (symbol-package sym) table '())))
    ;; should do the same as defpackage/extract-from above.
    (maphash (lambda (k v) (push (list k v) result)) table)
    result))

;; (set-equal (package-shadowing-symbols p)
;;            (reduce 'union (cons (package-shadow-list p)
;;                                 (mapcar 'rest (package-shadowing-import-list p)))))

(defmethod package-shadow-list (package)
  "Return the list of shadowed symbols (but not shadowing-imported ones)"
  (remove package (package-shadowing-symbols package)
          :test-not (function eql)
          :key (function symbol-package)))

(defmethod package-shadowing-import-list (package)
  "Return a list of lists of shadowing-imports.
Each sublist contains the package followed by its imported symbols."
  (classify-per-package  (remove package (package-shadowing-symbols package)
                                 :key (function symbol-package))))


;; NOTE: we don't know where the imported symbols were taken from, we
;;       only know their home package.  If they were imported from a
;;       package that used them, or that imported them, then we won't
;;       remember it, and will import them directly from their home.
;;       This is probably not good.

(defmethod package-import-from-list (package)
  (let ((symbols '()))
    (with-package-iterator (it package :present)
      (loop
        (multiple-value-bind (got-it symbol kind home) (it)
          (declare (ignore kind))
          (if got-it
              (unless (eq home package)  (push symbol symbols))
              (return (classify-per-package symbols))))))))

(defmethod package-symbols (package)
  (let ((result '()))
    (with-package-iterator (it package :present)
      (loop
        (multiple-value-bind (got-it symbol kind home) (it)
          (declare (ignore kind))
          (if got-it
              (when (eq home package) (push symbol result))
              (return result)))))))

(defmethod package-export-list (package)
  (let ((result '()))
    (with-package-iterator (it package :external)
      (loop
        (multiple-value-bind (got-it symbol kind home) (it)
          (declare (ignore kind home))
          (if got-it
              (push symbol result)
              (return result)))))))




(defmethod make-load-form ((pack package) &optional environment)
  (declare (ignore environment))
  `(%define-package ',(package-name pack)
                    ',(mapcar (function symbol-name) (package-shadow-list pack))
                    ',(package-shadowing-import-list pack)
                    ',(mapcar (function package-name) (package-use-list pack))
                    ',(package-import-from-list pack)
                    ',(mapcar (function symbol-name) (package-symbols pack))
                    ',(mapcar (function symbol-name) (package-export-list pack))
                    ',(package-documentation pack)
                    ',(package-nicknames pack)))


(defmacro in-package (name)
  "
DO:     Sets the current *package* to the package designated by NAME.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/m_in_pkg.htm>
"
  (let ((name (normalize-string-designator name)))
    `(eval-when (:compile-toplevel :load-toplevel :execute)
       (let ((new-package (normalize-package-designator
                           ,name :if-package-does-not-exist :ignore-or-replace)))
         (when new-package
           (setf *package* new-package))))))

;; To test:
;; (cl-user::cd #P"~/src/lisp/implementations/ansi-tests/") (mapc 'delete-file (directory "*.lx*")) (load "zpack-load.lsp")

;;;; THE END ;;;;
ViewGit