1;-*- Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Base:10; Fonts:(CPTFONT CPTFONTB); Cold-Load:T -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.

;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151

;;; Copyright (C) 1986-1989 Texas Instruments Incorporated. All rights reserved.*

;1;; NOMENCLATURE: *
;1;;*
;1;; Let <s> denote a symbol and <p> a package object [so that (symbolp <s>)=> t and*
;1;; (packagep <p>)=>t.]*
;1;; Then*
;1;;   <s> is PRESENT in <p> iff *
;1;;                               (MULTIPLE-VALUE-BIND (sym type)*
;1;;                                     (FIND-SYMBOL <s> <p>)*
;1;;                                 (AND (eq <s> sym) (or (eq type :internal)(eq type :external))))*
;1;;   <s> is ACCESSIBLE in <p> iff*
;1;;                               (MULTIPLE-VALUE-BIND (sym type)*
;1;;                                     (FIND-SYMBOL <s> <p>)*
;1;;                                 (AND (eq <s> sym) type))*
;1;;      note: the condition for <s> to be accessible in <p> cannot be simplified to*
;1;;            (eq <s> (find-symbol <s> <p>))*
;1;;   For taking <s> to be NIL and <p> a package not USING the Lisp package, the above would be true*
;1;;   and yet NIL would not be accessible from <p>.*
;1;;*
;1;;   <s> is an EXTERNAL SYMBOL of <p> iff*
;1;;                               (MULTIPLE-VALUE-BIND (sym type)*
;1;;                                     (FIND-SYMBOL <s> <p>)*
;1;;                                 (AND (eq <s> sym) (eq type :external)))*
;1;;   <s> is an INTERNAL SYMBOL of <p> iff*
;1;;                               (MULTIPLE-VALUE-BIND (sym type)*
;1;;                                     (FIND-SYMBOL <s> <p>)*
;1;;                                 (AND (eq <s> sym) (or (eq type :internal)(eq type :inherited))))*
;1;;   <s> is INHERITED by <p> if*
;1;;                               (MULTIPLE-VALUE-BIND (sym type)*
;1;;                                     (FIND-SYMBOL <s> <p>)*
;1;;                                 (AND (eq <s> sym) (eq type :inherited)))*
;1;;  In brief, <s> is PRESENT in <p> if <s> has an entry in the symbol table of <p>. Symbols*
;1;;  present are either INTERNAL, by default, or EXTERNAL. A symbol present in <p> is made*
;1;;  external by EXPORTING the symbol. A symbol <s> is ACCESSIBLE in <p> if either it is present*
;1;;  in <p> or INHERITED. A symbol is inherited by <p> if it is an external symbol*
;1;;  some package <q> used by <p>; However the symbol is not an external symbol of <p>.*
;1;;*
;1;;  A symbol is NOT ACCESSIBLE to <p> iff*
;1;;                               (MULTIPLE-VALUE-BIND (sym type)*
;1;;                                     (FIND-SYMBOL <s> <p>)*
;1;;                                 (OR (NOT (eq <s> sym)) (NOT type)))*
;1;;      If (NOT type) then no symbol with the same name as <s> is accessible to <p>.*
;1;;      However, when (NOT (eq <s> sym)), then such a symbol exists. A NAME CONFLICT is a*
;1;;      condition that arises during certain package operations when there is an attempt*
;1;;      to make a symbol <s> accessible to <p> and there exists a symbol <u> already accessible*
;1;;      to <p> with the same name:*
;1;;                               (MULTIPLE-VALUE-BIND (<u> type)*
;1;;                                     (FIND-SYMBOL <s> <p>)*
;1;;                                 (AND type (NOT (eq <s> <u>))))*
;1;;  *
;1;;  5) <s> SHADOWS a symbol <s1> in <p> if <s1> would be accessible in <p> were it not for*
;1;;     <s>. Note <s> must be present in <p>.*

;;;Record of changes:
;;; 08/26/88   clm   Changed ALTER-PACKAGE to call PKG-FIND-PACKAGE instead of FIND-PACKAGE
;;;                  so that a better error message is given in case an undefined package
;;;                  is given for the :USE argument when calling IN-PACKAGE [spr 7901].
;;; 09/15/88   clm   Fixed UNINTERN to decrement the symbol count when uninterning a symbol.
;;;                  Done to prevent symbol table from becoming larger than necessary
;;;                  (sprs 8724 and 8661).
;;; 02/27/89   jlm   Changed PACKAGE-REHASH to rehash in same area as orig package.



1;;; Package Objects
;;; A package object is an instance of the structure define below. 
;;; Each of its slots is prefixed with PACK-, e.g. 'PACK-NAME'.
;;; The most important slots include the symbol table which defines the*
;1;; symbols 'present' in the package and the use-list which defines the*
;1;; symbols 'inheritable' by the package.*

(DEFSTRUCT (PACKAGE
	     (:CONSTRUCTOR INTERNAL-MAKE-PACKAGE)
	     (:callable-constructors nil)
	     (:CONC-NAME pack-)
	     (:predicate packagep)
	     (:copier nil)
	     )
  NAME						9; Official name (a string).*
  (NICKNAMES nil :type list)			1; List of nicknames (strings)*
  SYMBOL-TABLE					1; a two-dimensional ART-Q array whose organization is described below*
  PREFIX-NAME					1; prefix to be used in printing symbols in this package*
  (NUMBER-OF-SYMBOLS 0 :type fixnum)		1; Current number of symbols.*
  MAX-NUMBER-OF-SYMBOLS				1; Threshold for rehashing.*
  ALL-PACKAGES-POINTER				1; Pointer to the symbol *package-hash-table**
  USE-LIST					1; Packages this one has done USE-PACKAGE to.*
  USED-BY-LIST					1; Packages that have done USE-PACKAGE to this one.*
  (SHADOWING-SYMBOLS nil :type list)		1; List of symbols explicitly shadowed in this package.*
  INTERN-AREA					1; area where symbols interned in this package are to be stored*
  PLIST
  STORE-FUNCTION1        ; for special applications -- a Function called to store a new symbol in this package.*
  AFTER-INTERN-DAEMON     1; for special applications -- a function called immediately after interning. See*
                         1; EXTERNALIZE-ALL-SYMBOLS used by the keyword package*
  AUTO-EXPORT-P1         ; Non-NIL means this package EXPORTs all symbols put in it.*
  )



1;;; THE PACKAGE HASH TABLE
;;; package definitions are stored in the package hash table each entry of which is an alist binding*
;1;; string objects to package objects (i.e. ( string .  package-object) ).*

(EVAL-WHEN (compile)
   (Defmacro PACKAGE-HASH-FUNCTION (string) `(REM (SYS:%SXHASH-STRING ,string #xFF)  *package-hash-table-size*))
   )

(Defun LIST-ALL-PACKAGES () 
1   "return a list of all packages in the system"*
   (LET (list-of-packages)
      (DOTIMES (index *package-hash-table-size* list-of-packages)
	 (DOLIST (item (AREF *package-hash-table* index))
	    (PUSHNEW (CDR item) list-of-packages :test #'EQ)))))

(Defun FIND-PACKAGE (object ) 
1  "Return the package object whose name or one of whose nicknames is <object> which
can be a symbol, a (case-sensitive) string or a package object.  If no such package 
exists, NIL is returned."*
  (IF (PACKAGEP object) object
      (LET* ((string (STRING object))
	     (bucket (AREF *package-hash-table* (PACKAGE-HASH-FUNCTION string ))))
	(CDR (ASSOC string bucket :test #'EQUAL)))))

;1; macros needed by make-package*

(EVAL-WHEN (compile)
  (Defmacro SYMBOL-STRING-TO-HASH (string) `(SYS:%SXHASH-STRING ,string #xFF))
  
  (Defmacro SHORTEST-NAME-OR-NICKNAME (pkg)
    `(LET ((shortest-name (PACK-NAME ,pkg)))
       (DOLIST (nick (PACK-NICKNAMES ,pkg) shortest-name)
	 (IF (AND
	       (NOT (EQUAL nick ""))
	       (< (LENGTH nick) (LENGTH shortest-name)))
	     (SETQ shortest-name nick)))))
  )



1;;; package objects are created using the following:*
(Defun MAKE-PACKAGE (name &KEY
		     nicknames
		     (use '("LISP" "TICL"))
		     (size 200)
		     shadow
		     export
		     prefix-name 
		     auto-export-p 
		     import 
		     (area SYS:NR-SYM)
		     shadowing-import 
		     plist
		     store-function
		     after-intern-daemon
		     )
  
1  "Creates and returns a package object named <name>.  The name must be 
distinct from the names and nicknames for all existing packages or an 
error will result. The keyword arguments are as follows:
1) :USE specifies a list of names of packages for this one to use. 
   (see USE-PACKAGE).
2) :NICKNAMES specifies a list of nicknames for this package.  The nicknames
   must be distinct from the names and nicknames of all existing packages.
3) :SHADOW specifies a list of names of symbols to shadow in this package
   (see SHADOW).
4) :EXPORT specifies a list of names of symbols to export in this package
   (see EXPORT).
5) :IMPORT specifies a list of symbols to import in this package
   (see IMPORT).
6) :SHADOWING-IMPORT specifies a list of symbols to import in this package,
    overriding any name conflicts (see SHADOWING-IMPORT).
7) :PREFIX-NAME specifies the name to be used when printing the symbols.  
   This MUST be a name or nickname of the package.
8) :AUTO-EXPORT-P non-NIL specifies that all symbols placed in this package
   should be exported automatically at that time.
9) :SIZE specifies the number of symbols to allocate space for initially."*
 
  (LET ((pkg (INTERNAL-MAKE-PACKAGE  :all-packages-pointer *PACKAGE-HASH-TABLE*
				     :number-of-symbols 0
				     :max-number-of-symbols size))
	success)
    (UNWIND-PROTECT      ;1; set unwind-protect in case we must kill package object just created*
	(PROGN
	  (WITHOUT-INTERRUPTS 
	    (SETF (PACK-NAME pkg) (ENTER-STRING-INTO-TABLE name pkg))
	    (SETF (PACK-NICKNAMES pkg) 
		  (LET (new-list)
		    (DOLIST (item (IF (LISTP nicknames ) nicknames (LIST nicknames)) (NREVERSE (the list new-list)))
		      (PUSH (ENTER-STRING-INTO-TABLE item pkg) new-list)))))
	  ;; determine a prefix name -- used by the printer/dumper/loader
	  (LET ((prefix  
		  (IF (AND 
			prefix-name
			(OR (MEMBER prefix-name (PACK-NICKNAMES pkg) :test #'string=)
			    (STRING= prefix-name name)))
		      prefix-name
		      (SHORTEST-NAME-OR-NICKNAME pkg))))
			
	  (SETF (PACK-PREFIX-NAME pkg) prefix
		(PACK-SYMBOL-TABLE pkg) (MAKE-ARRAY (LIST (GET-GOOD-PACKAGE-SIZE size) 2) :AREA pkg-area)
		(PACK-PLIST pkg) plist
		(PACK-INTERN-AREA pkg) (COND ((AND (NUMBERP area) 
						   (<= 0 area (SYMBOL-VALUE (CAR (LAST area-list))))) 
					      area)
					     ((MEMBER area area-list :test #'EQ) 
					      (SYMBOL-VALUE area))
					     ((SYMBOLP area)  
					      (MAKE-AREA :NAME area :REPRESENTATION :structure) (SYMBOL-VALUE area))
					     (t (ERROR t "2area keyword argument ~s is invalid"* area))))
	  )
	  (IF (AND auto-export-p (NOT after-intern-daemon))
	      (SETF (PACK-AUTO-EXPORT-P pkg) auto-export-p
		    (PACK-AFTER-INTERN-DAEMON pkg) 'externalize-all-symbols)
	      (WHEN auto-export-p
		(ERROR t "in making package ~a--autoexport slot uses after-intern-daemon slot" name)))

	  (WHEN store-function
	    (SETF (PACK-STORE-FUNCTION pkg) store-function))
	  (WHEN after-intern-daemon
	    (SETF (PACK-AFTER-INTERN-DAEMON pkg) after-intern-daemon))

	  (WHEN shadow (SHADOW shadow pkg))
	  (WHEN shadowing-import (SHADOWING-IMPORT shadowing-import pkg))
	  (WHEN import (IMPORT import pkg))
	  (WHEN export
	    (dolist (x (if (listp export) export (list export)))
	      (EXPORT (if (stringp x) (intern x pkg) x) pkg)))	
	  (WHEN use (USE-PACKAGE use pkg))
	  (SETQ success t)
	  pkg)
      (UNLESS success
	(KILL-PACKAGE pkg))
      )))


;; the following are helper functions for make-package

(Defun ENTER-STRING-INTO-TABLE (object pkg)
1;; the following procedure enters strings into the package hash table. It should be 
;; wrapped around "without-interrupts" to prevent two processes from attempting to 
;; create packages having a common name or nickname. Note that it binds the default-cons-area 
;; so that cons-cells and package names and nicknames are allocated in the package area. Hopefully
;; this should maximize locality.*
  
  (LET* ((DEFAULT-CONS-AREA pkg-area) 
	 (string (STRING object))
	 (bucket (PACKAGE-HASH-FUNCTION string))
	 (bucket-contents (AREF *package-hash-table* bucket)))
	(IF (ASSOC string bucket-contents :test #'EQUAL) 
	    (ERROR nil "~a is the name or nickname of package ~a" string (CDR (ASSOC string bucket-contents :test #'EQUAL)))
	    (SETF (AREF *package-hash-table* bucket) (CONS (CONS string pkg) bucket-contents)))
	string))

;;AB 8/3/87.  Small efficiency improvement. [SPR 5256]
(Defun REMOVE-STRINGS-FROM-TABLE (name nicknames pkg)
1;; this is used to remove a package name and  nicknames from the package hash table 
;;   - it should be wrapped around a "without-interrupts".*
  (DOLIST (name (CONS name nicknames))
    (LET ((string (CATCH-ERROR (STRING name))))  ;;be careful---an invalid package name may be the reason we are here
      (IF string
	  (LET* ((hash (PACKAGE-HASH-FUNCTION string))
		 (bucket (AREF *package-hash-table*  hash)))
	    (SETF (AREF *package-hash-table* hash )
		  (DELETE `(,string . ,pkg) (THE list bucket) :test #'EQUAL :count 1)))
	  (RETURN-FROM REMOVE-STRINGS-FROM-TABLE (VALUES))))))

(DEFCONSTANT PKG-GOOD-SIZES
  '(67 73 83 97 113 131 149 163 179 193 223 239 251 269 283 293 307 317 337 359 383 409 433 457 487 
       521 547 577 613 643 677 719 751 787 827 863 877 919 967 1009 1051 1087 1113 1171 1213 1259 1319 
       1373 1433 1489 1553 1619 1693 1759 1823 1889 1973 2039 2113 2179 2251 2333 2411 2503 2591 2689 
       2777 2879 2999 3109 3187 3299 3407 3511 3637 3761 3889 4019 4159 4289 4481 4691 4931 5147 5347 
       5569 5827 6089 6353 6619 6883 7177 7477 7789 8111 8419 8707 9091 9473 9923 10369 10831 11273 11777 
       12373 12941 13513 14081 14657 15233 15877 16519 17239 17921 18637 19403 20161 21001 21767 22531 
       23297 24071 24967 25867 26759 27653 28547))

;1;4/11/88 clm for phd: change the constant from 1.25 to 1.67 [spr 7697].  We*
;1;were getting too many collisions on package references.*
(Defun GET-GOOD-PACKAGE-SIZE (number-of-symbols)
1;; given the size option <size> to make-package , this procedure determines the actual size of the 
;; symbol table and is approximately (5/4)*size .*
  (LET ((tem (CEILING (* number-of-symbols 1.67s0))))	1;Allow hash table to become 60% full.*
       (OR 
	 (DOLIST (size PKG-GOOD-SIZES)
		 (AND (> size tem) (RETURN size)))
	 1;; Beyond the list of good sizes => avoid multiples of small primes.*
	 (DO ((n (+ tem 1 (REM tem 2)) (+ n 2)))
	     ((NOT (OR (ZEROP (REM n 3))
		       (ZEROP (REM n 5))
		       (ZEROP (REM n 7))
		       (ZEROP (REM n 11.))))
	      n)))))



(Defun PACKAGE-DOES-NOT-EXIST-ERROR (name &OPTIONAL create-it?)
  (IF create-it?
      (WHEN (Y-OR-N-P 1"~&Package ~A does not exist. Do you want to create it?"* name)
	    (MAKE-PACKAGE name))
      (ERROR t 1"~a is neither the name nor the nickname of any package~%"* name)))

1;;; Code outside of this file should use the following accessors since 
;;;    1) they require a package argument
;;; and 2) to avoid compile-time dependency on package structures.*

(Defun PACKAGE-NAME (pkg)
1  "Returns the name of the specified package."*
   (WITH-PACKAGE-OBJECT (pkg) (PACK-NAME pkg)))

(Defun PACKAGE-PREFIX-PRINT-NAME (pkg) 
1  "Returns the name of the specified package for printing package prefixes."*
   (WITH-PACKAGE-OBJECT (pkg) (PACK-PREFIX-NAME pkg)))

(Defun PACKAGE-NICKNAMES (pkg)
1  "Returns the list of nicknames (as strings) of the specified package.
The package's name is not included."*
   (WITH-PACKAGE-OBJECT (pkg) (PACK-NICKNAMES pkg)))

(Defun PACKAGE-USE-LIST (pkg)
1  "Returns the list of packages (not names) USEd by specified package."*
   (WITH-PACKAGE-OBJECT (pkg) (PACK-USE-LIST pkg)))
 
(Defun PACKAGE-USED-BY-LIST (pkg)
1  "Returns the list of packages (not names) that USE the specified package."*
   (WITH-PACKAGE-OBJECT (pkg) (PACK-USED-BY-LIST pkg)))

(Defun PACKAGE-AUTO-EXPORT-P (pkg)
1  "Returns T if PKG automatically exports all symbols inserted in it."*
   (WITH-PACKAGE-OBJECT (pkg) (PACK-AUTO-EXPORT-P pkg)))

(Defun PACKAGE-SHADOWING-SYMBOLS (pkg)
1  "Returns the list of symbols explicitly shadowed in the specified package."*
   (WITH-PACKAGE-OBJECT (pkg) (PACK-SHADOWING-SYMBOLS pkg)))


;;AB 8/12/87.  Fix PKG-SHORTEST-NAME always to return a string.  [SPR 6186]
(Defun PKG-SHORTEST-NAME (pkg) 
1  "Returns a string which is the shortest of PKG's name and nicknames."*
   (WITH-PACKAGE-OBJECT (pkg)
     (STRING (PACKAGE-PREFIX-PRINT-NAME pkg))))

(Defun SET-PKG-AFTER-INTERN-DAEMON (pkg fct)
  ;; a hack used for destroying the after-intern-daemon in pkg-initialize
  (WITH-PACKAGE-OBJECT (pkg) (SETF (PACK-AFTER-INTERN-DAEMON pkg) fct)))


;;CLM for PHD 9/9/87 Fixed enter-string-into-table so we can duplicate the nicknames
;;in a call to RENAME-PACKAGE for a given package.
(Defun RENAME-PACKAGE (pkg new-name &OPTIONAL new-nicknames)
  1"Change the name(s) of a package."*
  (with-package-object (pkg)
    (setq new-nicknames (if (listp new-nicknames)
			    (mapcar #'string new-nicknames)
			    (list (string new-nicknames)))
	  new-name (string new-name))
    (without-interrupts
      (let ((tem (find-package new-name)))
	(when (and tem (neq tem pkg))
	  (error nil "A package named ~A already exists." new-name)))
      (dolist (nick new-nicknames)
	(let ((tem (find-package nick)))
	  (when (and tem (neq tem pkg))
	    (error nil "A package named ~A already exists." nick))))
      (remove-strings-from-table (pack-name pkg) (pack-nicknames pkg) pkg)
      (do-all-packages (pack)
	(when (member (pack-name pkg) (pack-use-list pack) :test #'eq)
	  (nsubstitute pkg pack (pack-use-list pack))))
      (setf (pack-name pkg) (enter-string-into-table new-name pkg))
      (setf (pack-nicknames pkg)
	    (let (new-list)
	      (dolist (nick (remove-duplicates (the list new-nicknames)
					       :test #'equal)
			    (nreverse (the list new-list)))
		(push (enter-string-into-table nick pkg) new-list))))
      (setf (pack-prefix-name pkg) new-name)
      pkg)))

(Defun KILL-PACKAGE (PKG)
  1"Kill a package."*
  (WITH-PACKAGE-OBJECT (pkg)
    (DOLIST (p (PACK-USE-LIST pkg))
      (UNUSE-PACKAGE-1 p pkg))
    (DOLIST (p (PACK-USED-BY-LIST pkg))
      (UNUSE-PACKAGE-1 pkg p))
    (WITHOUT-INTERRUPTS
      (REMOVE-STRINGS-FROM-TABLE (PACK-NAME pkg) (PACK-NICKNAMES pkg) pkg))))

;;CLM for PHD 9/9/87 Fixed in-package so it augments the use-list and nickname-list instead of replacing it.
(Defun IN-PACKAGE (name &REST options &key use nicknames &allow-other-keys)
  (DECLARE (arglist name &KEY nicknames (use '("LISP" "TICL")) (size 200) shadow export prefix-name auto-export-p
		    import (area sys:nr-sym) shadowing-import plist store-function after-intern-daemon))
  (LET ((pkg (FIND-PACKAGE name)))
    (SETQ *package*
	  (IF pkg
	      (PROGN
		(WHEN (PACK-AUTO-EXPORT-P pkg)
		  (ERROR nil "Package ~A is auto-exporting; it should not be the current package." pkg))
		(IF options 
		    (APPLY #'ALTER-PACKAGE name
			   :use
			   (append (package-use-list pkg)
				   (if (listp use)
				       use
				       (list use)))
			   :nicknames
			   (append (package-nicknames pkg)
				   (if (listp nicknames)
				       nicknames
				       (list nicknames)))
				   options)
		    pkg))
	      (APPLY #'MAKE-PACKAGE name options)))))


1;;;  Nobody should be using this any more.  We should be able to remove it soon (JK).*
(Defun CHECK-FOR-NAME-CONFLICT (string pkg &optional
				not-local-symbols additional-symbol additional-symbol-package
				additional-used-packages)
  (let (candidates shadowed-explicitly-flag)
    (unless not-local-symbols
      (multiple-value-bind (s foundp)
	  (FIND-SYMBOL-LOCALLY string pkg)
	(when foundp
	  (if (MEMBER s (PACK-SHADOWING-SYMBOLS pkg) :test #'EQ)
	      (setq shadowed-explicitly-flag t)
	    (push (list (PACK-NAME pkg) pkg s) candidates)))))
    (unless shadowed-explicitly-flag
      (when (and additional-symbol
		 (dolist (elt candidates t)
		   (when (eq (caddr elt) additional-symbol) (return nil))))
	(push (list (PACK-NAME additional-symbol-package)
		    additional-symbol-package additional-symbol)
	      candidates))
      (dolist (p (PACK-USE-LIST pkg))
	(multiple-value-bind (s foundp)
	    (FIND-SYMBOL-LOCALLY string p)
	  (when (eq foundp :external)
	    (dolist (elt candidates t)
	      (when (eq (caddr elt) s) (return nil)))
	    (push (list (PACK-NAME p) p s) candidates))))
      (dolist (p additional-used-packages)
	(multiple-value-bind (s foundp)
	    (FIND-SYMBOL-LOCALLY string p)
	  (when (eq foundp :external)
	    (dolist (elt candidates t)
	      (when (eq (caddr elt) s) (return nil)))
	    (push (list (PACK-NAME p) p s) candidates))))
      (and (cdr candidates)
	   candidates))))

1;;;  Nobody should be using this any more.  We should be able to remove it soon (JK).*
(DEFPROP REPORT-NAME-CONFLICT T :ERROR-REPORTER)
(Defun REPORT-NAME-CONFLICT (SYMBOL PKG AVAILABLE-SYMS)
  (CERROR :NO-ACTION NIL 'SYMBOL-NAME-CONFLICT
	  "UNINTERN of ~1G~S from package ~A causing discovered name conflict.
Symbols from packages ~A all want to be inherited."
	  (LIST (LIST SYMBOL PKG AVAILABLE-SYMS))
	  SYMBOL PKG (MAPCAR 'CAR AVAILABLE-SYMS))
  (LET* ((DESIRED-PKG (PROMPT-AND-READ :STRING "~&Type the name of the package whose symbol you want ~A to contain: " PKG))
	 (ELT (ASSOC DESIRED-PKG AVAILABLE-SYMS)))
    (VALUES (CADR elt) (CADDR elt))))


(Defun FIND-ALL-SYMBOLS (string)
  1"Returns a list of all symbols in any packages whose names match STRING, counting case."*
  (LET (accum)
    (DO-ALL-PACKAGES (pkg accum)
      (MULTIPLE-VALUE-BIND (sym foundp)
	  (FIND-SYMBOL-LOCALLY string pkg)
	(WHEN foundp (PUSHNEW sym accum))))))

(defun mapatoms (function &optional (pkg *package*) (inherited-p t))
  1"Apply <function> to each symbol in package <pkg>.  If <inherited-p>
is non-NIL, <function> is applied to each symbol accessible in <pkg>."*
  (if inherited-p
      (do-symbols (sym (pkg-find-package pkg))
        (funcall function sym))
      (do-local-symbols (sym (pkg-find-package pkg))
	(funcall function sym))))

(defun mapatoms-all (function &optional (top-pkg *ticl-package*))
  1"Apply <function> to each symbol in <top-pkg> and all packages that USE it.
<top-pkg> defaults to TICL.  Packages USEd by <top-pkg> are not included."*
  (setq top-pkg (pkg-find-package top-pkg))
  (dolist (pkg (cons top-pkg (pack-used-by-list top-pkg)))
    (do-local-symbols (sym pkg)
      (funcall function sym))))

(Defun WHERE-IS (PNAME &OPTIONAL UNDER-PKG
		 &AUX FOUND-IN-PKG FROM-PKGS RETURN-LIST TABLE)
  "Find all symbols with a given pname, which packages they are in,
and which packages they are accessible from.
If UNDER-PKG is specified, search only packages inheriting from UNDER-PKG.
If PNAME is a string, it is converted to upper case."
  ;; Given a string, it should probably be uppercased.  But given a symbol copy it exactly.
  (SETQ PNAME (IF (STRINGP PNAME) (STRING-UPCASE PNAME) (STRING PNAME)))
  (FORMAT T "~&")
  ;; Each entry in TABLE is (from-pkg found-in-pkg).  Highest package first.
  (DOLIST (PKG (IF UNDER-PKG
		   (PACKAGE-USED-BY-LIST UNDER-PKG)
		 (list-all-packages)))
    (MULTIPLE-VALUE-BIND (SYM FOUND)
	(FIND-SYMBOL PNAME PKG)
      (COND (FOUND
	     (PUSH (LIST PKG (SYMBOL-PACKAGE SYM)) TABLE)
	     (OR (MEMBER SYM RETURN-LIST :test #'EQ) (PUSH SYM RETURN-LIST))))))
  (SETQ TABLE (NREVERSE TABLE))
  (IF (NULL TABLE) (FORMAT T "No symbols named ~S exist.~%" PNAME)
    (DO () ((NULL TABLE))
      (SETQ FOUND-IN-PKG (CADAR TABLE)
	    FROM-PKGS (SORT (MAPCAN #'(LAMBDA (X)
					(COND ((EQ (CADR X) FOUND-IN-PKG)
					       (SETQ TABLE (DELETE X (THE list TABLE) :test #'EQ :count 1))
					       (CONS (PACK-NAME (CAR X)) nil))))
				    TABLE)
			    #'STRING-LESSP))
      (FORMAT T "~A:~A is accessible from package~P ~{~<~%~10t~2:;~A~>~^, ~}~%"
	      (PACK-NAME FOUND-IN-PKG) PNAME (LENGTH FROM-PKGS) FROM-PKGS)))
  RETURN-LIST)

(Defun PKG-GOTO (&OPTIONAL (PKG PKG-USER-PACKAGE) GLOBALLY)	;Go to type-in package.
  "Set the current binding of *PACKAGE* to the package you specify (by name).
If GLOBALLY is non-NIL, then we do a PKG-GOTO-GLOBALLY as well."
  (CHECK-ARG PKG (OR (PACKAGEP PKG)(SYMBOLP PKG)(STRINGP PKG)) "a package or a package name")
  (LET ((PK (COND ((FIND-PACKAGE pkg))1   ;; at this point, <pkg> should be a package object*
		  (T (PACKAGE-DOES-NOT-EXIST-ERROR pkg)))))
    (WHEN (OR (PACK-AUTO-EXPORT-P pk) (EQ pk *keyword-package*))
      (ERROR NIL "Package ~A is auto-exporting; it should not be the current package." pk))
    (AND GLOBALLY (PKG-GOTO-GLOBALLY PK))
    (SETQ *PACKAGE* PK)))

(Defun PKG-GOTO-GLOBALLY (&OPTIONAL (PKG PKG-USER-PACKAGE))
  "Set the global binding of *PACKAGE* used by new lisp listeners
and by random processes that don't bind *PACKAGE*."
  (LET ((*PACKAGE* *PACKAGE*))			;do error check
    (SETQ PKG (PKG-GOTO PKG)))
  (SETQ-GLOBALLY *PACKAGE* PKG))


 


(EVAL-WHEN (compile)
  (Defmacro WHEN-SYMBOL-PRESENT ((pkg string hashcode word1 word0 &OPTIONAL (index (GENSYM))) &BODY body)
;1; this macro expands into code which searches for a symbol in <pkg> whose name matches <string>. *
;1; In the event a candidate symbol is located, words 0 and 1 of its symbol table entry are placed*
;1; into <word0> and <word1> respectively and the forms in <body> are executed.*
    `(LET* ((symtab (PACK-SYMBOL-TABLE ,pkg))  ;1; fetch the symbol table*
	    (length (P-NUMBER-OF-ENTRIES symtab))  ;1; compute length for hashing*
	    ,word0 ,word1)
       (DO ((,index (REM ,hashcode length)))
	   (())
	 ;1; exit will occur when an entry with a null word0 is encountered or *
	 ;1; possibly by code executed within <body>*
	 (IF (SETQ ,word0 (P-WORD0 symtab ,index)) 
	     (PROGN
	       (WHEN (AND
		       (P-ACTIVE-ENTRY ,word0)
		       (= ,hashcode (P-EXTRACT-CODE ,word0))
		       (EQUAL ,string  ;1; case-sensitive, font-sensitive comparison*
			      (SYMBOL-NAME (setq ,word1 (P-WORD1 symtab ,index)))))
		 ,@body
		 (RETURN))
	       (INCF ,index)   ;; faster than doing "(rem hashcode length)"
	       (WHEN (>= ,index length) (SETQ ,index 0)))
	     (RETURN))  ;1; else word0 is Nil -- terminate search.*
	 )))
    
  (Defmacro WHEN-INTERNING ((pkg symbol hashcode &OPTIONAL (index (GENSYM))) &BODY body)
;1; this macro expands into code which installs <symbol> in <pkg> and afterwhich executes*
;1; the forms in <body>.*
    `(LET* ((symtab (PACK-SYMBOL-TABLE ,pkg))
	    (length (P-NUMBER-OF-ENTRIES symtab)))
       (DO ((,index (REM ,hashcode length) (REM (1+ ,index) length)))  ;1; the DO has no body*
	   ((P-INACTIVE-ENTRY (P-WORD0 symtab ,index))              ;1; upon exit, execute the following*
	    (SETF (P-WORD0 symtab ,index) ,hashcode)
	    (SETF (P-WORD1 symtab ,index) ,symbol)
	    (PROGN . ,body)))))

;;12/10/87 CLM - quoted ART-FAT-STRING (spr 7013).  
  (Defmacro PARSE-STRING-ARGUMENT (string)
    `(IF (STRINGP ,string)
	 (IF (EQ (ARRAY-TYPE ,string) 'ART-FAT-STRING)  ;1; watch out for fonted strings*
	     (STRING-REMOVE-FONTS ,string)
	     ,string)
	 (STRING ,string)))
  
  (Defmacro PARSE-PACKAGE-ARGUMENT (pkg)
;1; expands into code which attempts to produce a package object from the argument <pkg>*
;1; and default to *PACKAGE* if omitted.*
;1; Most package functions, e.g. intern, expect a package object as the second argument.*
    `(COND ((NULL ,pkg) *PACKAGE*)
	   ((FIND-PACKAGE ,pkg))1   ;; at this point, <pkg> should be a package object*
	   (T (PACKAGE-DOES-NOT-EXIST-ERROR  ,pkg))))
  
  )


(Defun FIND-SYMBOL (string &OPTIONAL pkg)
1  "FIND-SYMBOL searches for a symbol with the print name <string> ACCESSIBLE in package <pkg>.
- the search begins with <pkg> itself. If such a symbol is found, it is returned.  Otherwise
  each package USEd by <pkg> is searched for an EXTERNAL symbol with print name <string> until
  either such a symbol is found, in which case it is returned, or all USEd packages have been 
  searched, in which case NIL is returned.
- In Common Lisp, <string> must be a string object, although the Explorer system also allows
  <string> to be a symbol.
- FIND-SYMBOL returns two values, the symbol found and an indicator keyword which is
  :external - if the symbol is present in <pkg> and an external symbol of <pkg>
  :internal - if the symbol is present in <pkg> and not external
  :inherited - if the symbol is inherited by <pkg> from some package it USEs
  NIL - if the symbol is not accessible in <pkg>.
  On the Explorer system, a third value is returned indicating in which package the symbol 
  found is present.
- FIND-SYMBOL never creates a new symbol nor has any side-effects on <pkg> (cf. INTERN)."*
  
  (DECLARE (VALUES symbol indicator))
  
  (LET* ((pkg (PARSE-PACKAGE-ARGUMENT pkg))
	 (string (PARSE-STRING-ARGUMENT string))
	 (hashcode  (SYMBOL-STRING-TO-HASH string)))
    
    (WITHOUT-INTERRUPTS
      (WHEN-SYMBOL-PRESENT (pkg string hashcode entry-symbol entry-info)  ;1; search this package*
	(RETURN-FROM FIND-SYMBOL 
	  (VALUES entry-symbol (IF (P-EXTERNAL-SYMBOL entry-info) :EXTERNAL :INTERNAL) pkg)))
      
      (DOLIST (pack (PACK-USE-LIST pkg))                                     ;1; search packages used by this package*
	(WHEN-SYMBOL-PRESENT (pack string hashcode entry-symbol entry-info)
	  (WHEN (P-EXTERNAL-SYMBOL entry-info)                             ;1; only external symbols are inheritable*
	     (RETURN-FROM FIND-SYMBOL
	       (VALUES entry-symbol :INHERITED pack))))))))


(Defun FIND-SYMBOL-LOCALLY (string &OPTIONAL pkg)
;1; this is an internal function which performs a find-symbol but looking only for symbols present*
;1; in the package. This procedure is used as an optimization for FIND-SYMBOL in places where*
;1; inherited symbols would be ignored.*
  
  (DECLARE (VALUES symbol indicator))
  
  (LET* ((pkg (PARSE-PACKAGE-ARGUMENT pkg))
	 (string (PARSE-STRING-ARGUMENT string))
	 (hashcode  (SYMBOL-STRING-TO-HASH string)))
    
    (WITHOUT-INTERRUPTS
      (WHEN-SYMBOL-PRESENT (pkg string hashcode entry-symbol entry-info)  ;1; search this package*
	(RETURN-FROM FIND-SYMBOL-LOCALLY 
	  (VALUES entry-symbol (IF (P-EXTERNAL-SYMBOL entry-info) :EXTERNAL :INTERNAL)))))))

(Defun FIND-EXTERNAL-SYMBOL (string &OPTIONAL pkg)
  1"Returns the external symbol available in package PKG whose name is STRING, if any.
Unlike INTERN, FIND-EXTERNAL-SYMBOL never creates a new symbol;
it returns NIL if none was found, or an internal symbol was found.*"
  (DECLARE (VALUES symbol indicator))
  (LET* ((pkg (PARSE-PACKAGE-ARGUMENT pkg))
	 (string (PARSE-STRING-ARGUMENT string))
	 (hashcode  (SYMBOL-STRING-TO-HASH string)))
    
    (WITHOUT-INTERRUPTS
      (WHEN-SYMBOL-PRESENT (pkg string hashcode entry-symbol entry-info)  ;1; search this package*
	(RETURN-FROM FIND-EXTERNAL-SYMBOL 
	  (VALUES entry-symbol (IF (P-EXTERNAL-SYMBOL entry-info) :EXTERNAL)))))))



(Defun INTERN (string &OPTIONAL pkg)
1  "INTERN returns the symbol with print name <string> ACCESSIBLE in package <pkg>.  
- the search begins with <pkg> itself.  If such a symbol is found, it is returned.  Otherwise
  each package USEd by <pkg> is searched for an EXTERNAL symbol with print name <string> until
  either such a symbol is found, in which case it is returned, or all USEd packages have been 
  searched, in which case a new symbol is created with home package <pkg>.
- In Common Lisp, <string> must be a string object, although the Explorer system also allows
  <string> to be a symbol.
- INTERN returns two values, the symbol found and an indicator keyword which is
  :external - if the symbol is present in <pkg> and an external symbol of <pkg>
  :internal - if the symbol is present in <pkg> and not external
  :inherited - if the symbol is inherited by <pkg> from some package it USEs
  NIL - if the symbol is newly created.
  On the Explorer system, a third value is returned indicating in which package the symbol 
  found is present."*
  
  (DECLARE (VALUES SYMBOL ALREADY-INTERNED-FLAG))
  (LET* ((pkg (PARSE-PACKAGE-ARGUMENT pkg))
	 (string (PARSE-STRING-ARGUMENT string))
	 (hashcode (SYMBOL-STRING-TO-HASH string)))
    (WITHOUT-INTERRUPTS
      (WHEN-SYMBOL-PRESENT (pkg string hashcode entry-symbol entry-info)  ;1; search this package*
	(RETURN-FROM intern
	  (VALUES entry-symbol (IF (P-EXTERNAL-SYMBOL entry-info) :EXTERNAL :INTERNAL) pkg)))
      (DOLIST (pack (PACK-USE-LIST pkg))                                     ;1; search packages used by this package*
	(WHEN-SYMBOL-PRESENT (pack string hashcode entry-symbol entry-info)
	  (WHEN (P-EXTERNAL-SYMBOL entry-info)                             ;1; only external symbols are inheritable*
	     (RETURN-FROM intern
	       (VALUES entry-symbol :INHERITED pack)))))
      (LET ((store-function (PACK-STORE-FUNCTION pkg))
	    (symbol (MAKE-SYMBOL-IN-AREA string (PACK-INTERN-AREA pkg))))
	(IF store-function          ;1; store the symbol*
	    (FUNCALL store-function hashcode symbol pkg)
	    (WHEN-INTERNING (pkg symbol hashcode index)			      
			    (WHEN (SYMBOLP (SYMBOL-PACKAGE symbol))   ;1; when no 'home' package*
				  (SETF (SYMBOL-PACKAGE symbol) pkg))
			    (WHEN (PACK-AFTER-INTERN-DAEMON pkg)
				  (FUNCALL (PACK-AFTER-INTERN-DAEMON pkg) symbol pkg symtab index))
			    (WHEN (> (INCF (PACK-NUMBER-OF-SYMBOLS pkg)) ;1; increment symbol count *
				     (PACK-MAX-NUMBER-OF-SYMBOLS pkg))
				  (PACKAGE-REHASH pkg))))
	(VALUES symbol nil pkg)
	))))


(Defun INTERN-SYMBOL-LOCALLY (symbol pkg)
;1; this function adds an internal symbol <symbol> to <pkg> *
;1; and returns <symbol>. No checking is done to see if <symbol>*
;1; is already present. This is NOT the same as the old "intern-local" and*
;1; is intended for internal use only.*
   (WITHOUT-INTERRUPTS
    (LET* ((string  (SYMBOL-NAME symbol))
	   (hashcode  (SYMBOL-STRING-TO-HASH string))
	   (store-function (PACK-STORE-FUNCTION pkg))
	   )
      (IF store-function  (FUNCALL store-function hashcode symbol pkg)        ;1; store the symbol*
	  (WHEN-INTERNING (pkg symbol hashcode index)			      
	    (WHEN (SYMBOLP (SYMBOL-PACKAGE symbol))   ;1; when no 'home' package*
	      (SETF (SYMBOL-PACKAGE symbol) pkg))
	    (WHEN (PACK-AFTER-INTERN-DAEMON pkg)
	      (FUNCALL (PACK-AFTER-INTERN-DAEMON pkg) symbol pkg symtab index))
	    (WHEN (> (INCF (PACK-NUMBER-OF-SYMBOLS pkg)) ;1; increment symbol count *
		     (PACK-MAX-NUMBER-OF-SYMBOLS pkg))
	      (PACKAGE-REHASH pkg)))
	  symbol))))


(Defun EXTERNALIZE-ALL-SYMBOLS (symbol pkg symtab index)
;1; this function is designed primarily for the keyword package and is called immediately*
;1; after <symbol> has been interned in <pkg> at index <index> in the symbol-table <symtab>.
;; It is also used by the LISP and the TICL packages to make their symbols external.*
;1; It returns nothing.*
  (COND ((EQ pkg *KEYWORD-PACKAGE*)1    ;; if keyword, make symbol self-evaluating*
	 (SET symbol symbol)           ;1; and then make symbol external*
	 (SETF (P-WORD0 symtab index) (P-MAKE-WORD0 1 (P-WORD0 symtab index))))
	(T (SETF (P-WORD0 symtab index) (P-MAKE-WORD0 1 (P-WORD0 symtab index)))))
  (VALUES))




(Defun PACKAGE-REHASH (pkg &OPTIONAL (size 1))
;1; when a package becomes 80% full, it is rehashed as follows:*
;1; first a new symbol-table array is created having at least twice the size as the original.*
;1; second, the symbols stored in the old symbol table are re-hashed and stored in the new symbol table*
  
  (WITH-PACKAGE-OBJECT (pkg)
    (LET* ((size (MAX size (* 2 (PACK-MAX-NUMBER-OF-SYMBOLS pkg))))
	   (old-symbol-table (PACK-SYMBOL-TABLE pkg))
	   (old-length (P-NUMBER-OF-ENTRIES old-symbol-table))
	   (package-area (%area-number pkg)))
      
      (SETF (PACK-MAX-NUMBER-OF-SYMBOLS pkg) size)
      (LET* ((new-symbol-table (MAKE-ARRAY (LIST (GET-GOOD-PACKAGE-SIZE size) 2) :area pkg-area))
	     (new-length (P-NUMBER-OF-ENTRIES new-symbol-table)))
	(SETF (PACK-SYMBOL-TABLE pkg) new-symbol-table)
	(DOTIMES (old-index old-length)
	  (WHEN (P-ACTIVE-ENTRY-P old-symbol-table old-index)          ;1; when we have an active entry in old*
	    (LET ((hashcode (SYMBOL-STRING-TO-HASH (SYMBOL-NAME (P-WORD1 old-symbol-table old-index)))))
	      (DO ((new-index (REM hashcode new-length) (REM (1+ new-index) new-length)))
		  ((NOT (P-ACTIVE-ENTRY-P new-symbol-table new-index))  ;1; store entry at new-index in new*
		   (SETF (P-WORD0 new-symbol-table new-index) (P-WORD0 old-symbol-table old-index))
		   (SETF (P-WORD1 new-symbol-table new-index) (P-WORD1 old-symbol-table old-index))))))))
      (LET* ((Hashcount (GETF (PACK-PLIST pkg) :times-rehashed))
	     (Rehashcount (if hashcount 
			      (1+ hashcount)
			      1)))
	(if (area-shared-p package-area)
	    (setf (car (last (pack-plist pkg))) RehashCount)
	    (SETF (GETF (PACK-PLIST pkg) :times-rehashed) RehashCount) 
	    ))
      )))

(Defun PACKAGE-EXTERNAL-SYMBOLS (pkg)
1  "Returns a list of all symbols 2external* in 2<*pkg2>*."*
   (LET (result)
      (DO-EXTERNAL-SYMBOLS (sym pkg)  (PUSH sym result))
    result))

1;; package objects are named-structures *
(Defun (:property PACKAGE NAMED-STRUCTURE-INVOKE) (op &OPTIONAL self &REST args)
  (COND ((EQ op :WHICH-OPERATIONS) '(:DESCRIBE :PRINT-SELF))
	((EQ op :DESCRIBE)
	 (DESCRIBE-PACKAGE self)
	 (DESCRIBE-DEFSTRUCT self))
	((EQ op :PRINT-SELF)
	 (LET ((stream (CAR args))
	       (slashify-p (CADDR args)))
	   (if slashify-p
	       (SI:PRINTING-RANDOM-OBJECT 
		 (self stream) 
		 (PRINC "Package " stream) 
		 (PRINC (PACK-NAME self) stream))
	       (PRINC (PACK-NAME self) stream))
	   t))))

(Defun DESCRIBE-PACKAGE (pkg)
  1"Describes thoroughly the package <pkg> (a package or the name of one).
The only thing not mentioned is what symbols are in the package.
Use MAPATOMS for that."*
  (WITH-PACKAGE-OBJECT (pkg)
     (FORMAT T "~%Package ~A" (PACK-NAME pkg))
     (WHEN (PACK-NICKNAMES pkg)
	   (PRINC "  with nicknames (")
	   (DO ((names (PACK-NICKNAMES pkg) (CDR names))
		(first t nil))
	       ((NULL names))
	       (UNLESS first (PRINC ", "))
	       (PRINC (CAR names)))
	   (PRINC ")"))
     (PRINC ".")
     (FORMAT t "~&   ~D. symbols out of ~D.  Hash modulus = ~D.~&"
	     (PACK-NUMBER-OF-SYMBOLS pkg)
	     (PACK-MAX-NUMBER-OF-SYMBOLS pkg)
	     (P-NUMBER-OF-ENTRIES (PACK-SYMBOL-TABLE pkg)))
     (FORMAT t "~@[Packages which USE this one:~&~{   ~A~&~}~]" (PACK-USED-BY-LIST pkg))
     (FORMAT t "~@[Packages which are USEd by this one:~&~{   ~A~&~}~]" (PACK-USE-LIST pkg))
     (FORMAT t "~@[Shadowed symbols:~&~{   ~S~&~}~]" (PACK-SHADOWING-SYMBOLS pkg))
     (FORMAT t "~@[Symbols are interned in this package using( ~S~&~]" (PACK-STORE-FUNCTION pkg))
     (FORMAT t "~@[Symbols interned in this package are automatically exported.~%~]"
	     (PACK-AUTO-EXPORT-P pkg))
     (FORMAT t "~@[Additional properties of this package:~%~{   ~S:~33T~S~%~}~]"
	     (PACK-PLIST pkg))
     PKG))

;1;; import <s> <p>*
;1;;  -basically <s> is interned in <p> as an internal symbol. The 'home ' package for <s> remains*
;1;;   unaltered*
;1;;  -if <s> is present in <p> , return t*
;1;;   else if inherited, intern it locally in <p>*
;1;;   else if <s> is not accesssible and there is no conflicting symbol , intern <s> in <p>*
;1;;   else NAME-CONFLICT:<s> is not acessible and there is a conflicting symbol <u>. Then*
;1;;      Signal a conflict having the user choose <s> or abort the operation. If <s> wins,*
;1;;      make it a shadowing-import.*
;1;;  - To IMPORT nil, one must use (import '(nil) 'foo)*
;1;;  - in checking for name-conflicts,ALL symbols accessible to <p> must be checked. In particular,*
;1;;      it is not adequate merely to check symbols present in <p>. Otherwise*
;1;;      there is the possibility that an import will silently shadow an inherited symbol.*


(Defun IMPORT (symbols &OPTIONAL pkg)
  "2<symbols>, which is either a single symbol or a list of symbols, are made accessible
in package <pkg>, which defaults to *package*. The symbols may now be used without
supplying their package prefix. An error occurs if there is a symbol with* 2the same 
name already accessible in <pkg>."*
  
  (LET ((pkg (PARSE-PACKAGE-ARGUMENT pkg))
	(symlist (IF (LISTP symbols) symbols (LIST symbols)))) 
    (UNLESS (EVERY #'SYMBOLP symlist)
	    (ERROR t 1"the import list contains non-symbols: ~s"* (REMOVE-IF #'SYMBOLP symlist)))
    (TAGBODY try-next-sym
	(DOLIST (sym symlist t)
		(MULTIPLE-VALUE-BIND (conflict type)
		    (FIND-SYMBOL sym pkg)
		  (COND ((AND type (EQ conflict sym))	;1 <sym> accessible*
			 (WHEN (EQ type :inherited)	;1 if inherited, make present*
			       (INTERN-SYMBOL-LOCALLY sym pkg)))
			((NOT type) 
			 (INTERN-SYMBOL-LOCALLY sym pkg))	;1 not accessible but no conflict*
			((eq type :inherited)	1;conflict with an inherited symbol*
			 (signal-proceed-case ((ignore) 'eh:name-conflict
					       (format t "~%An ~a symbol named ~a is already accessible in the ~a package."
						       type (symbol-name sym) pkg)
					       sym
					       (package-name pkg)
					       :import
					       nil
					       nil)
					      (:import-accessible-by-inheritance nil)	1;Handler does shadowing-import.*
					      (:skip (go try-next-sym))
					      (:skip-all (return-from import t))))
			(t			1;conflict with a symbol already present in <pkg>*
			  (signal-proceed-case ((ignore) 'eh:name-conflict
						(format t "~%An ~a symbol named ~a is already accessible in the ~a package."
							type (symbol-name sym) pkg)
						sym
						(package-name pkg)
						:import
						nil
						nil)
					       (:import-present (import sym pkg))	1;Handler uninterns <conflict>.*
					       (:skip (go try-next-sym))
					       (:skip-all (return-from import t)))))
		  (UNLESS (PACKAGEP (SYMBOL-PACKAGE sym))
			  (SETF (SYMBOL-PACKAGE sym) pkg)))
		try-next-sym))
    t))


;1;; shadowing-import <s> <p>*
;1;;  -basically <s> is interned in <p> as an internal symbol, added to the shadowing symbols*
;1;;   list and any conflicts introduced by the import are automatically resolved in favor of <s>.*
;;1;  -the use of FIND-SYMBOL-LOCALLY ,as opposed to FIND-SYMBOL, is justified by the fact *
;1;;   that we are interested only in locating a symbol present in the package which*
;1;;   conflicts with the import since such a symbol will have  to be uninterned. If there*
;1;;   is a name conflict between a shadowing import and an inherited symbol, the import *
;1;;   would again win but the inherited symbol would not be uninterned. So why look?*

(EVAL-WHEN (compile)
  (Defmacro DELETE-SHADOWING-SYMBOL (symbol pkg)
;1; delete a symbol from the list of shadowing symbols*
    `(LET ((default-cons-area pkg-area))
       (SETF (PACK-SHADOWING-SYMBOLS ,pkg) (DELETE ,symbol (THE list (PACK-SHADOWING-SYMBOLS ,pkg))))))
  
  (Defmacro ADD-SHADOWING-SYMBOL (symbol pkg)
    `(LET ((tlist (PACK-SHADOWING-SYMBOLS ,pkg)))  ;1; effectively PUSHNEW*
       (UNLESS (MEMBER ,symbol tlist :test #'EQ)
	 (SETF (PACK-SHADOWING-SYMBOLS ,pkg)
	       (CONS-IN-AREA ,symbol tlist pkg-area)))))
       )

(Defun SHADOWING-IMPORT (symbols &OPTIONAL pkg)
  "2<symbols>, which is either a single symbol or a list of symbols, are made PRESENT
in package <pkg>, which defaults to *package*. The symbols may now be used without
supplying their package prefix. An error occurs if there is there is a symbol with
the same name already accessible in <pkg>."*

  (LET ((pkg (PARSE-PACKAGE-ARGUMENT pkg))
	(symlist (IF (LISTP symbols) symbols (LIST symbols))))
    (UNLESS (EVERY #'SYMBOLP symlist)
      (ERROR t 1"the shadowing import list contains non-symbols: ~s"* (REMOVE-IF #'SYMBOLP symlist)))
    (DOLIST (sym symlist t)
      (MULTIPLE-VALUE-BIND (conflict type)
	  (FIND-SYMBOL-LOCALLY (SYMBOL-NAME sym) pkg)     ;1 type will be NIL, :external or :internal*
	(COND ((AND type (EQ conflict sym)))              ;1 <sym> accessible*
	      ((NOT type)                                 ;1 not accessible but no conflict*
	       (INTERN-SYMBOL-LOCALLY sym pkg))
	      (t                                          ;1 conflict present*
	       (DELETE-SHADOWING-SYMBOL conflict pkg)     1; necessary for UNINTERN*
	       (UNINTERN conflict pkg)
	       (INTERN-SYMBOL-LOCALLY sym pkg)))
	(ADD-SHADOWING-SYMBOL sym pkg)))))                ;1 in any event, add to shadowing symbols list*


;1; shadow <s> <p>*
;1;   - if <s> is present in <p>, <s> is added to thge shadowing symbols list. Otherwise*
;1;     a new symbol is created, interned in <p> and added to the shadowing symbols list.*
;1;   - reason for using FIND-SYMBOL-LOCALLY same as above.
;;;10/05/87 CLM for JK - Fixed call to ADD-SHADOWING-SYMBOL when argument is a *
;1;;string and the symbol already exists in the package.  The string was being*
;1;;placed on the list of shadowed symbols, which caused an error when trying to*
;1;;perform a DO-SYMBOLS on that package.*
(Defun SHADOW (symbols &OPTIONAL pkg)
1  "Makes the symbols in package PKG with names NAMES be shadowed symbols.
This means that symbols with these names are created directly
in PKG if none were present already.
Any symbols with these names previously available by inheritance become hidden."*
  (LET ((pkg (PARSE-PACKAGE-ARGUMENT pkg))
	(symlist (IF (LISTP symbols) symbols (LIST symbols))))
    (UNLESS (EVERY #'(lambda (x) (TYPEP x '(OR SYMBOL STRING))) symlist)
      (ERROR t 1"the shadowing import list contains non-symbols: ~s"*
	      (REMOVE-IF-NOT #'(lambda (x) (TYPEP x '(OR SYMBOL STRING))) symlist)))
    (DOLIST (sym symlist t)
      (MULTIPLE-VALUE-BIND (conflict type)       ;1; type will be :internal or :external or nil (if not present)*
	  (FIND-SYMBOL-LOCALLY (STRING sym) pkg)
	(IF (AND type (string= (symbol-name conflict)
			       (if (symbolp sym) (symbol-name sym) sym)))    ;1; symbol present*
	    (ADD-SHADOWING-SYMBOL conflict pkg)
	    ;1; else create a new symbol in package*
	  (LET ((new-symbol (MAKE-SYMBOL-IN-AREA (STRING sym) (PACK-INTERN-AREA pkg)))) 
	    (INTERN-SYMBOL-LOCALLY new-symbol pkg)
	    (ADD-SHADOWING-SYMBOL  new-symbol pkg)))))))


;1;; unintern <s> <p>*
;1;;  - removes <s> from the symbol table of <p> and, if <p> is the home package*
;1;;    for <s>, sets the package to nil. If <s> is not present in <p> , no action*
;1;;    is taken.*
;1;;  - when <s> appears on the shadowing symbols list of <p>, uninterning can uncover*
;1;;    a name conflict: suppose <u> and <v> are inheritable but shadowed by <s>. Then*
;1;;    uninterning would leave both symbols accessible to <p>. We force the user to*
;1;;    either abort the operation, leaving <s> in the package, or force him to choose*
;1;;    between <u> and <v> -- with the winner made an shadowing import.*
;1;;  - if <s> is removed, the symbol table is set to indicate a "deleted" entry.*

(Defun UNINTERN (symbol &OPTIONAL pkg)
  "Removes (uninterns) the symbol <symbol> from package <pkg> which
defaults to the current package. Uninterning may uncover a name
conflict if <symbol> resides on the shadowing symbols list of <pkg>.
Unintern returns t if <sym> was uninterned and nil otherwise."
  (CHECK-TYPE symbol symbol "a symbol")
  (LET ((pkg (PARSE-PACKAGE-ARGUMENT pkg)))
    (IF (MEMBER symbol (PACK-SHADOWING-SYMBOLS pkg) :TEST #'EQ)
	(LET* ((conflicts (THE list
			       (REMOVE 'nil
				       (THE list
					    (MAPCAR 
					      #'(lambda (p) 
						  (MULTIPLE-VALUE-BIND (csym type) 
						      (FIND-SYMBOL-LOCALLY symbol p)
						    (WHEN (EQ type :EXTERNAL)
							  (CONS csym p))))
					      (PACK-USE-LIST pkg)))))))
	  (IF (CDR conflicts) 
	      (signal-proceed-case ((ignore) 'eh:name-conflict
				    (format t "~%Attempting to unintern the shadowing symbol ~s from the ~a ~
package ~%would introduce the following name conflicts:" symbol (package-name pkg))
				    symbol
				    (package-name pkg)
				    :unintern
				    conflicts
				    (dolist (pair conflicts)
					    ;;  Ensure the symbol's prefix is displayed.
					    (format t "~&~10t~a:~a is accessible by inheritance ~
in the ~a package."
						    
						    (multiple-value-bind (ignore ignore pack)
							(find-symbol (symbol-name (car pair))
								     (cdr pair))
						      (package-name pack))
						    (car pair)
						    (package-name pkg))))
				   (:unintern (return-from unintern t))
				   (:skip (return-from unintern)))
	      (PROGN
		(DELETE-SHADOWING-SYMBOL symbol pkg)
		(UNINTERN symbol pkg)   ;; recurse to take a different path
		)))
	(LET* ((string (SYMBOL-NAME symbol))
	       (hashcode (SYMBOL-STRING-TO-HASH string)))
	  (WHEN-SYMBOL-PRESENT (pkg string hashcode word0 word1 index)
	    (SETF (P-WORD0 symtab index) t)
	    (SETF (P-WORD1 symtab index) nil)
	    (decf (pack-number-of-symbols pkg))  ;; 9/15/88 clm - decrement the symbol count
	    (WHEN (EQ (SYMBOL-PACKAGE symbol) pkg)
	      (SETF (SYMBOL-PACKAGE symbol) nil))
	    (RETURN-FROM UNINTERN t))))))

(Defun EXTERNALIZE (sym pkg)
1;; an internal routine called from EXPORT to make a symbol <sym> external in package <pkg>*
  (LET* ((string (SYMBOL-NAME sym))
	 (hashcode (SYMBOL-STRING-TO-HASH string)))
    (WHEN-SYMBOL-PRESENT (pkg string hashcode word0 word1 index)
      (SETF (P-WORD0 symtab index) (P-MAKE-WORD0 1 (P-WORD0 symtab index)))
      (RETURN (VALUES)))))

(defun INTERNALIZE (sym pkg)
1;; an internal routine called by UNEXPORT to make a symbol <sym> internal in package <pkg>  *
  (let* ((string (symbol-name sym))
	 (hashcode (symbol-string-to-hash string)))
    (when-symbol-present (pkg string hashcode word0 word1 index)
      (setf (p-word0 symtab index) (p-make-word0 0 (p-word0 symtab index)))
      (return (values)))))

;;;(Defun EXPORT (symbols &OPTIONAL pkg force-flag)
;;;  1"Makes SYMBOLS external in package PKG.*
;;;1If the symbols are not already present in PKG, they are imported first.*
;;;1Error if this causes a name conflict in any package that USEs PKG.*
;;;1FORCE-FLAG non-NIL turns off checking for name conflicts, for speed*
;;;1in the case where you know there cannot be any."*
;;;  (LET ((pkg (PARSE-PACKAGE-ARGUMENT pkg)))
;;;      (UNLESS force-flag
;;;	 (DO-FOREVER
;;;	    (LET (conflicts)
;;;	       ;; Find all conflicts there are. Each element of CONFLICTS looks like
;;;	       ;; (NEW-CONFLICTING-SYMBOL CONFLICT-PACKAGE
;;;	       ;;   (OTHER-PACKAGE-NAME OTHER-PACKAGE-SYMBOL OTHER-PACKAGE)...)
;;;	       (DOLIST (p1 (PACK-USED-BY-LIST pkg))
;;;		  (DOLIST (symbol (IF (LISTP symbols) SYMBOLS (LIST symbols)))
;;;		     (LET ((candidates
;;;				 (CHECK-FOR-NAME-CONFLICT (IF (SYMBOLP SYMBOL) (SYMBOL-NAME SYMBOL) SYMBOL)
;;;								        P1 NIL SYMBOL PKG)))
;;;		        (WHEN CANDIDATES
;;;			   (PUSH (LIST* SYMBOL P1 CANDIDATES) CONFLICTS)))))
;;;	       (UNLESS CONFLICTS (RETURN NIL))
;;;	       ;; Now report whatever conflicts we found.
;;;	       (CERROR :NO-ACTION NIL 'SYMBOL-NAME-CONFLICT
;;;			   "Name conflicts created by EXPORT in package ~A:
;;;~:{~S causes a conflict in package ~A.~%~}"
;;;			   PKG CONFLICTS))))
;;;  (DOLIST (sym (IF (LISTP symbols) symbols (LIST symbols)))
;;;    (UNLESS (SYMBOLP sym)
;;;      (FERROR nil "argument ~s to export must be a symbol" sym))
;;;;;    (UNLESS (AND (SYMBOLP sym)			;
;;;;;		 (EQ (SYMBOL-PACKAGE sym) pkg))
;;;;;      (SETQ SYM (INTERN-SYMBOL-LOCALLY SYM PKG)))
;;;    (IMPORT SYM PKG)
;;;    (EXTERNALIZE sym pkg))
;;;  T))

(Defun UNEXPORT (SYMBOLS &OPTIONAL (PKG *PACKAGE*))
  "Makes SYMBOLS no longer external in package PKG.  This should be
used mainly as a way to undo erroneous calls to EXPORT.  It is an
error to UNEXPORT any symbol not already present in PKG."
  (setq pkg (find-package pkg))
  (dolist (sym (if (and symbols (symbolp symbols)) (list symbols) symbols))
    (multiple-value-bind (symb type)
	(find-symbol sym pkg)
      (if (and type
	       (neq type :inherited))
	  (when (eq type :external)
	    (internalize symb pkg))
	(cerror :no-action nil nil "Symbol ~s is not present in the ~a package." sym pkg))))
  t)

;;AB 8/3/87.  Fix to give intelligible error msg when PACKAGES-TO-USE don't exist.  [SPR 5465]
(defun use-package (packages-to-use &optional (inheriting-pkg *package*))
  "Adds PACKAGES-TO-USE to the use list of INHERITING-PKG so that the 
external symbols of the used packages are accessible (but not present) 
as internal symbols in INHERITING-PKG.
PACKAGES-TO-USE may be a list of package objects or names of packages,
or a single package object or name."
  (let ((pkgs-to-use (if (listp packages-to-use)
			 (mapcar #'PKG-FIND-PACKAGE packages-to-use)
			 (list (PKG-FIND-PACKAGE packages-to-use))))
	(inheriting-pkg (PKG-FIND-PACKAGE inheriting-pkg)))
    (when (member *global-package* pkgs-to-use :test #'eq)
      (dolist (pkg pkgs-to-use)
	(when (or (eq pkg *lisp-package*)
		  (eq pkg *ticl-package*))
	  (cerror "Use both the ~a and GLOBAL packages and resolve name conflicts."
		  "It is generally an error to use both the ~a and GLOBAL packages, since incompatible ~%~9@TCommon Lisp and Zetalisp functions of the same name are accessible from these packages."
		  (package-name pkg)))))
    (tagbody try-next-pkg
	(dolist (pkg pkgs-to-use)
		(when (eq pkg *keyword-package*)
		      (ferror nil "It is an error to try to use the KEYWORD package."))
		
		(unless (member pkg (pack-use-list inheriting-pkg) :test #'eq)
			(let ((set-of-directly-conflicting-symbols nil)
			      (set-of-inherited-conflicting-symbols nil)
			      (shadowing-symbols (pack-shadowing-symbols inheriting-pkg)))
			  (do-external-symbols (symbol pkg)
					       (multiple-value-bind (sym type)
						   (find-symbol (symbol-name symbol) inheriting-pkg)
						 (when (and type
							    (neq sym symbol)
							    (not (member sym shadowing-symbols :test #'eq)))
						       (if (eq type :inherited)
							   (push (cons sym inheriting-pkg)
								 set-of-inherited-conflicting-symbols)
							   (push (cons sym inheriting-pkg)
								 set-of-directly-conflicting-symbols)))))
			  1;; Handle name conflicts.*
			  (cond ((and set-of-directly-conflicting-symbols
				      set-of-inherited-conflicting-symbols)
				 (signal-proceed-case ((ignore) 'eh:name-conflict
						       (format t "~%Attempting to use the ~a package would introduce the ~
following name conflicts:" pkg)
						       nil
						       (package-name pkg)
						       :use-package
						       (cons set-of-directly-conflicting-symbols
							     set-of-inherited-conflicting-symbols)
						       (progn (dolist (pair set-of-directly-conflicting-symbols)
								      (format t "~&~10t~s is present in the ~a package."
									      (car pair) (cdr pair)))
							      (dolist (pair set-of-inherited-conflicting-symbols)
								      (format t "~&~10t~a:~a is accessible by inheritance ~
in the ~a package."
									      (multiple-value-bind (ignore ignore pack)
										  (find-symbol (symbol-name (car pair))
											       (cdr pair))
										pack)
									      (car pair)
									      (cdr pair)))))
						      (:use-package-both-conflict-types nil)
						      (:skip (go try-next-pkg))
						      (:skip-all (without-interrupts
								   (dolist (pack pkgs-to-use)
								     (setf (pack-use-list inheriting-pkg)
									   (delete pack (pack-use-list inheriting-pkg)
										   :test #'eq))))
								 (return-from use-package t))))
				(set-of-directly-conflicting-symbols
				  (signal-proceed-case ((ignore) 'eh:name-conflict
							(format t "~%Attempting to use the ~a package would introduce the ~
following name conflicts:"  pkg)
							nil
							(package-name pkg)
							:use-package
							set-of-directly-conflicting-symbols
							(dolist (pair set-of-directly-conflicting-symbols)
								(format t "~&~10t~s is present in the ~a package."
									(car pair) (cdr pair))))
						       (:use-package-present nil)
						       (:unintern-all nil)
						       (:shadow-all nil)
						       (:skip (setq pkgs-to-use (remove pkg pkgs-to-use :test #'eq))
							      (go try-next-pkg))
						       (:skip-all (without-interrupts
								    (dolist (pack pkgs-to-use)
								      (setf (pack-use-list inheriting-pkg)
									    (delete pack (pack-use-list inheriting-pkg)
										    :test #'eq))))
								  (return-from use-package t))))
				(set-of-inherited-conflicting-symbols
				  (signal-proceed-case ((ignore) 'eh:name-conflict
							(format t "~%Attempting to use the ~a package would introduce the ~
following name conflicts:"  pkg)
							nil
							(package-name pkg)
							:use-package
							set-of-inherited-conflicting-symbols
							(dolist (pair set-of-inherited-conflicting-symbols)
								(format t "~&~10t~a:~a is accessible by inheritance ~
in the ~a package."
									(multiple-value-bind (ignore ignore pack)
									    (find-symbol (symbol-name (car pair))
											 (cdr pair))
									  pack)
									(car pair)
									(cdr pair))))
						       (:use-package-accessible-by-inheritance nil)
						       (:skip (setq pkgs-to-use (remove pkg pkgs-to-use :test #'eq))
							      (go try-next-pkg))
						       (:skip-all (without-interrupts
								    (dolist (pack pkgs-to-use)
								      (setf (pack-use-list inheriting-pkg)
									    (delete pack (pack-use-list inheriting-pkg)
										    :test #'eq))))
								  (return-from use-package t))))
				(t nil))
			  (unless (member pkg (pack-use-list inheriting-pkg) :test #'eq)
			    (without-interrupts
			      (let ((default-cons-area pkg-area))
				(push pkg (pack-use-list inheriting-pkg))
				(push inheriting-pkg (pack-used-by-list pkg)))))))
		try-next-pkg)))
  t)


(Defun UNUSE-PACKAGE (pkgs &OPTIONAL pkg)
  1"Removes PKGS from the use list of <pkg> so their external symbols are no longer 
inherited. <pkgs> is a list of packages or package names or a single package or
package name."*

  (LET ((pkg (PARSE-PACKAGE-ARGUMENT pkg)))
    (DOLIST (p (IF (CONSP pkgs) pkgs (LIST pkgs)) t)
      (LET ((q (FIND-PACKAGE p)))
	(IF q (UNUSE-PACKAGE-1 q pkg))))))

(Defun UNUSE-PACKAGE-1 (used-package using-package)
  (WITHOUT-INTERRUPTS
    (SETF (PACK-USED-BY-LIST used-package)
	  (DELETE using-package (THE list (PACK-USED-BY-LIST used-package))))
    (SETF (PACK-USE-LIST using-package)
	  (DELETE used-package (THE list (PACK-USE-LIST using-package))))))




1;; The following returns a pair of the form ( nil . EQUAL-hash-table).  Once you
;; have finished with it, "rplaca" the pair with t to indicate it is again free
;; for use.  The hash-table has been cleared.  As an illustration, see DO-SYMBOLS.*
(Defun GET-UTILITY-HASH-TABLE-FOR-PACKAGE (pkg length)
  (WITH-PACKAGE-OBJECT (pkg)
    (LET ((ht-list (GETF (PACK-PLIST pkg) :hash-table))
	  available)
1      ;; ht-list is an alist each cons of which looks like (t-or-nil . Equal-hash-table)
      ;; t means available, nil means in use*
      (WITHOUT-INTERRUPTS
	(IF (AND ht-list (SETQ available (ASSOC t ht-list :test #'EQ)))
	    (PROGN
	      (RPLACA available nil)
	      (CLRHASH (cdr AVAILABLE))
	      available)
	    (PROGN
	      (SETF (GETF (PACK-PLIST pkg) :hash-table)
		    (CONS (CONS T (MAKE-HASH-TABLE :size length :test #'EQUAL)) ht-list))
	      (GET-UTILITY-HASH-TABLE-FOR-PACKAGE pkg length)))))))




(Defun PKG-FIND-PACKAGE (THING &OPTIONAL CREATE-P USE-LOCAL-NAMES-PACKAGE)
  1"Find or possibly create a package named THING.
If FIND-PACKAGE can find a package from the name THING,
we return that package.
Otherwise, we may create such a package, depending on CREATE-P.
This should only happen if THING is a string or symbol.
Possible values of CREATE-P:
 NIL means get an error,
 :FIND means return NIL,
 :ASK means create package and return it after getting confirmation,
 T means create package and return it."*
  (OR (AND (PACKAGEP THING) THING)
      (FIND-PACKAGE THING)    ;;  USE-LOCAL-NAMES-PACKAGE)
      (case CREATE-P
	(:FIND NIL)
	((NIL :ERROR)
	 (SIGNAL-PROCEED-CASE ((NEW-NAME) 'PACKAGE-NOT-FOUND-1
					  "Package ~A does not exist."
					  THING USE-LOCAL-NAMES-PACKAGE)
	   (:CREATE-PACKAGE (OR (FIND-PACKAGE THING)
				(MAKE-PACKAGE THING)))
	   (:NEW-NAME
	    (LET* ((*PACKAGE* *USER-PACKAGE*)
		   (STRING1 (STRING (READ-FROM-STRING NEW-NAME))))
	      (PKG-FIND-PACKAGE STRING1 CREATE-P NIL)))
	   (:RETRY (PKG-FIND-PACKAGE THING CREATE-P USE-LOCAL-NAMES-PACKAGE))))
	(:ASK
	 (IF (FQUERY FORMAT:YES-OR-NO-P-OPTIONS
		     "~&Package ~A not found.  Create? "
		     THING)
	     (MAKE-PACKAGE THING)
	   (CERROR ':NO-ACTION NIL NIL
		   "Please load package ~A declaration file then continue." THING)
	   (PKG-FIND-PACKAGE THING CREATE-P)))
	((T)
	 (MAKE-PACKAGE THING)))))





(Defun ALTER-PACKAGE (name &KEY nicknames
		      (use '("LISP" "TICL"))
		      size
		      shadow 
		      export 
		      prefix-name 
		      auto-export-p
		      import 
		      shadowing-import 
		      properties)
  (DECLARE (IGNORE size))
  (LET ((pkg (PARSE-PACKAGE-ARGUMENT name)))
    (UNLESS (LISTP nicknames) (SETQ nicknames (LIST nicknames)))
    (RENAME-PACKAGE pkg (PACK-NAME pkg) nicknames)
    (UNLESS (OR (NULL prefix-name) (STRING= prefix-name name) (MEMBER prefix-name nicknames :TEST #'STRING=))
      (ERROR nil "The prefix name ~A is not a name or nickname of the package." prefix-name))
    (SETF (PACK-PREFIX-NAME pkg) (OR prefix-name (SHORTEST-NAME-OR-NICKNAME pkg)))
    (LOOP for (prop val) on properties by 'cddr
	  do (SETF (GETF (PACK-PLIST pkg) prop) val))
    (WHEN shadow (SHADOW shadow pkg))
    (WHEN shadowing-import (SHADOWING-IMPORT shadowing-import pkg))
    (WHEN export
	    (dolist (x (if (listp export) export (list export)))
	      (EXPORT (if (stringp x) (intern x pkg) x) pkg)))	
    (LET ((desired-use (IF (LISTP use)
			   (MAPCAR #'PKG-FIND-PACKAGE use)  ;;8/26/88 clm
			   (LIST (PKG-FIND-PACKAGE use)))))
      (DOLIST (elt (PACK-USE-LIST pkg))
	(UNLESS (MEMBER elt desired-use)
	  (UNUSE-PACKAGE elt pkg)))
      (USE-PACKAGE desired-use pkg))
    (WHEN import (IMPORT import pkg))
    (COND (auto-export-p 
	   (SETF (PACK-AFTER-INTERN-DAEMON pkg) 'after-intern-daemon)
	   (SETF (PACK-AUTO-EXPORT-P pkg) T))
	  (T
	   (SETF (PACK-AFTER-INTERN-DAEMON pkg) nil)
	   (SETF (PACK-AUTO-EXPORT-P pkg) nil)))
    pkg))


(Defun DELETE-PACKAGE(pkg)
1  "Kills a package object and uninterns all symbols present in the package.
It is illegal to delete a package when it is used by another so one must remove
such dependencies before proceeding."*

  (LET* ((pkg (FIND-PACKAGE pkg))
	 (used-by-list (PACKAGE-USED-BY-LIST pkg)))
    (WHEN used-by-list
      (ERROR t "~s cannot be deleted since it is used by ~s~%" pkg used-by-list))
    (SETF (PACK-SHADOWING-SYMBOLS pkg) nil)  ;1; prevent UNINTERN from looking for name conflicts*
    (DO-LOCAL-SYMBOLS (var pkg) (UNINTERN var pkg))
    (KILL-PACKAGE pkg)))

(DEFVAR *PACK-BAD-SYMBOLS*)

(Defun BOOTSTRAP-EXPORT (symbols &OPTIONAL pkg force-flag)
  1"Makes SYMBOLS external in package PKG.
If the symbols are not already present in PKG, they are imported first.
Error if this causes a name conflict in any package that USEs PKG.
FORCE-FLAG non-NIL turns off checking for name conflicts, for speed
in the case where you know there cannot be any."*
;;;  (LET ((pkg (PARSE-PACKAGE-ARGUMENT pkg)))
;;;      (UNLESS force-flag
;;;	 (DO-FOREVER
;;;	    (LET (conflicts)
;;;	       ;; Find all conflicts there are. Each element of CONFLICTS looks like
;;;	       ;; (NEW-CONFLICTING-SYMBOL CONFLICT-PACKAGE
;;;	       ;;   (OTHER-PACKAGE-NAME OTHER-PACKAGE-SYMBOL OTHER-PACKAGE)...)
;;;	       (DOLIST (p1 (PACK-USED-BY-LIST pkg))
;;;		  (DOLIST (symbol (IF (LISTP symbols) SYMBOLS (LIST symbols)))
;;;		     (LET ((candidates
;;;				 (CHECK-FOR-NAME-CONFLICT (IF (SYMBOLP SYMBOL) (SYMBOL-NAME SYMBOL) SYMBOL)
;;;								        P1 NIL SYMBOL PKG)))
;;;		        (WHEN CANDIDATES
;;;			   (PUSH (LIST* SYMBOL P1 CANDIDATES) CONFLICTS)))))
;;;	       (UNLESS CONFLICTS (RETURN NIL))
;;;	       ;; Now report whatever conflicts we found.
;;;	       (return (push (cons pkg (list* "conflict-list" conflicts)) *pack-bad-symbols*))
;;;	       )))
  (declare (ignore force-flag))
  (let ((pkg (parse-package-argument pkg)))
  (DOLIST (sym (IF (LISTP symbols) symbols (LIST symbols)))
    (UNLESS (SYMBOLP sym)
      (FERROR nil "argument ~s to export must be a symbol" sym))
;;    (UNLESS (AND (SYMBOLP sym)			;
;;		 (EQ (SYMBOL-PACKAGE sym) pkg))
;;      (SETQ SYM (INTERN-SYMBOL-LOCALLY SYM PKG)))
    (MULTIPLE-VALUE-BIND (conflict type)
	(FIND-SYMBOL sym pkg)
      (COND ((AND type (EQ conflict sym))	;1 <sym> accessible*
	     (WHEN (EQ type :inherited)		;1 if inherited, make present*
	       (INTERN-SYMBOL-LOCALLY sym pkg)))
	    ((NOT type) (INTERN sym pkg))	;1 not accessible but no conflict*
	    (t					;1 conflict - PUT SYMBOL ON PACK-BAD-SYMBOLS*
	     (PUSH (CONS sym conflict) *pack-bad-symbols*)
	     (SHADOWING-IMPORT sym pkg))))
    (EXTERNALIZE sym pkg))
  T))

(defvar *symbols-seen-twice* nil)
(defvar *multiple-symbol-blocks* nil)

(Defun BOOTSTRAP-INTERN-AND-OPTIONALLY-EXPORT (symbol pkg &OPTIONAL export-p)
;; <symbol> -- a symbol stored in NR-SYM
;; <pkg> -- a real package
   (LET* ((string  (SYMBOL-NAME symbol))
	  (hashcode  (SYMBOL-STRING-TO-HASH string)))
      (WHEN-SYMBOL-PRESENT (pkg string hashcode entry-symbol entry-info)  ;1; search this package*
	(COND ((eq entry-symbol symbol) 
               ;; here are trying to "intern" the same symbol twice (this happens when the same symbol
	       ;; appears on more than one of the symbol lists)
	       (push symbol *symbols-seen-twice*))
	      (t
	       ;; else we have different symbols with the same name being interned in the same package.
	       ;; Complaining about it here would do no good since there are no streams.
	       (push (cons entry-symbol symbol) *multiple-symbol-blocks*)))
	(RETURN-FROM bootstrap-intern-and-optionally-export (values)))
      ;; If we get here, there is no symbol with the name <string> in <pkg> -- intern <symbol>.
      (WHEN-INTERNING (pkg symbol hashcode index)			      
	    (WHEN (SYMBOLP (SYMBOL-PACKAGE symbol))   ;1; when no 'home' package*
	      (SETF (SYMBOL-PACKAGE symbol) pkg))
	    (WHEN export-p
		  (SETF (P-WORD0 symtab index) (P-MAKE-WORD0 1 (P-WORD0 symtab index))))
	    (WHEN (> (INCF (PACK-NUMBER-OF-SYMBOLS pkg)) ;1; increment symbol count *
		     (PACK-MAX-NUMBER-OF-SYMBOLS pkg))
	      (PACKAGE-REHASH pkg)))
	  symbol))


(Defun EXPORT (symbols &OPTIONAL pkg)
1  "Makes SYMBOLS external in package PKG.
If the symbols are not already present in PKG, they are imported first.
Error if this causes a name conflict in any package that USEs PKG."*
  (LET ((pkg (PARSE-PACKAGE-ARGUMENT pkg))                          ;; verify package argument
	(export-list (IF (LISTP symbols) symbols (LIST symbols))))  ;; coerce <symbols> to a list
    (UNLESS (EVERY #'SYMBOLP export-list)                           ;; verify all are symbols - complain otherwise
	    (ERROR t 1"the export list contains non-symbols: ~s"* (REMOVE-IF #'SYMBOLP export-list)))
    (LET ((real-export-list    ;; prepare to punt symbols already exported
	    (REMOVE-IF         ;;   -- this is worthwhile since files with 'exports' are often re-compiled
	      #'(Lambda (sym) 
		  (MULTIPLE-VALUE-BIND (csym found) 
		      (FIND-SYMBOL (symbol-name sym) pkg)
		    (AND (EQ found :external) (EQ sym csym))))
	      export-list))
	  (used-by-list (PACK-USED-BY-LIST pkg)))
      (TAGBODY try-next-sym
	  (DOLIST (sym real-export-list)
		  (WHEN used-by-list
			(LET ((set-of-directly-conflicting-symbols nil)
			      (set-of-inherited-conflicting-symbols nil)
			      (name (SYMBOL-NAME sym)))
			  (DOLIST (p used-by-list)     ;; for each package p using pkg
				  (MULTIPLE-VALUE-BIND (csym found)  ;; look for a conflict
				      (FIND-SYMBOL name p)
				    (WHEN (AND found
					       (NEQ sym csym) 
					       (NOT (MEMBER csym (pack-shadowing-symbols p) :test #'eq)))
					  (IF (EQ found :inherited)
					      (PUSH (CONS csym p) set-of-inherited-conflicting-symbols)
					      (PUSH (CONS csym p) set-of-directly-conflicting-symbols)))))
			1  ;; Handle name conflicts*
			  (COND ((AND set-of-directly-conflicting-symbols
				      set-of-inherited-conflicting-symbols)
				 (signal-proceed-case ((ignore) 'eh:name-conflict
						       (format t "~%Attempting to export ~s from the ~a package ~
would introduce the following name conflicts:" sym (package-name pkg))
						       sym	
						       (package-name pkg)
						       :export
						       (cons set-of-directly-conflicting-symbols
							     set-of-inherited-conflicting-symbols)
						       (progn (dolist (pair set-of-directly-conflicting-symbols)
								      (format t "~&~10t~s is present in the ~a package."
									      (car pair) (package-name (cdr pair))))
							      (dolist (pair set-of-inherited-conflicting-symbols)
								      (format t "~&~10t~? is accessible by inheritance ~
in the ~a package."
									      "~a:~a"
									      `(,(multiple-value-bind (ignore ignore pack)
										     (find-symbol (symbol-name (car pair))
												  (cdr pair))
										   (package-name pack))
										,(car pair))
									      (package-name (cdr pair))))))
						      (:export-both-conflict-types nil)
						      (:skip (go try-next-sym))
						      (:skip-all (return-from export t))))
				(set-of-directly-conflicting-symbols
				  (signal-proceed-case ((ignore) 'eh:name-conflict
							(format t "~%Attempting to export ~s from the ~a package ~
would introduce the following name conflicts:" sym (package-name pkg))
							sym	
							(package-name pkg)
							:export
							set-of-directly-conflicting-symbols
							(dolist (pair set-of-directly-conflicting-symbols)
								(format t "~&~10t~s is present in the ~a package."
									(car pair) (package-name (cdr pair)))))
						       (:export-present nil)
						       (:unintern-all nil)
						       (:shadow-all nil)
						       (:skip (go try-next-sym))
						       (:skip-all (return-from export t))))
				(set-of-inherited-conflicting-symbols
				  (signal-proceed-case ((ignore) 'eh:name-conflict
							(format t "~%Attempting to export ~s from the ~a package ~
would introduce the following name conflicts:" sym (package-name pkg))
							sym	
							(package-name pkg)
							:export
							set-of-inherited-conflicting-symbols
							(dolist (pair set-of-inherited-conflicting-symbols)
								(format t "~&~10t~? is accessible by inheritance ~
in the ~a package."
									"~a:~a"
									`(,(multiple-value-bind (ignore ignore pack)
									       (find-symbol (symbol-name (car pair))
											    (cdr pair))
									     (package-name pack))
									  ,(car pair))
									(package-name (cdr pair)))))
						       (:export-accessible-by-inheritance nil)
						       (:skip (go try-next-sym))
						       (:skip-all (return-from export t))))
				(t nil))
			  ))
		  1;; If we get here, then proceed with exporting <sym>.*
		  (IMPORT sym pkg)			
		  (EXTERNALIZE sym pkg)
		  try-next-sym
		  ))
      t)))