;;; This is a -*-Lisp-*- file.
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;;
;;; The package system.
;;; Written by Lee Schumacher.
;;; Bug fixes, iteration macros, and stuff like that courtesy Skef Wholey.
;;; See package chapter of the Common Lisp Reference Manual.
;;;
;;; Package print function.  Describe can be used to get other information
;;; about packages.

(defun print-package (package stream print-level)
  print-level					; ignored
  (write-string "#<The " stream)
  (write-string (package-name package) stream)
  (write-string " package>" stream))

(defstruct (package
	    (:constructor internal-make-package)
	    (:predicate packagep)
	    (:print-function print-package))
  (name "" :type string)
  (nicknames () :type list)
  (use-list () :type list) 
  (used-by-list () :type list)
  (internal-symbols (make-hash-table :test #'equal :size 300))
  (external-symbols (make-hash-table :test #'equal :size 300))
  (shadowing-symbols () :type list))


;;; Global variables.

(defvar *package-obarray* ()
  "Table of all package symbols.")

(defvar *package* () "The default package.")

;;; The cold loader builds two lists of symbols which should be put into the
;;; keyword package and Lisp package.

(defvar *initial-lisp-symbols*)
(defvar *initial-keyword-symbols*)

;;; Lots of people want the keyword package and Lisp package without a lot
;;; of fuss, so we give them their own variables.

(defvar *lisp-package*)
(defvar *keyword-package*)

;;;; Test functions and utilities.

;;; Calls cerror and handles the patch if the luser continues.
;;; Only returns when the new name is not in conflict with anything.
(defun handle-package-name-conflicts (name)
  (cerror "a new package name will be prompted for."
	  "Package name conflict with ~S." name)
  (write-string "Name: ")
  (do ((name (string (read)) (string (read))))
      (())
    (if (find-package name)
	(format t "There is already a package named ~S.~%Name: " name)
	(return name))))

;;; Check name checks for package-name conflicts, and replaces symbols with
;;; strings.
(defun check-name (string-or-symbol)
  (cond ((find-package string-or-symbol)
	 (handle-package-name-conflicts string-or-symbol))
	((symbolp string-or-symbol) (symbol-name string-or-symbol))
	(t string-or-symbol)))

;;; This fun handles name conflicts were uninterning a shadowing symbol
;;; leaves multiple choices for the replacement.
(defun handle-revealed-name-conflict (symbol conflict-list package)
  (let ((package-list (mapcar #'%sp-get-package conflict-list)))
    (cerror "Pick the package whose symbol you wish to import ~
	    from ~S."
	    "Uninterning shadowing symbol ~S leaves ~
	    more than one symbol with that name available."
	    symbol (mapcar #'package-name package-list))
    (do* ((new-package (find-package (read)))
	   (new-symbol (find-symbol (symbol-name symbol)
					     new-package)))
	 ((member new-package package-list)
	  (shadowing-import new-symbol package))
	 (format t "That package is not one of the choices, try again."))))
;;; 
;;;; Functions for handling packages.
;;; Provides error checking for the defstruct constructor function.
(defun make-package (name &rest keys)
  "Return a package object with the given name, assuming that no
  package already uses the name."
  (with-keywords keys ((:nicknames nick-names ())
		       (:use use (list (find-package 'lisp))))
		 (let* ((new-name (check-name name))
		       (new-nick-names (mapcar #'check-name nick-names))
		       (package-list (mapcar
				      #'(lambda (x)
					  (if (packagep x)
					      x (find-package x)))
				      use))
		       (package
			(internal-make-package :name new-name
					       :nicknames new-nick-names
					       :use-list package-list)))
		   ;; enter the nick-names in the *Package-Obarray*
		   (dolist (x (cons new-name new-nick-names))
			    (setf (gethash x *Package-Obarray*) package))
		   ;; set the use by's 
		   (dolist (x package-list)
		     (setf (package-used-by-list x)
			   (push package (package-used-by-list x))))
		   ;; return the new package object
		   package)))

;;; This function is substantially similar to make-package.
(defun in-package (name &rest keys)
  "Sets *package* to package with given name, nicknames, and use-list,
  modifying appropriate fields if the package already exists."
  (with-keywords keys ((:nicknames nicknames ())
		       (:use use ()))
    (setq *package*
	  (let* ((old-package (find-package name)))
	    (if old-package 
		(let ((new-nicknames (nset-difference
				      nicknames
				      (package-nicknames old-package)))
		      (new-use-list
		       (nset-difference
			(mapcar
			 #'(lambda (x) (if (packagep x) x (find-package x)))
			 use)
			(package-use-list old-package)))
		      (*package* old-package))
		  (mapcar #'use-package new-use-list)
		  (dolist (x new-nicknames)
		    (if (and (find-package x)
			     (not (eq (find-package x) old-package)))
			(progn
			 (cerror "Prompt for new nickname."
				 "Illegal nickname ~S for ~S, ~
					name is already used for ~S."
				 x old-package (find-package x))
			 (do ((y))
			     (y
			      (setf (package-nicknames old-package)
				    (push y
					  (package-nicknames
					   old-package))))
			   (format t "Enter a different nickname.")
			   (let ((answer (read)))
			     (if (or (not (find-package answer))
				     (eq (find-package answer)
					 old-package))
				 (setq y answer)))))
			(or (find-package x)
			    (setf (package-nicknames old-package)
				  (push x
					(package-nicknames
					 old-package))))))
		  old-package)
		(apply #'make-package name keys))))))

;; Gethash returns the correct value.
(defun find-package (name)
  "Find a package whose name is the string given, or the print name if it's a
  symbol."
  (gethash (if (symbolp name) (symbol-name name) (the string name))
	   *package-obarray*))

;;; Does the same checking as make-package, using check-name.
(defun rename-package (package name &optional (nicknames ()))
  "Substitute the args for the appropriate fields in the given package."
  (let ((new-name (check-name name))
	(new-nicknames (mapcar #'check-name nicknames)))
    (remhash (package-name package) *package-obarray*)
    (dolist (nick (package-nicknames package))
      (remhash nick *package-obarray*))
    (setf (gethash new-name *package-obarray*) package)
    (dolist (nick new-nicknames)
      (setf (gethash new-name *package-obarray*) package))
    (setf (package-name package) new-name)
    (setf (package-nicknames package) new-nicknames)))

(declare (special %lap-result))
;;; list-all-packages uses maphash and conses up a list from *package-obarray*
(defun list-all-packages ()
  "Return a list of all the packages in extent."
  (let ((%lap-result ()))
    (maphash #'(lambda (x y)
		 x
		 (pushnew y %lap-result))
	     *package-obarray*)
    %lap-result))
;;; 
;;;; Functions for handling symbols in packages.
;;; Looks for a symbol with name name using find-symbol,
;;; if its there, then the symbol is returned, o/w a new
;;; symbol with that name is created and returned.
;;; notes: name changed to intern when read knows not to send symbols.

(defun intern (name &optional (package *package*))
  "Intern looks for a symbol with the given name, and creates a new one if
  it doesn't exist."
 (multiple-value-bind (symbol test) (find-symbol name package)
    ;;second value of find-symbol is t if a symbol was found.	
    (if test
	(values symbol test)
	(let ((new-symbol))
	  (%primitive set-allocation-space 2)
	  (setq new-symbol (%primitive alloc-symbol name))
	  (%primitive set-allocation-space 0)
	  ;; Special case the keyword package.
	  (if (eq package *keyword-package*)
	      (progn 
	       (setq test :external)
	       (setf (gethash name (package-external-symbols package))
		     new-symbol)
	       ;; This will make the symbol eval to itself.
	       (set new-symbol new-symbol))
	      (progn 
	       (setf (gethash name (package-internal-symbols package))
		     new-symbol)
	       (setq test :internal)))
	  (%primitive set-package new-symbol package)
	  ;; return the symbol
	  (values new-symbol test)))))

;;; Find-symbol looks for the symbol named string in the
;;; internal and external symbol tables of the given package
;;; and in the external symbols table of the packages in the use-list.
(defun find-symbol (string &optional (package *package*))
  "Search for a symbol named string in package, does the same
  as intern but will never create a symbol."
  (multiple-value-bind (extern test)
		       (gethash string (package-external-symbols package))
    (if test
	(values extern :external)
	(multiple-value-bind (intern test)
			     (gethash string
				      (package-internal-symbols package))
	  (if test
	      (values intern :internal)
	      (dolist (x (package-use-list package) (values nil nil))
		 (multiple-value-bind (symbol test)
				      (gethash string
					       (package-external-symbols x))
		   (if test
		       (return (values symbol :inherited))))))))))
;;; 
;;;; Functions that have to do name conflict checking. (and there inverses)
;;; unintern checks to see if the symbol shadows anything. If it doesn't
;;; then the symbol is remhash'ed.
;;; Otherwise name conflicts are looked for and resolved if found,
;;; the symbol is removed the shadowing-symbols list and then 
;;; recurses.
(defun unintern (symbol &optional (package *package*))
  "Removes the symbol from the given package."
  (if (member (the symbol symbol)
	      (package-shadowing-symbols (the package package)))
      (let
       ;; The lambda returns nil if symbol was found in the package x,
       ;; under the assumption that the luser doesn't want that symbol
       ;; any more.
       ((symbol-list (delete-duplicates
		      (mapcar #'(lambda (x)
				  (multiple-value-bind
				   (new-symbol test)
				   (find-symbol (symbol-name symbol) x)
				   (if (eq test :external) new-symbol symbol)))
			      (package-use-list
			       package)))))
       ;; If there is only 1 element in symbol-list\symbol
       ;; then there is no conflict, and we go 
       ;; our merry way.
       (if (cdr (delete symbol symbol-list))
	   ;; handles the conflict, and calls unintern again.
	   (handle-revealed-name-conflict symbol symbol-list package)
	   (progn 
	    (setf (package-shadowing-symbols package)
		  (delete symbol (package-shadowing-symbols package)))
	    (unintern symbol package))))
      (let* ((name (symbol-name symbol))
	     (internal (multiple-value-list
			(gethash name (package-internal-symbols package)))))
	(if (eq (%primitive get-package symbol) package)
	    (%primitive set-package symbol nil))
	;; Remhash returns the proper value for the function.
	(if (second internal)(remhash name (package-internal-symbols package))
	    (remhash name (package-external-symbols package))))))

;;; Export does a find-symbol on each symbol in symbol list and
;;; for each package in the use-list of package. If a distinct symbol
;;; is found with the same name, a cerror is signaled.
(defun export (symbol-list &optional (package *package*))
  "Export makes it args external symbols in the given package,
  after checking for name conflicts in the used-by-list."
 (if (atom symbol-list) (setq symbol-list (list symbol-list)))
 (dolist (symbol symbol-list t)
   ;; If the thing is already external in the specified package, let it go.
   (multiple-value-bind (sym there)
			(gethash (symbol-name symbol)
				 (package-external-symbols package))
     (declare (ignore sym))
     (unless there
       (let* ((name (symbol-name (the symbol symbol)))
	      ;; Find all symbols with the same name that are accessible
	      ;; from packages using the given package.
	  (conflict-list (do ((x (package-used-by-list
				  (the package package))(cdr x))
			      (result))
			     ((null x) result)
			   (multiple-value-bind (conflict test)
						(find-symbol name (car x))
			     (if (and test
				      (not (member conflict
						   (package-shadowing-symbols
						    (car x)))))
				 (push (car x) result))))))
     (cond ((multiple-value-bind (x y)(find-symbol name package) (not y))
	    (cerror "prompt for importing the symbol."
		    "Symbol ~S not available in ~S." symbol package)
	    (if (y-or-n-p "Should the symbol be imported ?")
		(progn (import symbol package)
		       (export symbol package))))
	    ((null conflict-list)
	     (progn
	      (remhash name
		       (package-internal-symbols package))
	      (setf (gethash name (package-external-symbols package))
		    symbol)))
	    (t (progn
		(cerror	"prompt for choice between symbol present and ~
			inherited symbol on a symbol by symbol, or ~
			package basis."
			"Exporting symbol ~S causes name conflict in  ~
			the package~P ~S."
			symbol (length conflict-list) conflict-list)
		(cond ((y-or-n-p
			(format nil "Do you want the symbol already present to~
				 always take precedence ?"))
		       (dolist (x conflict-list)
			 (setf (package-shadowing-symbols x)
			       (push (find-symbol name x)
				     (package-shadowing-symbols x)))))
		      ((y-or-n-p
			(format nil "Do you want the symbol being exported to~
				 always take precedence ?"))
		       (dolist (x conflict-list)
			 (unintern (find-symbol name x) x)
			 (let ((old (find-symbol name x)))
			   (if (second old) 
			       (shadowing-import symbol x)))))
		      (t (dolist (x conflict-list)
			   (if (y-or-n-p (format nil "Should the symbol~
						 already present in package ~
						 ~S take precedence ?"
						 (package-name x)))
			       (push (find-symbol name x)
				     (package-shadowing-symbols x))
			       (unintern (find-symbol name x) x)))))
		(remhash name (package-internal-symbols package))
		(setf (gethash name (package-external-symbols package))
		      symbol)))))))))

;;; Needs no name conlict checking.
(defun unexport (symbol-list &optional (package *package*))
  "Makes the symbols unavailable to using packages. The inverse of export."
  (if (atom symbol-list) (setq symbol-list (list symbol-list)))
  (dolist (symbol symbol-list t)
    (let ((name (symbol-name (the symbol symbol))))
      (remhash name (package-external-symbols (the package package)))
      (setf (gethash name (package-internal-symbols package)) symbol))))

;;; Import does all sorts of name checking.  Allows conflict resolution
;;; only on a symbol by symbol basis.
(defun import (symbol-list &optional (package *package*))
  "Make the symbols in symbol-list available as internal symbols
  to using packages."
  (if (atom symbol-list) (setq symbol-list (list symbol-list)))
  (dolist (symbol symbol-list t)
    (multiple-value-bind (conflict test)
			 (find-symbol (symbol-name (the symbol symbol))
				      package)
      (if (and test (not (eq conflict symbol)))
	  (progn
	   (cerror "prompt for choice between old and new symbols."
		   "Symbol named ~S already available in ~S."
		   symbol package)
	   (if (y-or-n-p "Should the new symbol take precedence ?")
	       (shadowing-import symbol)))
	  (setf (gethash (symbol-name symbol)
			 (package-internal-symbols  package)) symbol)))))
;;; 
;;;; Functions that have no name conflicts.
;;; Does import without worrying about name conflicts. All symbols in 
;;; symbol-list are put on the shadowing-symbols-list.
(defun shadowing-import (symbol-list &optional (package *package*))
  "Imports symbols in symbol-list and adds them to the 
  shadowing-symbols list of package. "
  ;; take care of atoms so iteration works on boundary case
  ;; I do this in a number of other places.
  (if (atom symbol-list) (setq symbol-list (list symbol-list)))
  (dolist (symbol symbol-list t)
     (multiple-value-bind (old-symbol test)
		       (find-symbol (symbol-name (the symbol symbol))
				    package)
      (if (or (eq test :internal)
	      (eq test :external))
	  (progn 
	   ;; So unintern doesn't worry about name-conflicts.
	   (setf (package-shadowing-symbols package)
		 (delete old-symbol (package-shadowing-symbols package)))
	   (unintern old-symbol package)))
      (setf (package-shadowing-symbols package)
	    (push symbol (package-shadowing-symbols package)))
      (setf (gethash (symbol-name symbol)
		     (package-internal-symbols package)) symbol))))

;;; Puts symbols in symbol-list on the shadowing-symbols-list of the package.
(defun shadow (symbol-list &optional (package *package*))
  "Creates a shadow for the arguments, does nothing if the symbol
  is directly present already."
  (if (symbolp symbol-list) (setq symbol-list (list symbol-list)))
  (dolist (symbol symbol-list t)
    (multiple-value-bind (old-symbol test)
			 (find-symbol (symbol-name (the symbol symbol))
				      package)
      (if (or (null test) (eq test :inherited))
	  (let* ((name (symbol-name symbol))
		 (new-symbol))
	    (%primitive set-allocation-space 2)
	    (%primitive alloc-symbol name)
	    (%primitive set-allocation-space 0)
	    (%primitive set-package new-symbol package)	    
	    (setf (package-shadowing-symbols package)
		   (push new-symbol (package-shadowing-symbols package)))
	    (setf (gethash name (package-internal-symbols package))
		  new-symbol))))))

;;; Use-package does all sorts of name conflict checking. For each symbol
;;; in each package in package-list a find-symbol is done in
;;; %spec-package, and if a symbol is found, then an error is signalled.
;;; Allows conflict resolution on a package or symbol by symbol basis.
(defun use-package (package-list &optional (%spec-package *package*))
  "Put packages in package-list on the package use list of the given package." 
  (declare (special %spec-package))
  (setq package-list
	(mapcar
	 #'(lambda (x) (cond ((packagep x) x)
			     ((or (and x (symbolp x)) (stringp x))
			      (find-package x))
			     (t (error "Illegal arg ~S to use-package" x))))
	 (if (atom package-list) (list package-list) package-list)))
  (dolist (current package-list t)		
    (let ((%conflict-list ()))
      ;; the following gross hack due to maphash lossage. and no-lex eval.
      (declare (special %conflict-list))
      (maphash #'(lambda (x y)
		   (multiple-value-bind (symbol test)
					(find-symbol x %spec-package)
		     (if (and test
			      (not (member symbol
					   (package-shadowing-symbols
					    %spec-package)))
			      (not (eq symbol y)))
			 (pushnew symbol %conflict-list))))
	       (package-external-symbols current))
      (if (null %conflict-list)
	  (progn
	   (setf (package-use-list %spec-package)
		 (pushnew current (package-use-list %spec-package)))
	   (setf (package-used-by-list current)
		 (pushnew %spec-package (package-used-by-list current))))
	  (progn
	   (cerror "Prompt for which symbols take precedence."
		   "The symbol~P in ~S conflict with ~
		   one~P already present in ~S."
		   (length %conflict-list)
		   current (length %conflict-list) %spec-package)
	   (cond
	    ((y-or-n-p (format nil "Do you want the symbols currently present ~
			       in ~S to take precedence ? " %spec-package))
	     (dolist (x %conflict-list)(shadowing-import x %spec-package)))
	    ((y-or-n-p (format nil "Do you want the symbols in ~S ~
			       to take precedent ? " current))
	     (dolist (x %conflict-list)
	       (shadowing-import (find-symbol (symbol-name x) current)
				 %spec-package)))
	    (t (dolist (x %conflict-list)
		 (if (y-or-n-p (format nil "Should the symbol ~S currently ~
				       in ~S take precedence ? " x
				       %spec-package))
		     (shadowing-import x %spec-package)
		     (shadowing-import (find-symbol (symbol-name x)
						    current)
				       %spec-package)))))
	    (setf (package-use-list %spec-package)
		  (pushnew current (package-use-list %spec-package)))
	    (setf (package-used-by-list current)
		  (pushnew %spec-package (package-used-by-list current))))))))

;;; Unuse-package does no name conflict checking, it merely removes 
;;; the args from the given package.
(defun unuse-package (package-list &optional (package *package*))
  "Removes the packages in the first arg from the use-list of the second."
  (if (atom package-list)(setq package-list (list package-list)))
  (setq package-list
	(mapcar
	 #'(lambda (x) (cond ((packagep x) x)
			     ((or (symbolp x) (stringp x))
			      (find-package x))
			     (t
			      (error "Illegal arg to unuse-package ~S." x))))
	 package-list))  
  (dolist (x package-list)
    (setf (package-used-by-list x) (delete package (package-used-by-list x))))
  (setf (package-use-list package)
	(nset-difference  (package-use-list package) package-list))
  t)


(declare (special %fas-string %fas-result))
(defun find-all-symbols (string-or-symbol)
  "Looks for symbol name string in all packages."
  (let ((%fas-string (if (stringp string-or-symbol) string-or-symbol
		    (symbol-name string-or-symbol)))
	(%fas-result ()))
    (maphash #'(lambda (x y)
		 (multiple-value-bind (new test) (find-symbol %fas-string y)
		   (if (and test (not (eq test :inherited)))
		       (pushnew new %fas-result))))
	     *package-obarray*)
    %fas-result))

;;; Exported Lisp symbols.

(defun export-lisp-symbols ()
  (export '(

;;; Random things.

coerce
deftype
type-of
defun
eval-when

;;; In the "Predicates" chapter:

typep
subtypep
null
symbolp
atom
consp
listp
numberp
integerp
rationalp
floatp
complexp
characterp
stringp
bit-vector-p
vectorp
simple-vector-p
simple-string-p
simple-bit-vector-p
arrayp
packagep
functionp
compiled-function-p
commonp
eq
eql
equal
equalp
not
and
or

structurep
fixnump
bignump
bitp
short-floatp
single-floatp
long-floatp
double-floatp
ratiop

;;; In the "Control Structure" chapter:

quote
function
symbol-value
symbol-function
boundp
fboundp
special-form-p
set
setq
psetq
makunbound
fmakunbound
get-setf-method
get-setf-method-multiple-value
apply
funcall
call-arguments-limit
prog1
prog2
progn
let
let*
compiler-let
progv
flet
labels
macrolet
if
block
return-from
return
mapcar
maplist
mapc
mapl
mapcan
mapcon
tagbody
prog
prog*
go
values
multiple-values-limit
values-list
multiple-value-list
multiple-value-call
multiple-value-prog1
multiple-value-bind
multiple-value-setq
catch
unwind-protect
throw
macro-function

;;; In the "Macros" chapter:

macroexpand
macroexpand-1
*macroexpand-hook*

;;; In the "Declarations" chapter:

proclaim
declare
locally
the
special
type
ftype
function
inline
notinline
ignore
optimize
declaration

;;; In the "Symbols" chapter:

get
remprop
symbol-plist
getf
get-properties

symbol-name
samenamep
make-symbol
copy-symbol
gensym
gentemp
symbol-package
keywordp

;;; In the "Packages" chapter:

*package*
make-package
in-package
find-package
package-name
package-nicknames
rename-package
package-use-list
package-used-by-list
package-shadowing-symbols
list-all-packages
intern
find-symbol
unintern
export
unexport
import
shadowing-import
shadow
use-package
unuse-package
find-all-symbols
*modules*
provide
require

;;; In the "Numbers" chapter:

zerop
plusp
minusp
oddp
evenp

=
/=
<
>
<=
>=
max
min
+
-
*
/
1+
1-
conjugate
gcd
lcm

exp
expt
log
sqrt
isqrt
abs
phase
signum
sin
cos
tan
cis
asin
acos
atan
pi
sinh
cosh
tanh
asinh
acosh
atanh

float
rational
rationalize
numerator
denominator
floor
ceiling
truncate
round
mod
rem
ffloor
fceiling
fround
ftruncate
decode-float
scale-float
float-radix
float-sign
float-digits
float-precision
integer-decode-float
complex
realpart
imagpart

logior
logxor
logand
logeqv
lognand
lognor
logandc1
logandc2
logorc1
logorc2
boole
boole-clr
boole-set
boole-1
boole-2
boole-c1
boole-c2
boole-and
boole-ior
boole-xor
boole-eqv
boole-nand
boole-nor
boole-andc1
boole-andc2
boole-orc1
boole-orc2
lognot
logtest
logbitp
ash

logcount
integer-length
byte
byte-size
byte-position
ldb
ldb-test
mask-field
dpb
deposit-field

random
*random-state*
make-random-state
random-state-p

most-positive-fixnum
most-negative-fixnum
most-positive-short-float
least-positive-short-float
least-negative-short-float
most-negative-short-float
most-positive-single-float
least-positive-single-float
least-negative-single-float
most-negative-single-float
most-positive-double-float
least-positive-double-float
least-negative-double-float
most-negative-double-float
most-positive-long-float
least-positive-long-float
least-negative-long-float
most-negative-long-float
short-float-epsilon
single-float-epsilon
double-float-epsilon
long-float-epsilon
short-float-negative-epsilon
single-float-negative-epsilon
double-float-negative-epsilon
long-float-negative-epsilon

;;; In "Characters" chapter:

char-code-limit
char-font-limit
char-bits-limit
standard-char-p
graphic-char-p
string-char-p
alpha-char-p
upper-case-p
lower-case-p
both-case-p
digit-char-p
alphanumericp

char=
char/=
char<
char>
char<=
char>=
char-equal
char-not-equal
char-lessp
char-greaterp
char-not-greaterp
char-not-lessp

character
char-code
char-bits
char-font
code-char
make-char

char-upcase
char-downcase
digit-char
char-int
int-char
char-name
name-char

char-control-bit
char-meta-bit
char-hyper-bit
char-super-bit
char-bit
set-char-bit

;;; In the "Sequences" chapter:

elt
subseq
copy-seq
length
reverse
nreverse

make-sequence
concatenate
map
some
every
notany
notevery
reduce
fill
replace
remove
remove-if
remove-if-not
delete
delete-if
delete-if-not
remove-duplicates
delete-duplicates
substitute
substitute-if
substitute-if-not
nsubstitute
nsubstitute-if
nsubstitute-if-not

find
find-if
find-if-not
position
position-if
position-if-not
count
count-if
count-if-not
mismatch
search
sort
stable-sort
merge

;;; In the "Manipulating 'List Structure" chapter:

car
cdr
caar
cadr
cdar
cddr
caaar
caadr
cadar
caddr
cdaar
cdadr
cddar
cdddr
caaaar
caaadr
caadar
caaddr
cadaar
cadadr
caddar
cadddr
cdaaar
cdaadr
cdadar
cdaddr
cddaar
cddadr
cdddar
cddddr

cons
tree-equal
endp
list-length
nth
first
second
third
fourth
fifth
sixth
seventh
eighth
ninth
tenth

rest
nthcdr
last
list
list*
make-list
append
copy-list
copy-alist
copy-tree
revappend
nconc
nreconc
butlast
nbutlast
ldiff
rplaca
rplacd

subst
subst-if
subst-if-not
nsubst
nsubst-if
nsubst-if-not
sublis
nsublis

member
member-if
member-if-not
tailp
adjoin
union
nunion
intersection
nintersection
set-difference
nset-difference
set-exclusive-or
nset-exclusive-or
subsetp

acons
pairlis
assoc
assoc-if
assoc-if-not
rassoc
rassoc-if
rassoc-if-not

;;; In the Hash-Table chapter:

make-hash-table
hash-table-p
gethash
remhash
maphash
clrhash
hash-table-count
sxhash

;;; In the "Arrays" chapter:

make-array
array-rank-limit
array-dimension-limit
array-total-size-limit
vector
aref
array-element-type
array-rank
array-dimension
array-dimensions
array-in-bounds-p
array-row-major-index

svref
bit
sbit

bit-and
bit-ior
bit-xor
bit-eqv
bit-nand
bit-nor
bit-andc1
bit-andc2
bit-orc1
bit-orc2
bit-not

array-has-fill-pointer-p
fill-pointer
vector-push
vector-push-extend
vector-pop
adjust-array


;;; In the "Strings" chapter:

char
schar

string=
string-equal
string<
string>
string<=
string>=
string/=
string-lessp
string-greaterp
string-not-lessp
string-not-greaterp
string-not-equal

make-string
string-trim
string-left-trim
string-right-trim
string-upcase
string-downcase
string-capitalize
nstring-upcase
nstring-downcase
nstring-capitalize
string

;;; In the "Eval" chapter:

eval
*evalhook*
*applyhook*
*eval
evalhook
applyhook
constantp

;;; In the "Streams" chapter:

*standard-input*
*standard-output*
*error-output*
*query-io*
*debug-io*
*terminal-io*
*trace-output*

make-synonym-stream
make-broadcast-stream
make-concatenated-stream
make-two-way-stream
make-echo-stream
make-string-input-stream
make-string-output-stream
get-output-stream-string
streamp
input-stream-p
output-stream-p
close

;;; In the "Input/Output" chapter:

*read-base*
*readtable*
copy-readtable
readtablep
set-syntax-from-char
set-macro-character
get-macro-character
make-dispatch-macro-character
set-dispatch-macro-character
get-dispatch-macro-character

*print-escape*
*print-pretty*
*print-circle*
*print-base*
*print-radix*
*print-case*
*print-level*
*print-length*
*print-array*

read
*read-default-float-format*
read-preserving-whitespace
read-delimited-list
read-line
read-char
unread-char
peek-char
listen
read-char-no-hang
clear-input
read-from-string
parse-integer
read-byte
read-binary-object

write
prin1
print
pprint
princ
write-to-string
prin1-to-string
princ-to-string
write-char
write-string
write-line
terpri
fresh-line
finish-output
force-output
clear-output
write-byte
write-binary-object
format

y-or-n-p
yes-or-no-p

;;; In the "File System Interface" chapter:

pathname
truename
parse-namestring
merge-pathnames
make-pathname
pathnamep
pathname-host
pathname-device
pathname-directory
pathname-name
pathname-type
pathname-version
namestring
file-namestring
directory-namestring
host-namestring
enough-namestring
user-homedir-pathname
init-file-pathname
*default-pathname-defaults*

open
rename-file
delete-file
probe-file
file-creation-date
file-author
file-position
file-length
load
*load-verbose*
*load-set-default-pathname*
*load-pathname-defaults*
directory

;;; In the "Errors" chapter:

error
cerror
warn
*break-on-warnings*
break
check-type
assert
etypecase
ctypecase
ecase
ccase

;;; In the "Miscellaneous" Chapter.

compile
compile-file
*compile-file-set-default-pathname*
disassemble
documentation
describe
inspect
room
ed
dribble
apropos
apropos-list
get-decoded-time
get-universal-time
decode-universal-time
encode-universal-time
internal-time-units-per-second
get-internal-run-time
get-internal-real-time
sleep
lisp-implementation-type
lisp-implementation-version
machine-type
machine-version
machine-instance
software-type
software-version
short-site-name
long-site-name
*features*
identity

;;; These are extensions.

memq
assq
delq
compile-from-stream
uncompile
unproclaim
compiledp
quit
beep

;;; Names of features.

perq
spice
cmu

;;; Names of macros.

defmacro
defvar
defparameter
defconstant
if
when
unless
loop
do
do*
dotimes
dolist
setf
defsetf
psetf
shiftf
rotatef
push
pushnew
pop
incf
decf
putf
remf
case
cond
typecase
with-open-file
with-open-stream
with-input-from-string
with-output-to-string
compiler-let
locally

;;; Type names.

array
atom
bignum
bit
bit-vector
character
common
compiled-function
complex
cons
double-float
fixnum
float
function
hash-table
integer
keyword
list
long-float
nil
null
number
package
pathname
random-state
ratio
rational
readtable
sequence
short-float
signed-byte
simple-array
simple-bit-vector
simple-string
simple-vector
single-float
standard-char
stream
string
string-char
symbol
t
unsigned-byte
vector

;;; Things that were left out of the above:

backtrace
debug
trace
untrace
step
$g
$p
h
q
u
d
b
f
?
a
l
p
pp
debug-return
backtrace
debug-lexical
debug-special
debug-local
debug-show
debug-hide
debug-arg
debug-pc
compiled
active
functions
packages
frames
types
interpreted
lambdas

defstruct
grindef
gc

lambda
&optional
&rest
&key
&aux
&body
&whole

*keyword-package*
*lisp-package*
*prompt*
%put
+
++
+++
*
**
***
/
//
///
-

)
	  *lisp-package*))

;;; Initialization.

;;; The cold loader makes the lists *Initial-Lisp-Symbols* and
;;; *Initial-Keyword-Symbols*, which contain symbols to be put in those
;;; packages.  Here we create *Lisp-Package* and *Keyword-Package* and
;;; intern those symbols in them.

(defun package-init ()
  (setq *package-obarray* (make-hash-table :test #'equal))

  ;; Lisp package:
  (setq *lisp-package*
	(internal-make-package
	 :name "LISP"
	 :nicknames ()
	 :use-list ()
	 :used-by-list ()
	 :internal-symbols
	  (make-hash-table :size 3200 :rehash-size 1000 :test #'equal)
	 :external-symbols
	  (make-hash-table :size 1000 :rehash-size 1000 :test #'equal)
	 :shadowing-symbols ()))
  (setf (gethash "LISP" *package-obarray*) *lisp-package*)
  (dolist (symbol *initial-lisp-symbols*)
    (setf (gethash (symbol-name symbol)
		   (package-internal-symbols *lisp-package*))
	  symbol)
    (%primitive set-package symbol *lisp-package*))
  (setq *initial-lisp-symbols* 'gone!)		; So it gets GC'ed.
  (export-lisp-symbols)

  ;; Keyword package:
  (setq *keyword-package*
	(internal-make-package
	 :name "KEYWORD"
	 :nicknames '("")
	 :use-list ()
	 :used-by-list ()
	 :internal-symbols
	  (make-hash-table :size 1 :rehash-size 1 :test #'equal)
	 :external-symbols
	  (make-hash-table :size 250 :rehash-size 250 :test #'equal)
	 :shadowing-symbols ()))
  (setf (gethash "KEYWORD" *package-obarray*) *keyword-package*)
  (setf (gethash "" *package-obarray*) *keyword-package*)
  (dolist (symbol *initial-keyword-symbols*)
    (setf (gethash (symbol-name symbol)
		   (package-external-symbols *keyword-package*))
	  symbol)
    (%primitive set-package symbol *keyword-package*)
    (set symbol symbol))
  (setq *initial-keyword-symbols* 'gone!)	; So it gets GC'ed.

  ;; Common Lisp says that there's a System package, so here it is:
  (make-package "SYSTEM")

  ;; Lastly and leastly, the luser's package:
  (make-package "USER")

  ;; For the kernel core image wizards, set the package to *Lisp-Package*.
  (setq *package* *lisp-package*))

;;; Iteration macros:

;;; Instead of using slow, silly successor functions, we make the iteration
;;; guys be big PROG's.  Yea!

(eval-when (compile load eval)

(defun make-do-symbols-vars ()
  `(,(gensym)					; index
    ,(gensym)					; hash-vector
    ,(gensym)					; terminus
    ,(gensym)))					; bucket

(defun make-do-symbols-code (vars var hash-table exit-form forms)
  (let ((index (first vars))
	(hash-vector (second vars))
	(terminus (third vars))
	(bucket (fourth vars))
	(TOP (gensym))
	(BUCKET-LOOP (gensym)))
    `((setq ,index 0)
      (setq ,hash-vector (hash-table-table ,hash-table))
      (setq ,terminus (length (the simple-vector ,hash-vector)))
      ,TOP
      (if (= ,index ,terminus)
	  ,exit-form)
      (setq ,bucket (svref ,hash-vector ,index))
      ,BUCKET-LOOP
      (unless ,bucket
	(incf ,index)
	(go ,TOP))
      (let ((,var (cdar ,bucket)))
	,@forms)
      (setq ,bucket (cdr ,bucket))
      (go ,BUCKET-LOOP))))

)

(defmacro do-symbols ((var &optional (package '*package*) result-form)
		      &rest forms)
  "Executes the Forms once for each symbol in the given Package with Var bound
  to the current symbol."
  (let* ((TAG (gensym))
	 (vars (make-do-symbols-vars))
	 (internal-code (make-do-symbols-code vars
			 var `(package-internal-symbols ,package)
			 `(go ,TAG)
			 forms))
	 (external-code (make-do-symbols-code vars
			 var `(package-external-symbols ,package)
			 `(return ,result-form)
			 forms)))
    `(prog ,vars
	   ,@internal-code
	   ,TAG
	   ,@external-code)))

(defmacro do-external-symbols ((var &optional (package '*package*) result-form)
			       &rest forms)
  "Executes the Forms once for each external symbol in the given Package with
  Var bound to the current symbol."
  (let ((vars (make-do-symbols-vars)))
    `(prog ,vars
	   ,@(make-do-symbols-code vars
	      var `(package-external-symbols ,package)
	      `(return ,result-form)
	      forms))))

(defmacro do-all-symbols ((var &optional result-form)
			  &rest forms)
  "Executes the Forms once for each symbol in each package with Var bound
  to the current symbol."
  (let* ((PACKAGE-LOOP (gensym))
	 (TAG (gensym))
	 (package-list (gensym))
	 (vars (make-do-symbols-vars))
	 (internal-code (make-do-symbols-code vars
			 var `(package-internal-symbols (car ,package-list))
			 `(go ,TAG)
			 forms))
	 (external-code (make-do-symbols-code vars
			 var `(package-external-symbols (car ,package-list))
			 `(progn (setq ,package-list (cdr ,package-list))
				 (go ,PACKAGE-LOOP))
			 forms)))
    `(prog ,(cons package-list vars)
	   (setq ,package-list (list-all-packages))
           ,PACKAGE-LOOP
           (if (null ,package-list)
	       (return ,result-form))
	   ,@internal-code
	   ,TAG
	   ,@external-code)))

;;; Apropos and Apropos-List.

(defun briefly-describe-symbol (symbol)
  (fresh-line)
  (prin1 symbol)
  (when (boundp symbol)
    (write-string ", value: ")
    (prin1 (symbol-value symbol)))
  (if (fboundp symbol)
      (write-string ", defined.")
      (write-char #\.)))

(defun apropos (string &optional (package *package*))
  (let ((string (coerce string 'simple-string)))
    (declare (simple-string string))
    (if (null package)
	(do-all-symbols (symbol)
	   (if (search string (the simple-string (symbol-name symbol)))
	       (briefly-describe-symbol symbol)))
	(do-symbols (symbol package)
	   (if (search string (the simple-string (symbol-name symbol)))
	       (briefly-describe-symbol symbol))))
    (values)))

(defun apropos-list (string &optional (package *package*))
  (let ((string (coerce string 'simple-string))
	(list '()))
    (declare (simple-string string))
    (if (null package)
	(do-all-symbols (symbol)
	   (if (search string (the simple-string (symbol-name symbol)))
	       (push symbol list)))
	(do-symbols (symbol package)
	   (if (search string (the simple-string (symbol-name symbol)))
	       (push symbol list))))
    list))