;;;; PACKAGEs and stuff like that
;;;;
;;;; Note: The code in this file signals many correctable errors. This
;;;; is not just an arbitrary aesthetic decision on the part of the
;;;; implementor -- many of these are specified by ANSI 11.1.1.2.5,
;;;; "Prevention of Name Conflicts in Packages":
;;;;   Within one package, any particular name can refer to at most one
;;;;   symbol. A name conflict is said to occur when there would be more
;;;;   than one candidate symbol. Any time a name conflict is about to
;;;;   occur, a correctable error is signaled.
;;;;
;;;; FIXME: The code contains a lot of type declarations. Are they
;;;; all really necessary?

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB!IMPL")

(!begin-collecting-cold-init-forms)

(!cold-init-forms
  (/show0 "entering !PACKAGE-COLD-INIT"))

;;;; PACKAGE-HASHTABLE stuff

(def!method print-object ((table package-hashtable) stream)
  (declare (type stream stream))
  (print-unreadable-object (table stream :type t)
    (format stream
	    ":SIZE ~S :FREE ~S :DELETED ~S"
	    (package-hashtable-size table)
	    (package-hashtable-free table)
	    (package-hashtable-deleted table))))

;;; the maximum density we allow in a package hashtable
(defconstant package-rehash-threshold 0.75)

;;; Make a package hashtable having a prime number of entries at least
;;; as great as (/ SIZE PACKAGE-REHASH-THRESHOLD). If RES is supplied,
;;; then it is destructively modified to produce the result. This is
;;; useful when changing the size, since there are many pointers to
;;; the hashtable.
(defun make-or-remake-package-hashtable (size
					 &optional
                                         res)
  (flet ((actual-package-hashtable-size (size)
           (loop for n of-type fixnum
              from (logior (truncate size package-rehash-threshold) 1)
              by 2
              when (positive-primep n) return n)))
    (let* ((n (actual-package-hashtable-size size))
           (size (truncate (* n package-rehash-threshold)))
           (table (make-array n))
           (hash (make-array n
                             :element-type '(unsigned-byte 8)
                             :initial-element 0)))
      (if res
          (setf (package-hashtable-table res) table
                (package-hashtable-hash res) hash
                (package-hashtable-size res) size
                (package-hashtable-free res) size
                (package-hashtable-deleted res) 0)
          (setf res (%make-package-hashtable table hash size)))
      res)))

;;;; package locking operations, built conditionally on :sb-package-locks

#!+sb-package-locks
(progn
(defun package-locked-p (package) 
  #!+sb-doc 
  "Returns T when PACKAGE is locked, NIL otherwise. Signals an error
if PACKAGE doesn't designate a valid package."
  (package-lock (find-undeleted-package-or-lose package)))

(defun lock-package (package)
  #!+sb-doc 
  "Locks PACKAGE and returns T. Has no effect if PACKAGE was already
locked. Signals an error if PACKAGE is not a valid package designator"
  (setf (package-lock (find-undeleted-package-or-lose package)) t))

(defun unlock-package (package)
  #!+sb-doc 
  "Unlocks PACKAGE and returns T. Has no effect if PACKAGE was already
unlocked. Signals an error if PACKAGE is not a valid package designator."
  (setf (package-lock (find-undeleted-package-or-lose package)) nil)
  t)

(defun package-implemented-by-list (package)
  #!+sb-doc 
  "Returns a list containing the implementation packages of
PACKAGE. Signals an error if PACKAGE is not a valid package designator."
  (package-%implementation-packages (find-undeleted-package-or-lose package)))

(defun package-implements-list (package) 
  #!+sb-doc 
  "Returns the packages that PACKAGE is an implementation package
of. Signals an error if PACKAGE is not a valid package designator."
  (let ((package (find-undeleted-package-or-lose package)))
    (loop for x in (list-all-packages)
          when (member package (package-%implementation-packages x))
          collect x)))

(defun add-implementation-package (packages-to-add 
				   &optional (package *package*))
  #!+sb-doc 
  "Adds PACKAGES-TO-ADD as implementation packages of PACKAGE. Signals
an error if PACKAGE or any of the PACKAGES-TO-ADD is not a valid
package designator."
  (let ((package (find-undeleted-package-or-lose package))
	(packages-to-add (package-listify packages-to-add)))
    (setf (package-%implementation-packages package)
          (union (package-%implementation-packages package)
                 (mapcar #'find-undeleted-package-or-lose packages-to-add)))))

(defun remove-implementation-package (packages-to-remove 
				      &optional (package *package*)) 
  #!+sb-doc 
  "Removes PACKAGES-TO-REMOVE from the implementation packages of
PACKAGE. Signals an error if PACKAGE or any of the PACKAGES-TO-REMOVE
is not a valid package designator."
  (let ((package (find-undeleted-package-or-lose package))
	(packages-to-remove (package-listify packages-to-remove)))
    (setf (package-%implementation-packages package)
          (nset-difference 
           (package-%implementation-packages package)
           (mapcar #'find-undeleted-package-or-lose packages-to-remove)))))

(defmacro with-unlocked-packages ((&rest packages) &body forms)
  #!+sb-doc
  "Unlocks PACKAGES for the dynamic scope of the body. Signals an
error if any of PACKAGES is not a valid package designator."
  (with-unique-names (unlocked-packages)
    `(let (,unlocked-packages)
      (unwind-protect
           (progn 
             (dolist (p ',packages)
               (when (package-locked-p p)
                 (push p ,unlocked-packages)
                 (unlock-package p)))
             ,@forms)
        (dolist (p ,unlocked-packages)
	  (when (find-package p)
	    (lock-package p)))))))

(defun package-lock-violation (package &key (symbol nil symbol-p)
                               format-control format-arguments)
  (let* ((restart :continue)
         (cl-violation-p (eq package *cl-package*))
         (error-arguments
          (append (list (if symbol-p
                            'symbol-package-locked-error
                            'package-locked-error)
                        :package package
                        :format-control format-control
                        :format-arguments format-arguments)
                  (when symbol-p (list :symbol symbol))
                  (list :references
                        (append '((:sbcl :node "Package Locks"))
                                (when cl-violation-p
                                  '((:ansi-cl :section (11 1 2 1 2)))))))))
    (restart-case
        (apply #'cerror "Ignore the package lock." error-arguments)
      (:ignore-all ()
        :report "Ignore all package locks in the context of this operation."
        (setf restart :ignore-all))
      (:unlock-package ()
        :report "Unlock the package."
        (setf restart :unlock-package)))
    (ecase restart
      (:continue
       (pushnew package *ignored-package-locks*))
      (:ignore-all
       (setf *ignored-package-locks* t))
      (:unlock-package
       (unlock-package package)))))

(defun package-lock-violation-p (package &optional (symbol nil symbolp))
  ;; KLUDGE: (package-lock package) needs to be before
  ;; comparison to *package*, since during cold init this gets
  ;; called before *package* is bound -- but no package should
  ;; be locked at that point.
  (and package 
       (package-lock package)
       ;; In package or implementation package
       (not (or (eq package *package*)
                (member *package* (package-%implementation-packages package))))
       ;; Runtime disabling
       (not (eq t *ignored-package-locks*))
       (or (eq :invalid *ignored-package-locks*)
           (not (member package *ignored-package-locks*)))
       ;; declarations for symbols
       (not (and symbolp (member symbol (disabled-package-locks))))))

(defun disabled-package-locks ()
  (if (boundp 'sb!c::*lexenv*)
      (sb!c::lexenv-disabled-package-locks sb!c::*lexenv*)
      sb!c::*disabled-package-locks*))

) ; progn

;;;; more package-locking these are NOPs unless :sb-package-locks is
;;;; in target features. Cross-compiler NOPs for these are in cross-misc.

;;; The right way to establish a package lock context is
;;; WITH-SINGLE-PACKAGE-LOCKED-ERROR, defined in early-package.lisp
;;;
;;; Must be used inside the dynamic contour established by
;;; WITH-SINGLE-PACKAGE-LOCKED-ERROR
(defun assert-package-unlocked (package &optional format-control 
				&rest format-arguments)
  #!-sb-package-locks 
  (declare (ignore format-control format-arguments))
  #!+sb-package-locks
  (when (package-lock-violation-p package)
    (package-lock-violation package 
			    :format-control format-control 
			    :format-arguments format-arguments))
  package)

;;; Must be used inside the dynamic contour established by
;;; WITH-SINGLE-PACKAGE-LOCKED-ERROR.
;;;
;;; FIXME: Maybe we should establish such contours for he toplevel
;;; and others, so that %set-fdefinition and others could just use
;;; this.
(defun assert-symbol-home-package-unlocked (name format)
  #!-sb-package-locks
  (declare (ignore format))
  #!+sb-package-locks
  (let* ((symbol (etypecase name
		   (symbol name)
		   (list (if (eq 'setf (first name))
			     (second name)
			     ;; Skip (class-predicate foo), etc.
			     ;; FIXME: MOP and package-lock
			     ;; interaction needs to be thought about.
			     (return-from 
			      assert-symbol-home-package-unlocked
			       name)))))
	 (package (symbol-package symbol)))
    (when (package-lock-violation-p package symbol)
      (package-lock-violation package 
			      :symbol symbol
			      :format-control format
			      :format-arguments (list name))))
  name)


;;;; miscellaneous PACKAGE operations

(def!method print-object ((package package) stream)
  (let ((name (package-%name package)))
    (if name
	(print-unreadable-object (package stream :type t)
	  (prin1 name stream))
	(print-unreadable-object (package stream :type t :identity t)
	  (write-string "(deleted)" stream)))))

;;; ANSI says (in the definition of DELETE-PACKAGE) that these, and
;;; most other operations, are unspecified for deleted packages. We
;;; just do the easy thing and signal errors in that case.
(macrolet ((def (ext real)
	     `(defun ,ext (x) (,real (find-undeleted-package-or-lose x)))))
  (def package-nicknames package-%nicknames)
  (def package-use-list package-%use-list)
  (def package-used-by-list package-%used-by-list)
  (def package-shadowing-symbols package-%shadowing-symbols))

(defun %package-hashtable-symbol-count (table)
  (let ((size (the fixnum
		(- (package-hashtable-size table)
		   (package-hashtable-deleted table)))))
    (the fixnum
      (- size (package-hashtable-free table)))))

(defun package-internal-symbol-count (package)
  (%package-hashtable-symbol-count (package-internal-symbols package)))

(defun package-external-symbol-count (package)
  (%package-hashtable-symbol-count (package-external-symbols package)))

(defvar *package* (error "*PACKAGE* should be initialized in cold load!") 
  #!+sb-doc "the current package")
;;; FIXME: should be declared of type PACKAGE, with no NIL init form,
;;; after I get around to cleaning up DOCUMENTATION

;;; a map from package names to packages
(defvar *package-names*)
(declaim (type hash-table *package-names*))
(!cold-init-forms
  (setf *package-names* (make-hash-table :test 'equal)))

;;; This magical variable is T during initialization so that
;;; USE-PACKAGE's of packages that don't yet exist quietly win. Such
;;; packages are thrown onto the list *DEFERRED-USE-PACKAGES* so that
;;; this can be fixed up later.
;;;
;;; FIXME: This could be cleaned up the same way I do it in my package
;;; hacking when setting up the cross-compiler. Then we wouldn't have
;;; this extraneous global variable and annoying runtime tests on
;;; package operations. (*DEFERRED-USE-PACKAGES* would also go away.)
(defvar *in-package-init*)

;;; pending USE-PACKAGE arguments saved up while *IN-PACKAGE-INIT* is true
(defvar *!deferred-use-packages*)
(!cold-init-forms
  (setf *!deferred-use-packages* nil))

(define-condition bootstrap-package-not-found (condition)
  ((name :initarg :name :reader bootstrap-package-name)))
(defun debootstrap-package (&optional condition)
  (invoke-restart 
   (find-restart-or-control-error 'debootstrap-package condition)))
  
(defun find-package (package-designator)
  (flet ((find-package-from-string (string)
	   (declare (type string string))
	   (let ((packageoid (gethash string *package-names*)))
	     (when (and (null packageoid)
			(not *in-package-init*) ; KLUDGE
			(let ((mismatch (mismatch "SB!" string)))
			  (and mismatch (= mismatch 3))))
	       (restart-case
		   (signal 'bootstrap-package-not-found :name string)
		 (debootstrap-package ()
		   (return-from find-package
		     (if (string= string "SB!XC")
			 (find-package "COMMON-LISP")
			 (find-package 
			  (substitute #\- #\! string :count 1)))))))
	     packageoid)))
    (typecase package-designator
      (package package-designator)
      (symbol (find-package-from-string (symbol-name package-designator)))
      (string (find-package-from-string package-designator))
      (character (find-package-from-string (string package-designator)))
      (t (error 'type-error
		:datum package-designator
		:expected-type '(or character package string symbol))))))

;;; Return a list of packages given a package designator or list of
;;; package designators, or die trying.
(defun package-listify (thing)
  (let ((res ()))
    (dolist (thing (if (listp thing) thing (list thing)) res)
      (push (find-undeleted-package-or-lose thing) res))))

;;; Make a package name into a simple-string.
(defun package-namify (n)
  (stringify-name n "package"))

;;; ANSI specifies (in the definition of DELETE-PACKAGE) that PACKAGE-NAME
;;; returns NIL (not an error) for a deleted package, so this is a special
;;; case where we want to use bare %FIND-PACKAGE-OR-LOSE instead of
;;; FIND-UNDELETED-PACKAGE-OR-LOSE.
(defun package-name (package-designator)
  (package-%name (%find-package-or-lose package-designator)))

;;;; operations on package hashtables

;;; Compute a number from the sxhash of the pname and the length which
;;; must be between 2 and 255.
(defmacro entry-hash (length sxhash)
  `(the fixnum
	(+ (the fixnum
		(rem (the fixnum
			  (logxor ,length
				  ,sxhash
				  (the fixnum (ash ,sxhash -8))
				  (the fixnum (ash ,sxhash -16))
				  (the fixnum (ash ,sxhash -19))))
		     254))
	   2)))
;;; FIXME: should be wrapped in EVAL-WHEN (COMPILE EXECUTE)

;;; Add a symbol to a package hashtable. The symbol is assumed
;;; not to be present.
(defun add-symbol (table symbol)
  (let* ((vec (package-hashtable-table table))
	 (hash (package-hashtable-hash table))
	 (len (length vec))
	 (sxhash (%sxhash-simple-string (symbol-name symbol)))
	 (h2 (the fixnum (1+ (the fixnum (rem sxhash
					      (the fixnum (- len 2))))))))
    (declare (fixnum len sxhash h2))
    (cond ((zerop (the fixnum (package-hashtable-free table)))
	   (make-or-remake-package-hashtable (* (package-hashtable-size table)
						2)
					     table)
	   (add-symbol table symbol)
	   (dotimes (i len)
	     (declare (fixnum i))
	     (when (> (the fixnum (aref hash i)) 1)
	       (add-symbol table (svref vec i)))))
	  (t
	   (do ((i (rem sxhash len) (rem (+ i h2) len)))
	       ((< (the fixnum (aref hash i)) 2)
		(if (zerop (the fixnum (aref hash i)))
		    (decf (package-hashtable-free table))
		    (decf (package-hashtable-deleted table)))
		(setf (svref vec i) symbol)
		(setf (aref hash i)
		      (entry-hash (length (symbol-name symbol))
				  sxhash)))
	     (declare (fixnum i)))))))

;;; Find where the symbol named STRING is stored in TABLE. INDEX-VAR
;;; is bound to the index, or NIL if it is not present. SYMBOL-VAR
;;; is bound to the symbol. LENGTH and HASH are the length and sxhash
;;; of STRING. ENTRY-HASH is the entry-hash of the string and length.
(defmacro with-symbol ((index-var symbol-var table string length sxhash
				  entry-hash)
		       &body forms)
  (let ((vec (gensym)) (hash (gensym)) (len (gensym)) (h2 (gensym))
	(name (gensym)) (name-len (gensym)) (ehash (gensym)))
    `(let* ((,vec (package-hashtable-table ,table))
	    (,hash (package-hashtable-hash ,table))
	    (,len (length ,vec))
	    (,h2 (1+ (the index (rem (the index ,sxhash)
				      (the index (- ,len 2)))))))
       (declare (type index ,len ,h2))
       (prog ((,index-var (rem (the index ,sxhash) ,len))
	      ,symbol-var ,ehash)
	 (declare (type (or index null) ,index-var))
	 LOOP
	 (setq ,ehash (aref ,hash ,index-var))
	 (cond ((eql ,ehash ,entry-hash)
		(setq ,symbol-var (svref ,vec ,index-var))
		(let* ((,name (symbol-name ,symbol-var))
		       (,name-len (length ,name)))
		  (declare (type index ,name-len))
		  (when (and (= ,name-len ,length)
			     (string= ,string ,name
				      :end1 ,length
				      :end2 ,name-len))
		    (go DOIT))))
	       ((zerop ,ehash)
		(setq ,index-var nil)
		(go DOIT)))
	 (setq ,index-var (+ ,index-var ,h2))
	 (when (>= ,index-var ,len)
	   (setq ,index-var (- ,index-var ,len)))
	 (go LOOP)
	 DOIT
	 (return (progn ,@forms))))))

;;; Delete the entry for STRING in TABLE. The entry must exist.
(defun nuke-symbol (table string)
  (declare (simple-string string))
  (let* ((length (length string))
	 (hash (%sxhash-simple-string string))
	 (ehash (entry-hash length hash)))
    (declare (type index length hash))
    (with-symbol (index symbol table string length hash ehash)
      (setf (aref (package-hashtable-hash table) index) 1)
      (setf (aref (package-hashtable-table table) index) nil)
      (incf (package-hashtable-deleted table)))))

;;; Enter any new NICKNAMES for PACKAGE into *PACKAGE-NAMES*.
;;; If there is a conflict then give the user a chance to do
;;; something about it.
(defun enter-new-nicknames (package nicknames)
  (declare (type list nicknames))
  (dolist (n nicknames)
    (let* ((n (package-namify n))
	   (found (gethash n *package-names*)))
      (cond ((not found)
	     (setf (gethash n *package-names*) package)
	     (push n (package-%nicknames package)))
	    ((eq found package))
	    ((string= (the string (package-%name found)) n)
	     ;; FIXME: This and the next error needn't have restarts.
	     (with-simple-restart (continue "Ignore this nickname.")
	       (error 'simple-package-error
		      :package package
		      :format-control "~S is a package name, so it cannot be a nickname for ~S."
		      :format-arguments (list n (package-%name package)))))
	    (t
	     (with-simple-restart (continue "Redefine this nickname.")
	       (error 'simple-package-error
		      :package package
		      :format-control "~S is already a nickname for ~S."
		      :format-arguments (list n (package-%name found))))
	     (setf (gethash n *package-names*) package)
	     (push n (package-%nicknames package)))))))

(defun make-package (name &key
			  (use '#.*default-package-use-list*)
			  nicknames
			  (internal-symbols 10)
			  (external-symbols 10))
  #!+sb-doc
  #.(format nil
     "Make a new package having the specified NAME, NICKNAMES, and 
  USE list. :INTERNAL-SYMBOLS and :EXTERNAL-SYMBOLS are
  estimates for the number of internal and external symbols which
  will ultimately be present in the package. The default value of
  USE is implementation-dependent, and in this implementation
  it is ~S."
     *default-package-use-list*)

  ;; Check for package name conflicts in name and nicknames, then
  ;; make the package.
  (when (find-package name)
    ;; ANSI specifies that this error is correctable.
    (cerror "Leave existing package alone."
	    "A package named ~S already exists" name))
  (let* ((name (package-namify name))
	 (package (internal-make-package
		   :%name name
		   :internal-symbols (make-or-remake-package-hashtable
				      internal-symbols)
		   :external-symbols (make-or-remake-package-hashtable
				      external-symbols))))

    ;; Do a USE-PACKAGE for each thing in the USE list so that checking for
    ;; conflicting exports among used packages is done.
    (if *in-package-init*
	(push (list use package) *!deferred-use-packages*)
	(use-package use package))

    ;; FIXME: ENTER-NEW-NICKNAMES can fail (ERROR) if nicknames are illegal,
    ;; which would leave us with possibly-bad side effects from the earlier
    ;; USE-PACKAGE (e.g. this package on the used-by lists of other packages,
    ;; but not in *PACKAGE-NAMES*, and possibly import side effects too?).
    ;; Perhaps this can be solved by just moving ENTER-NEW-NICKNAMES before
    ;; USE-PACKAGE, but I need to check what kinds of errors can be caused by
    ;; USE-PACKAGE, too.
    (enter-new-nicknames package nicknames)
    (setf (gethash name *package-names*) package)))

;;; Change the name if we can, blast any old nicknames and then
;;; add in any new ones.
;;;
;;; FIXME: ANSI claims that NAME is a package designator (not just a
;;; string designator -- weird). Thus, NAME could
;;; be a package instead of a string. Presumably then we should not change
;;; the package name if NAME is the same package that's referred to by PACKAGE.
;;; If it's a *different* package, we should probably signal an error.
;;; (perhaps (ERROR 'ANSI-WEIRDNESS ..):-)
(defun rename-package (package name &optional (nicknames ()))
  #!+sb-doc
  "Changes the name and nicknames for a package."
  (let* ((package (find-undeleted-package-or-lose package))
	 (name (string name))
	 (found (find-package name))
	 (nicks (mapcar #'string nicknames)))
    (unless (or (not found) (eq found package))
      (error 'simple-package-error
	     :package name
	     :format-control "A package named ~S already exists."
	     :format-arguments (list name)))
    (with-single-package-locked-error ()
	(unless (and (string= name (package-name package))
		     (null (set-difference nicks (package-nicknames package) 
				       :test #'string=)))
	  (assert-package-unlocked package "rename as ~A~@[ with nickname~P ~
                                           ~{~A~^, ~}~]" 
				   name (length nicks) nicks))
      ;; do the renaming
      (remhash (package-%name package) *package-names*)
      (dolist (n (package-%nicknames package))
	(remhash n *package-names*))
      (setf (package-%name package) name
	    (gethash name *package-names*) package
	    (package-%nicknames package) ())
      (enter-new-nicknames package nicknames))
    package))

(defun delete-package (package-or-name)
  #!+sb-doc
  "Delete the package-or-name from the package system data structures."
  (let ((package (if (packagep package-or-name)
		     package-or-name
		     (find-package package-or-name))))
    (cond ((not package)
	   ;; This continuable error is required by ANSI.
	   (with-simple-restart (continue "Return NIL")
	     (error 'simple-package-error
		    :package package-or-name
		    :format-control "There is no package named ~S."
		    :format-arguments (list package-or-name))))
	  ((not (package-name package)) ; already deleted
	   nil)
	  (t
	   (with-single-package-locked-error
	       (:package package "deleting package ~A" package)
	     (let ((use-list (package-used-by-list package)))
	       (when use-list
		 ;; This continuable error is specified by ANSI.
		 (with-simple-restart
		     (continue "Remove dependency in other packages.")
		   (error 'simple-package-error
			  :package package
			  :format-control
			  "Package ~S is used by package(s):~%  ~S"
			  :format-arguments
			  (list (package-name package)
				(mapcar #'package-name use-list))))
		 (dolist (p use-list)
		   (unuse-package package p))))
	     (dolist (used (package-use-list package))
	       (unuse-package used package))
	     (do-symbols (sym package)
	       (unintern sym package))
	     (remhash (package-name package) *package-names*)
	     (dolist (nick (package-nicknames package))
	       (remhash nick *package-names*))
	     (setf (package-%name package) nil
		   ;; Setting PACKAGE-%NAME to NIL is required in order to
		   ;; make PACKAGE-NAME return NIL for a deleted package as
		   ;; ANSI requires. Setting the other slots to NIL
		   ;; and blowing away the PACKAGE-HASHTABLES is just done
		   ;; for tidiness and to help the GC.
		   (package-%nicknames package) nil
		   (package-%use-list package) nil
		   (package-tables package) nil
		   (package-%shadowing-symbols package) nil
		   (package-internal-symbols package)
		   (make-or-remake-package-hashtable 0)
		   (package-external-symbols package)
		   (make-or-remake-package-hashtable 0))
	     t)))))

(defun list-all-packages ()
  #!+sb-doc
  "Return a list of all existing packages."
  (let ((res ()))
    (maphash (lambda (k v)
	       (declare (ignore k))
	       (pushnew v res))
	     *package-names*)
    res))

(defun intern (name &optional (package (sane-package)))
  #!+sb-doc
  "Return a symbol having the specified name, creating it if necessary."
  ;; We just simple-stringify the name and call INTERN*, where the real
  ;; logic is.
  (let ((name (if (simple-string-p name)
		name
		(coerce name 'simple-string)))
	(package (find-undeleted-package-or-lose package)))
    (declare (simple-string name))
      (intern* name
	       (length name)
	       package)))

(defun find-symbol (name &optional (package (sane-package)))
  #!+sb-doc
  "Return the symbol named String in Package. If such a symbol is found
  then the second value is :internal, :external or :inherited to indicate
  how the symbol is accessible. If no symbol is found then both values
  are NIL."
  ;; We just simple-stringify the name and call FIND-SYMBOL*, where the
  ;; real logic is.
  (let ((name (if (simple-string-p name) name (coerce name 'simple-string))))
    (declare (simple-string name))
    (find-symbol* name
		  (length name)
		  (find-undeleted-package-or-lose package))))

;;; If the symbol named by the first LENGTH characters of NAME doesn't exist,
;;; then create it, special-casing the keyword package.
(defun intern* (name length package)
  (declare (simple-string name))
  (multiple-value-bind (symbol where) (find-symbol* name length package)
    (cond (where
	   (values symbol where))
	  (t
	   (let ((symbol-name (subseq name 0 length)))
	     (with-single-package-locked-error 
		 (:package package "interning ~A" symbol-name)
	       (let ((symbol (make-symbol symbol-name)))
		 (%set-symbol-package symbol package)
		 (cond ((eq package *keyword-package*)
			(add-symbol (package-external-symbols package) symbol)
			(%set-symbol-value symbol symbol))
		       (t
			(add-symbol (package-internal-symbols package) symbol)))
		 (values symbol nil))))))))

;;; Check internal and external symbols, then scan down the list
;;; of hashtables for inherited symbols. When an inherited symbol
;;; is found pull that table to the beginning of the list.
(defun find-symbol* (string length package)
  (declare (simple-string string)
	   (type index length))
  (let* ((hash (%sxhash-simple-substring string length))
	 (ehash (entry-hash length hash)))
    (declare (type index hash ehash))
    (with-symbol (found symbol (package-internal-symbols package)
			string length hash ehash)
      (when found
	(return-from find-symbol* (values symbol :internal))))
    (with-symbol (found symbol (package-external-symbols package)
			string length hash ehash)
      (when found
	(return-from find-symbol* (values symbol :external))))
    (let ((head (package-tables package)))
      (do ((prev head table)
	   (table (cdr head) (cdr table)))
	  ((null table) (values nil nil))
	(with-symbol (found symbol (car table) string length hash ehash)
	  (when found
	    (unless (eq prev head)
	      (shiftf (cdr prev) (cdr table) (cdr head) table))
	    (return-from find-symbol* (values symbol :inherited))))))))

;;; Similar to Find-Symbol, but only looks for an external symbol.
;;; This is used for fast name-conflict checking in this file and symbol
;;; printing in the printer.
(defun find-external-symbol (string package)
  (declare (simple-string string))
  (let* ((length (length string))
	 (hash (%sxhash-simple-string string))
	 (ehash (entry-hash length hash)))
    (declare (type index length hash))
    (with-symbol (found symbol (package-external-symbols package)
			string length hash ehash)
      (values symbol found))))

;;; If we are uninterning a shadowing symbol, then a name conflict can
;;; result, otherwise just nuke the symbol.
(defun unintern (symbol &optional (package (sane-package)))
  #!+sb-doc
  "Makes Symbol no longer present in Package. If Symbol was present
  then T is returned, otherwise NIL. If Package is Symbol's home
  package, then it is made uninterned."
  (let* ((package (find-undeleted-package-or-lose package))
	 (name (symbol-name symbol))
	 (shadowing-symbols (package-%shadowing-symbols package)))
    (declare (list shadowing-symbols))

    (with-single-package-locked-error ()
      (when (find-symbol name package)
	(assert-package-unlocked package "uninterning ~A" name))
      
      ;; If a name conflict is revealed, give use a chance to shadowing-import
      ;; one of the accessible symbols.
      (when (member symbol shadowing-symbols)
	(let ((cset ()))
	  (dolist (p (package-%use-list package))
	    (multiple-value-bind (s w) (find-external-symbol name p)
	      (when w (pushnew s cset))))
	  (when (cdr cset)
	    (loop
	     (cerror
	      "Prompt for a symbol to SHADOWING-IMPORT."
	      "Uninterning symbol ~S causes name conflict among these symbols:~%~S"
	      symbol cset)
	     (write-string "Symbol to shadowing-import: " *query-io*)
	     (let ((sym (read *query-io*)))
	       (cond
		 ((not (symbolp sym))
		  (format *query-io* "~S is not a symbol." sym))
		 ((not (member sym cset))
		  (format *query-io* "~S is not one of the conflicting symbols." sym))
		 (t
		  (shadowing-import sym package)
		  (return-from unintern t)))))))
	(setf (package-%shadowing-symbols package)
	      (remove symbol shadowing-symbols)))

      (multiple-value-bind (s w) (find-symbol name package)
	(declare (ignore s))
	(cond ((or (eq w :internal) (eq w :external))
	       (nuke-symbol (if (eq w :internal)
				(package-internal-symbols package)
				(package-external-symbols package))
			    name)
	       (if (eq (symbol-package symbol) package)
		   (%set-symbol-package symbol nil))
	       t)
	      (t nil))))))

;;; Take a symbol-or-list-of-symbols and return a list, checking types.
(defun symbol-listify (thing)
  (cond ((listp thing)
	 (dolist (s thing)
	   (unless (symbolp s) (error "~S is not a symbol." s)))
	 thing)
	((symbolp thing) (list thing))
	(t
	 (error "~S is neither a symbol nor a list of symbols." thing))))

(defun string-listify (thing)
  (mapcar #'string (if (listp thing) 
		       thing 
		       (list thing))))

;;; This is like UNINTERN, except if SYMBOL is inherited, it chases
;;; down the package it is inherited from and uninterns it there. Used
;;; for name-conflict resolution. Shadowing symbols are not uninterned
;;; since they do not cause conflicts.
(defun moby-unintern (symbol package)
  (unless (member symbol (package-%shadowing-symbols package))
    (or (unintern symbol package)
	(let ((name (symbol-name symbol)))
	  (multiple-value-bind (s w) (find-symbol name package)
	    (declare (ignore s))
	    (when (eq w :inherited)
	      (dolist (q (package-%use-list package))
		(multiple-value-bind (u x) (find-external-symbol name q)
		  (declare (ignore u))
		  (when x
		    (unintern symbol q)
		    (return t))))))))))

(defun export (symbols &optional (package (sane-package)))
  #!+sb-doc
  "Exports Symbols from Package, checking that no name conflicts result."
  (let ((package (find-undeleted-package-or-lose package))
	(syms ()))
    ;; Punt any symbols that are already external.
    (dolist (sym (symbol-listify symbols))
      (multiple-value-bind (s w)
	  (find-external-symbol (symbol-name sym) package)
	(declare (ignore s))
	(unless (or w (member sym syms))
	  (push sym syms))))
    (with-single-package-locked-error ()
      (when syms
	(assert-package-unlocked package "exporting symbol~P ~{~A~^, ~}"
				 (length syms) syms))
      ;; Find symbols and packages with conflicts.
      (let ((used-by (package-%used-by-list package))
	    (cpackages ())
	    (cset ()))
	(dolist (sym syms)
	  (let ((name (symbol-name sym)))
	    (dolist (p used-by)
	      (multiple-value-bind (s w) (find-symbol name p)
		(when (and w (not (eq s sym))
			   (not (member s (package-%shadowing-symbols p))))
		  (pushnew sym cset)
		  (pushnew p cpackages))))))
	(when cset
	  (restart-case
	      (error
	       'simple-package-error
	       :package package
	       :format-control
	       "Exporting these symbols from the ~A package:~%~S~%~
	        results in name conflicts with these packages:~%~{~A ~}"
	       :format-arguments
	       (list (package-%name package) cset
		     (mapcar #'package-%name cpackages)))
	    (unintern-conflicting-symbols ()
	      :report "Unintern conflicting symbols."
	      (dolist (p cpackages)
		(dolist (sym cset)
		  (moby-unintern sym p))))
	    (skip-exporting-these-symbols ()
	      :report "Skip exporting conflicting symbols."
	      (setq syms (nset-difference syms cset))))))

      ;; Check that all symbols are accessible. If not, ask to import them.
      (let ((missing ())
	    (imports ()))
	(dolist (sym syms)
	  (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
	    (cond ((not (and w (eq s sym)))
		   (push sym missing))
		  ((eq w :inherited)
		   (push sym imports)))))
	(when missing
	  (with-simple-restart
	      (continue "Import these symbols into the ~A package."
			(package-%name package))
	    (error 'simple-package-error
		   :package package
		   :format-control
		   "These symbols are not accessible in the ~A package:~%~S"
		   :format-arguments
		   (list (package-%name package) missing)))
	  (import missing package))
	(import imports package))

      ;; And now, three pages later, we export the suckers.
      (let ((internal (package-internal-symbols package))
	    (external (package-external-symbols package)))
	(dolist (sym syms)
	  (nuke-symbol internal (symbol-name sym))
	  (add-symbol external sym))))
      t))

;;; Check that all symbols are accessible, then move from external to internal.
(defun unexport (symbols &optional (package (sane-package)))
  #!+sb-doc
  "Makes Symbols no longer exported from Package."
  (let ((package (find-undeleted-package-or-lose package))
	(syms ()))
    (dolist (sym (symbol-listify symbols))
      (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
	(cond ((or (not w) (not (eq s sym)))
	       (error 'simple-package-error
		      :package package
		      :format-control "~S is not accessible in the ~A package."
		      :format-arguments (list sym (package-%name package))))
	      ((eq w :external) (pushnew sym syms)))))
    (with-single-package-locked-error ()
      (when syms
	(assert-package-unlocked package "unexporting symbol~P ~{~A~^, ~}"
				 (length syms) syms))
      (let ((internal (package-internal-symbols package))
	    (external (package-external-symbols package)))
	(dolist (sym syms)
	  (add-symbol internal sym)
	  (nuke-symbol external (symbol-name sym)))))
    t))

;;; Check for name conflict caused by the import and let the user
;;; shadowing-import if there is.
(defun import (symbols &optional (package (sane-package)))
  #!+sb-doc
  "Make Symbols accessible as internal symbols in Package. If a symbol
  is already accessible then it has no effect. If a name conflict
  would result from the importation, then a correctable error is signalled."
  (let* ((package (find-undeleted-package-or-lose package))
	 (symbols (symbol-listify symbols))
	 (homeless (remove-if #'symbol-package symbols))
	 (syms ())
	 (cset ()))
    (dolist (sym symbols)
      (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
	(cond ((not w)
	       (let ((found (member sym syms :test #'string=)))
		 (if found
		     (when (not (eq (car found) sym))
		       (push sym cset))
		     (push sym syms))))
	      ((not (eq s sym)) (push sym cset))
	      ((eq w :inherited) (push sym syms)))))
    (with-single-package-locked-error ()
      (when (or homeless syms cset)
	(let ((union (delete-duplicates (append homeless syms cset))))
	  (assert-package-unlocked package "importing symbol~P ~{~A~^, ~}" 
				   (length union) union)))
      (when cset
	;; ANSI specifies that this error is correctable.
	(with-simple-restart
	    (continue "Import these symbols with Shadowing-Import.")
	  (error 'simple-package-error
		 :package package
		 :format-control
		 "Importing these symbols into the ~A package ~
		causes a name conflict:~%~S"
		 :format-arguments (list (package-%name package) cset))))
      ;; Add the new symbols to the internal hashtable.
      (let ((internal (package-internal-symbols package)))
	(dolist (sym syms)
	  (add-symbol internal sym)))
      ;; If any of the symbols are uninterned, make them be owned by Package.
      (dolist (sym homeless)
	(%set-symbol-package sym package))
      (shadowing-import cset package))))

;;; If a conflicting symbol is present, unintern it, otherwise just
;;; stick the symbol in.
(defun shadowing-import (symbols &optional (package (sane-package)))
  #!+sb-doc
  "Import Symbols into package, disregarding any name conflict. If
  a symbol of the same name is present, then it is uninterned.
  The symbols are added to the Package-Shadowing-Symbols."
  (let* ((package (find-undeleted-package-or-lose package))
	 (internal (package-internal-symbols package))
	 (symbols (symbol-listify symbols))
	 (lock-asserted-p nil))
    (with-single-package-locked-error ()
      (dolist (sym symbols)
	(multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
	  (unless (or lock-asserted-p 
		      (and (eq s sym) 
			   (member s (package-shadowing-symbols package))))
	    (assert-package-unlocked package "shadowing-importing symbol~P ~
                                           ~{~A~^, ~}" (length symbols) symbols)
	    (setf lock-asserted-p t))
	  (unless (and w (not (eq w :inherited)) (eq s sym))
	    (when (or (eq w :internal) (eq w :external))
	      ;; If it was shadowed, we don't want UNINTERN to flame out...
	      (setf (package-%shadowing-symbols package)
		    (remove s (the list (package-%shadowing-symbols package))))
	      (unintern s package))
	    (add-symbol internal sym))
	  (pushnew sym (package-%shadowing-symbols package))))))
  t)

(defun shadow (symbols &optional (package (sane-package)))
  #!+sb-doc
  "Make an internal symbol in Package with the same name as each of the
  specified symbols, adding the new symbols to the Package-Shadowing-Symbols.
  If a symbol with the given name is already present in Package, then
  the existing symbol is placed in the shadowing symbols list if it is
  not already present."
  (let* ((package (find-undeleted-package-or-lose package))
	 (internal (package-internal-symbols package))
	 (symbols (string-listify symbols))
	 (lock-asserted-p nil))
    (flet ((present-p (w)
	     (and w (not (eq w :inherited)))))
      (with-single-package-locked-error ()
	(dolist (name symbols)
	  (multiple-value-bind (s w) (find-symbol name package)
	    (unless (or lock-asserted-p 
			(and (present-p w)
			     (member s (package-shadowing-symbols package))))
	      (assert-package-unlocked package "shadowing symbol~P ~{~A~^, ~}"
				       (length symbols) symbols)
	      (setf lock-asserted-p t))
	    (unless (present-p w)
	      (setq s (make-symbol name))
	      (%set-symbol-package s package)
	      (add-symbol internal s))
	    (pushnew s (package-%shadowing-symbols package)))))))
  t)

;;; Do stuff to use a package, with all kinds of fun name-conflict checking.
(defun use-package (packages-to-use &optional (package (sane-package)))
  #!+sb-doc
  "Add all the Packages-To-Use to the use list for Package so that
  the external symbols of the used packages are accessible as internal
  symbols in Package."
  (let ((packages (package-listify packages-to-use))
	(package (find-undeleted-package-or-lose package)))

    ;; Loop over each package, USE'ing one at a time...
    (with-single-package-locked-error ()
      (dolist (pkg packages)
	(unless (member pkg (package-%use-list package))
	  (assert-package-unlocked package "using package~P ~{~A~^, ~}"
				   (length packages) packages)
	  (let ((cset ())
		(shadowing-symbols (package-%shadowing-symbols package))
		(use-list (package-%use-list package)))
	  
	    ;;   If the number of symbols already accessible is less than the
	    ;; number to be inherited then it is faster to run the test the
	    ;; other way. This is particularly valuable in the case of
	    ;; a new package USEing Lisp.
	    (cond
	      ((< (+ (package-internal-symbol-count package)
		     (package-external-symbol-count package)
		     (let ((res 0))
		       (dolist (p use-list res)
			 (incf res (package-external-symbol-count p)))))
		  (package-external-symbol-count pkg))
	       (do-symbols (sym package)
		 (multiple-value-bind (s w)
		     (find-external-symbol (symbol-name sym) pkg)
		   (when (and w (not (eq s sym))
			      (not (member sym shadowing-symbols)))
		     (push sym cset))))
	       (dolist (p use-list)
		 (do-external-symbols (sym p)
		   (multiple-value-bind (s w)
		       (find-external-symbol (symbol-name sym) pkg)
		     (when (and w (not (eq s sym))
				(not (member (find-symbol (symbol-name sym)
							  package)
					     shadowing-symbols)))
		       (push sym cset))))))
	      (t
	       (do-external-symbols (sym pkg)
		 (multiple-value-bind (s w)
		     (find-symbol (symbol-name sym) package)
		   (when (and w (not (eq s sym))
			      (not (member s shadowing-symbols)))
		     (push s cset))))))

	    (when cset
	      (cerror
	       "Unintern the conflicting symbols in the ~2*~A package."
	       "Using package ~A results in name conflicts for these symbols:~%~
                ~S"
	       (package-%name pkg) cset (package-%name package))
	      (dolist (s cset) (moby-unintern s package))))

	  (push pkg (package-%use-list package))
	  (push (package-external-symbols pkg) (cdr (package-tables package)))
	  (push package (package-%used-by-list pkg))))))
  t)

(defun unuse-package (packages-to-unuse &optional (package (sane-package)))
  #!+sb-doc
  "Remove PACKAGES-TO-UNUSE from the USE list for PACKAGE."
  (let ((package (find-undeleted-package-or-lose package))
	(packages (package-listify packages-to-unuse)))
    (with-single-package-locked-error ()
      (dolist (p packages)
	(when (member p (package-use-list package))
	  (assert-package-unlocked package "unusing package~P ~{~A~^, ~}"
				   (length packages) packages))
	(setf (package-%use-list package)
	      (remove p (the list (package-%use-list package))))
	(setf (package-tables package)
	      (delete (package-external-symbols p)
		      (the list (package-tables package))))
	(setf (package-%used-by-list p)
	      (remove package (the list (package-%used-by-list p))))))
    t))

(defun find-all-symbols (string-or-symbol)
  #!+sb-doc
  "Return a list of all symbols in the system having the specified name."
  (let ((string (string string-or-symbol))
	(res ()))
    (maphash (lambda (k v)
	       (declare (ignore k))
	       (multiple-value-bind (s w) (find-symbol string v)
		 (when w (pushnew s res))))
	     *package-names*)
    res))

;;;; APROPOS and APROPOS-LIST

(defun briefly-describe-symbol (symbol)
  (fresh-line)
  (prin1 symbol)
  (when (boundp symbol)
    (write-string " (bound)"))
  (when (fboundp symbol)
    (write-string " (fbound)")))

(defun apropos-list (string-designator
		     &optional
		     package-designator
		     external-only)
  #!+sb-doc
  "Like APROPOS, except that it returns a list of the symbols found instead
  of describing them."
  (if package-designator
      (let ((package (find-undeleted-package-or-lose package-designator))
	    (string (stringify-name string-designator "APROPOS search"))
	    (result nil))
	(do-symbols (symbol package)
	  (when (and (eq (symbol-package symbol) package)
		     (or (not external-only)
			 (eq (nth-value 1 (find-symbol (symbol-name symbol)
						       package))
			     :external))
		     (search string (symbol-name symbol) :test #'char-equal))
	    (push symbol result)))
	result)
      (mapcan (lambda (package)
		(apropos-list string-designator package external-only))
	      (list-all-packages))))

(defun apropos (string-designator &optional package external-only)
  #!+sb-doc
  "Briefly describe all symbols which contain the specified STRING.
  If PACKAGE is supplied then only describe symbols present in
  that package. If EXTERNAL-ONLY then only describe
  external symbols in the specified package."
  ;; Implementing this in terms of APROPOS-LIST keeps things simple at the cost
  ;; of some unnecessary consing; and the unnecessary consing shouldn't be an
  ;; issue, since this function is is only useful interactively anyway, and
  ;; we can cons and GC a lot faster than the typical user can read..
  (dolist (symbol (apropos-list string-designator package external-only))
    (briefly-describe-symbol symbol))
  (values))

;;;; final initialization

;;;; The cold loader (GENESIS) makes the data structure in
;;;; *!INITIAL-SYMBOLS*. We grovel over it, making the specified
;;;; packages and interning the symbols. For a description of the
;;;; format of *!INITIAL-SYMBOLS*, see the GENESIS source.

(defvar *!initial-symbols*)

(!cold-init-forms

  (setq *in-package-init* t)

  (/show0 "about to loop over *!INITIAL-SYMBOLS* to make packages")
  (dolist (spec *!initial-symbols*)
    (let* ((pkg (apply #'make-package (first spec)))
	   (internal (package-internal-symbols pkg))
	   (external (package-external-symbols pkg)))
      (/show0 "back from MAKE-PACKAGE, PACKAGE-NAME=..")
      (/primitive-print (package-name pkg))

      ;; Put internal symbols in the internal hashtable and set package.
      (dolist (symbol (second spec))
	(add-symbol internal symbol)
	(%set-symbol-package symbol pkg))

      ;; External symbols same, only go in external table.
      (dolist (symbol (third spec))
	(add-symbol external symbol)
	(%set-symbol-package symbol pkg))

      ;; Don't set package for imported symbols.
      (dolist (symbol (fourth spec))
	(add-symbol internal symbol))
      (dolist (symbol (fifth spec))
	(add-symbol external symbol))

      ;; Put shadowing symbols in the shadowing symbols list.
      (setf (package-%shadowing-symbols pkg) (sixth spec))
      ;; Set the package documentation
      (setf (package-doc-string pkg) (seventh spec))))

  ;; FIXME: These assignments are also done at toplevel in
  ;; boot-extensions.lisp. They should probably only be done once.
  (/show0 "setting up *CL-PACKAGE* and *KEYWORD-PACKAGE*")
  (setq *cl-package* (find-package "COMMON-LISP"))
  (setq *keyword-package* (find-package "KEYWORD"))

  (/show0 "about to MAKUNBOUND *!INITIAL-SYMBOLS*")
  (makunbound '*!initial-symbols*)       ; (so that it gets GCed)

  ;; Make some other packages that should be around in the cold load.
  ;; The COMMON-LISP-USER package is required by the ANSI standard,
  ;; but not completely specified by it, so in the cross-compilation
  ;; host Lisp it could contain various symbols, USE-PACKAGEs, or
  ;; nicknames that we don't want in our target SBCL. For that reason,
  ;; we handle it specially, not dumping the host Lisp version at
  ;; genesis time..
  (aver (not (find-package "COMMON-LISP-USER")))
  ;; ..but instead making our own from scratch here.
  (/show0 "about to MAKE-PACKAGE COMMON-LISP-USER")
  (make-package "COMMON-LISP-USER"
		:nicknames '("CL-USER")
		:use '("COMMON-LISP"
		       ;; ANSI encourages us to put extension packages
		       ;; in the USE list of COMMON-LISP-USER.
		       "SB!ALIEN" "SB!ALIEN" "SB!DEBUG"
		       "SB!EXT" "SB!GRAY" "SB!PROFILE"))

  ;; Now do the *!DEFERRED-USE-PACKAGES*.
  (/show0 "about to do *!DEFERRED-USE-PACKAGES*")
  (dolist (args *!deferred-use-packages*)
    (apply #'use-package args))

  ;; The Age Of Magic is over, we can behave ANSIly henceforth.
  (/show0 "about to SETQ *IN-PACKAGE-INIT*")
  (setq *in-package-init* nil)

  ;; For the kernel core image wizards, set the package to *CL-PACKAGE*.
  ;;
  ;; FIXME: We should just set this to (FIND-PACKAGE
  ;; "COMMON-LISP-USER") once and for all here, instead of setting it
  ;; once here and resetting it later.
  (setq *package* *cl-package*))

(!cold-init-forms
  (/show0 "done with !PACKAGE-COLD-INIT"))

(!defun-from-collected-cold-init-forms !package-cold-init)