package.lisp 51.5 KB
Newer Older
ram's avatar
ram committed
1
2
3
;;; -*- Log: code.log; Package: Lisp -*-
;;;
;;; **********************************************************************
4
5
6
7
8
9
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
10
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.35 1994/02/04 15:24:38 wlott Exp $")
11
;;;
ram's avatar
ram committed
12
13
14
15
16
17
;;; **********************************************************************
;;;
;;;     Package stuff and stuff like that.
;;;
;;; Re-Written by Rob MacLachlan.  Earlier version written by
;;; Lee Schumacher.  Apropos & iteration macros courtesy of Skef Wholey.
18
;;; Defpackage by Dan Zigmond.  With-Package-Iterator by Blaine Burks. 
19
;;; Defpackage and do-mumble-symbols macros re-written by William Lott.
ram's avatar
ram committed
20
;;;
21
(in-package "LISP")
ram's avatar
ram committed
22
(export '(package packagep *package* make-package in-package find-package
23
	  package-name package-nicknames rename-package delete-package
ram's avatar
ram committed
24
25
26
	  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
wlott's avatar
wlott committed
27
	  unuse-package find-all-symbols do-symbols with-package-iterator
28
	  do-external-symbols do-all-symbols apropos apropos-list defpackage))
ram's avatar
ram committed
29
30

(in-package "EXTENSIONS")
31
32
(export '(*keyword-package* *lisp-package* *default-package-use-list*
			    map-apropos))
33
34
35
36

(in-package "KERNEL")
(export '(%in-package old-in-package))

37
(in-package "LISP")
ram's avatar
ram committed
38

39
40
41
42
(defvar *default-package-use-list* '("COMMON-LISP")
  "The list of packages to use by default of no :USE argument is supplied
   to MAKE-PACKAGE or other package creation forms.")

ram's avatar
ram committed
43
44
45
46

(defstruct (package
	    (:constructor internal-make-package)
	    (:predicate packagep)
47
	    (:print-function %print-package)
wlott's avatar
wlott committed
48
49
50
51
	    (:make-load-form-fun
	     (lambda (package)
	       (values `(package-or-lose ',(package-name package))
		       nil))))
ram's avatar
ram committed
52
53
54
55
56
57
  "Standard structure for the description of a package.  Consists of 
   a list of all hash tables, the name of the package, the nicknames of
   the package, the use-list for the package, the used-by- list, hash-
   tables for the internal and external symbols, and a list of the
   shadowing symbols."
  (tables (list nil))	; A list of all the hashtables for inherited symbols.
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
  ;;
  ;; The string name of the package.
  (%name nil :type (or simple-string null))
  ;;
  ;; List of nickname strings.
  (%nicknames () :type list)
  ;;
  ;; List of packages we use.
  (%use-list () :type list)
  ;;
  ;; List of packages that use this package.
  (%used-by-list () :type list)
  ;;
  ;; Hashtables of internal & external symbols.
  (internal-symbols (required-argument) :type package-hashtable)
  (external-symbols (required-argument) :type package-hashtable)
  ;;
  ;; List of shadowing symbols.
  (%shadowing-symbols () :type list))


(defun %print-package (s stream d)
  (declare (ignore d) (stream stream))
  (if (package-%name s)
      (multiple-value-bind (iu it) (internal-symbol-count s)
	(multiple-value-bind (eu et) (external-symbol-count s)
	  (print-unreadable-object (s stream)
85
	    (format stream "The ~A package, ~D/~D internal, ~D/~D external"
86
87
		    (package-%name s) iu it eu et))))
      (print-unreadable-object (s stream :identity t)
88
	(format stream "deleted package"))))
89
90
91
92
93

;;; Can get the name (NIL) of a deleted package.
;;;
(defun package-name (x)
  (package-%name (if (packagep x) x (package-or-lose x))))
94
95
96
97
98
99
100

(macrolet ((frob (ext real)
	     `(defun ,ext (x) (,real (package-or-lose x)))))
  (frob package-nicknames package-%nicknames)
  (frob package-use-list package-%use-list)
  (frob package-used-by-list package-%used-by-list)
  (frob package-shadowing-symbols package-%shadowing-symbols))
ram's avatar
ram committed
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139

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

;;; An equal hashtable from package names to packages.
;;;
(defvar *package-names* (make-hash-table :test #'equal))


;;; 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*)


;;; This magical variable is T during initialization so Use-Package's of packages
;;; that don't yet exist quietly win.  Such packages are thrown onto the list
;;; *Deferred-Use-Packages* so that this can be fixed up later.

(defvar *in-package-init* nil)
(defvar *deferred-use-packages* nil)

;;; Find-Package  --  Public
;;;
;;;
(defun find-package (name)
  "Find the package having the specified name."
  (values (gethash (string name) *package-names*)))

;;; Package-Listify  --  Internal
;;;
;;;    Return a list of packages given a package-or-string-or-symbol or
;;; list thereof, or die trying.
;;;
(defun package-listify (thing)
  (let ((res ()))
    (dolist (thing (if (listp thing) thing (list thing)) res)
      (push (package-or-lose thing) res))))

140
141
142
143
144
145
146
147
148
;;; PACKAGE-NAMIFY  --  Internal
;;;
;;;    Make a package name into a simple-string.
;;;
(defun package-namify (n)
  (if (symbolp n)
      (symbol-name n)
      (coerce n 'simple-string)))

ram's avatar
ram committed
149
150
151
152
153
;;; Package-Or-Lose  --  Internal
;;;
;;;    Take a package-or-string-or-symbol and return a package.
;;;
(defun package-or-lose (thing)
154
155
156
157
158
  (cond ((packagep thing)
	 (unless (package-%name thing)
	   (error "Can't do anything to a deleted package: ~S" thing))
	 thing)
	(t
159
160
161
162
163
164
	 (let ((thing (package-namify thing)))
	   (cond ((gethash thing *package-names*))
		 (t
		  (cerror "Make this package."
			  "~S is not the name of a package." thing)
		  (make-package thing)))))))
165

ram's avatar
ram committed
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183

;;;; Package-Hashtables
;;;
;;;    Packages are implemented using a special kind of hashtable.  It is
;;; an open hashtable with a parallel 8-bit I-vector of hash-codes.  The
;;; primary purpose of the hash for each entry is to reduce paging by
;;; allowing collisions and misses to be detected without paging in the
;;; symbol and pname for an entry.  If the hash for an entry doesn't
;;; match that for the symbol that we are looking for, then we can
;;; go on without touching the symbol, pname, or even hastable vector.
;;;    It turns out that, contrary to my expectations, paging is a very
;;; important consideration the design of the package representation.
;;; Using a similar scheme without the entry hash, the fasloader was
;;; spending more than half its time paging in INTERN.
;;;    The hash code also indicates the status of an entry.  If it zero,
;;; the the entry is unused.  If it is one, then it is deleted.
;;; Double-hashing is used for collision resolution.

184
185
(deftype hash-vector () '(simple-array (unsigned-byte 8) (*)))

ram's avatar
ram committed
186
187
188
189
190
(defstruct (package-hashtable
	    (:constructor internal-make-package-hashtable ())
	    (:copier nil)
	    (:print-function
	     (lambda (table stream d)
191
	       (declare (ignore d) (stream stream))
ram's avatar
ram committed
192
193
194
195
196
	       (format stream
		       "#<Package-Hashtable: Size = ~D, Free = ~D, Deleted = ~D>"
		       (package-hashtable-size table)
		       (package-hashtable-free table)
		       (package-hashtable-deleted table)))))
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
  ;;
  ;; The g-vector of symbols.
  (table nil :type (or simple-vector null))
  ;;
  ;; The i-vector of pname hash values.
  (hash nil :type (or hash-vector null))
  ;;
  ;; The maximum number of entries allowed.
  (size 0 :type index)
  ;;
  ;; The entries that can be made before we have to rehash.
  (free 0 :type index)
  ;;
  ;; The number of deleted entries.
  (deleted 0 :type index))
ram's avatar
ram committed
212
213
214
215
216
217
218
219
220
221
222
223


;;; The maximum density we allow in a package hashtable.
;;;
(defparameter package-rehash-threshold 3/4)

;;; Entry-Hash  --  Internal
;;;
;;;    Compute a number from the sxhash of the pname and the length which
;;; must be between 2 and 255.
;;;
(defmacro entry-hash (length sxhash)
224
225
226
227
228
229
230
231
232
233
  `(the fixnum
	(+ (the fixnum
		(rem (the fixnum
			  (logxor ,length
				  ,sxhash
				  (the fixnum (ash ,sxhash -8))
				  (the fixnum (ash ,sxhash -16))
				  (the fixnum (ash ,sxhash -19))))
		     254))
	   2)))
ram's avatar
ram committed
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250

;;; Make-Package-Hashtable  --  Internal
;;;
;;;    Make a package hashtable having a prime number of entries at least
;;; as great as (/ size package-rehash-threshold).  If Res is supplied,
;;; then it is destructively modified to produce the result.  This is
;;; useful when changing the size, since there are many pointers to
;;; the hashtable.
;;;
(defun make-package-hashtable (size &optional
				    (res (internal-make-package-hashtable)))
  (do ((n (logior (truncate size package-rehash-threshold) 1)
	  (+ n 2)))
      ((primep n)
       (setf (package-hashtable-table res)
	     (make-array n))
       (setf (package-hashtable-hash res)
251
252
	     (make-array n :element-type '(unsigned-byte 8)
			 :initial-element 0))
ram's avatar
ram committed
253
254
255
256
257
258
259
260
261
262
263
264
265
       (let ((size (truncate (* n package-rehash-threshold))))
	 (setf (package-hashtable-size res) size)
	 (setf (package-hashtable-free res) size))
       (setf (package-hashtable-deleted res) 0)
       res)
    (declare (fixnum n))))


;;; Internal-Symbol-Count, External-Symbols-Count  --  Internal
;;;
;;;    Return internal and external symbols.  Used by Genesis and stuff.
;;;
(flet ((stuff (table)
266
267
268
269
270
271
272
273
274
275
	 (let ((size (the fixnum
			  (- (the fixnum (package-hashtable-size table))
			     (the fixnum
				  (package-hashtable-deleted table))))))
	   (declare (fixnum size))
	   (values (the fixnum
			(- size
			   (the fixnum
				(package-hashtable-free table))))
		   size))))
ram's avatar
ram committed
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292

  (defun internal-symbol-count (package)
    (stuff (package-internal-symbols package)))

  (defun external-symbol-count (package)
    (stuff (package-external-symbols package))))


;;; Add-Symbol  --  Internal
;;;
;;;    Add a symbol to a package hashtable.  The symbol is assumed
;;; not to be present.
;;;
(defun add-symbol (table symbol)
  (let* ((vec (package-hashtable-table table))
	 (hash (package-hashtable-hash table))
	 (len (length vec))
293
	 (sxhash (%sxhash-simple-string (symbol-name symbol)))
ram's avatar
ram committed
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
	 (h2 (the fixnum (1+ (the fixnum (rem sxhash
					      (the fixnum (- len 2))))))))
    (declare (simple-vector vec)
	     (type (simple-array (unsigned-byte 8)) hash)
	     (fixnum len sxhash h2))
    (cond ((zerop (the fixnum (package-hashtable-free table)))
	   (make-package-hashtable (the fixnum
					(* (the fixnum
						(package-hashtable-size table))
					   2))
				   table)
	   (add-symbol table symbol)
	   (dotimes (i len)
	     (declare (fixnum i))
	     (when (> (the fixnum (aref hash i)) 1)
	       (add-symbol table (svref vec i)))))
	  (t
	   (do ((i (rem sxhash len) (rem (+ i h2) len)))
	       ((< (the fixnum (aref hash i)) 2)
		(if (zerop (the fixnum (aref hash i)))
		    (decf (the fixnum (package-hashtable-free table)))
		    (decf (the fixnum (package-hashtable-deleted table))))
		(setf (svref vec i) symbol)
		(setf (aref hash i)
318
319
		      (entry-hash (length (the simple-string
					       (symbol-name symbol)))
ram's avatar
ram committed
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
				  sxhash)))
	     (declare (fixnum i)))))))

;;; With-Symbol  --  Internal
;;;
;;;    Find where the symbol named String is stored in Table.  Index-Var
;;; is bound to the index, or NIL if it is not present.  Symbol-Var
;;; is bound to the symbol.  Length and Hash are the length and sxhash
;;; of String.  Entry-Hash is the entry-hash of the string and length.
;;;
(defmacro with-symbol ((index-var symbol-var table string length sxhash
				  entry-hash)
		       &body forms)
  (let ((vec (gensym)) (hash (gensym)) (len (gensym)) (h2 (gensym))
	(name (gensym)) (name-len (gensym)) (ehash (gensym)))
    `(let* ((,vec (package-hashtable-table ,table))
	    (,hash (package-hashtable-hash ,table))
	    (,len (length ,vec))
338
339
	    (,h2 (1+ (the index (rem (the index ,sxhash)
				      (the index (- ,len 2)))))))
wlott's avatar
wlott committed
340
       (declare (type (simple-array (unsigned-byte 8) (*)) ,hash)
ram's avatar
ram committed
341
		(simple-vector ,vec)
342
343
		(type index ,len ,h2))
       (prog ((,index-var (rem (the index ,sxhash) ,len))
ram's avatar
ram committed
344
	      ,symbol-var ,ehash)
345
	 (declare (type (or index null) ,index-var))
ram's avatar
ram committed
346
347
348
349
350
351
352
	 LOOP
	 (setq ,ehash (aref ,hash ,index-var))
	 (cond ((eql ,ehash ,entry-hash)
		(setq ,symbol-var (svref ,vec ,index-var))
		(let* ((,name (symbol-name ,symbol-var))
		       (,name-len (length ,name)))
		  (declare (simple-string ,name)
353
			   (type index ,name-len))
ram's avatar
ram committed
354
355
356
357
358
359
360
		  (when (and (= ,name-len ,length)
			     (string= ,string ,name  :end1 ,length
				      :end2 ,name-len))
		    (go DOIT))))
	       ((zerop ,ehash)
		(setq ,index-var nil)
		(go DOIT)))
361
362
363
	 (setq ,index-var (+ ,index-var ,h2))
	 (when (>= ,index-var ,len)
	   (setq ,index-var (- ,index-var ,len)))
ram's avatar
ram committed
364
365
366
367
368
369
370
371
372
373
374
	 (go LOOP)
	 DOIT
	 (return (progn ,@forms))))))

;;; Nuke-Symbol  --  Internal
;;;
;;;    Delete the entry for String in Table.  The entry must exist.
;;;
(defun nuke-symbol (table string)
  (declare (simple-string string))
  (let* ((length (length string))
375
	 (hash (%sxhash-simple-string string))
ram's avatar
ram committed
376
	 (ehash (entry-hash length hash)))
377
    (declare (type index length hash))
ram's avatar
ram committed
378
379
380
381
382
383
384
385
    (with-symbol (index symbol table string length hash ehash)
      (setf (aref (package-hashtable-hash table) index) 1)
      (setf (aref (package-hashtable-table table) index) nil)
      (incf (package-hashtable-deleted table)))))

;;;; Iteration macros.

(defmacro do-symbols ((var &optional (package '*package*) result-form)
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
		      &body body)
  "DO-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECLARATION}* {TAG | FORM}*
   Executes the FORMs at least once for each symbol accessible in the given
   PACKAGE with VAR bound to the current symbol."
  (let ((flet-name (gensym "DO-SYMBOLS-")))
    `(block nil
       (flet ((,flet-name (,var) ,@body))
	 (let* ((package (package-or-lose ,package))
		(shadows (package-%shadowing-symbols package)))
	   (flet ((iterate-over-hash-table (table ignore)
		    (let ((hash-vec (package-hashtable-hash table))
			  (sym-vec (package-hashtable-table table)))
		      (declare (type (simple-array (unsigned-byte 8) (*))
				     hash-vec)
			       (type simple-vector sym-vec))
		      (dotimes (i (length sym-vec))
			(when (>= (aref hash-vec i) 2)
			  (let ((sym (aref sym-vec i)))
404
405
			    (declare (inline member))
			    (unless (member sym ignore :test #'eq)
406
407
408
			      (,flet-name sym))))))))
	     (iterate-over-hash-table (package-internal-symbols package) nil)
	     (iterate-over-hash-table (package-external-symbols package) nil)
409
410
411
	     (dolist (use (package-%use-list package))
	       (iterate-over-hash-table (package-external-symbols use)
					shadows)))))
412
413
414
       (let ((,var nil))
	 (declare (ignorable ,var))
	 ,result-form))))
ram's avatar
ram committed
415
416

(defmacro do-external-symbols ((var &optional (package '*package*) result-form)
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
			       &body body)
  "DO-EXTERNAL-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECL}* {TAG | FORM}*
   Executes the FORMs once for each external symbol in the given PACKAGE with
   VAR bound to the current symbol."
  (let ((flet-name (gensym "DO-SYMBOLS-")))
    `(block nil
       (flet ((,flet-name (,var)
		,@body))
	 (let* ((package (package-or-lose ,package))
		(table (package-external-symbols package))
		(hash-vec (package-hashtable-hash table))
		(sym-vec (package-hashtable-table table)))
	   (declare (type (simple-array (unsigned-byte 8) (*))
			  hash-vec)
		    (type simple-vector sym-vec))
	   (dotimes (i (length sym-vec))
	     (when (>= (aref hash-vec i) 2)
	       (,flet-name (aref sym-vec i))))))
       (let ((,var nil))
	 (declare (ignorable ,var))
	 ,result-form))))

(defmacro do-all-symbols ((var &optional result-form) &body body)
  "DO-ALL-SYMBOLS (VAR [RESULT-FORM]) {DECLARATION}* {TAG | FORM}*
   Executes the FORMs once for each symbol in every package with VAR bound
   to the current symbol."
  (let ((flet-name (gensym "DO-SYMBOLS-")))
    `(block nil
       (flet ((,flet-name (,var)
		,@body))
	 (dolist (package (list-all-packages))
	   (flet ((iterate-over-hash-table (table)
		    (let ((hash-vec (package-hashtable-hash table))
			  (sym-vec (package-hashtable-table table)))
		      (declare (type (simple-array (unsigned-byte 8) (*))
				     hash-vec)
			       (type simple-vector sym-vec))
		      (dotimes (i (length sym-vec))
			(when (>= (aref hash-vec i) 2)
			  (,flet-name (aref sym-vec i)))))))
	     (iterate-over-hash-table (package-internal-symbols package))
	     (iterate-over-hash-table (package-external-symbols package)))))
       (let ((,var nil))
	 (declare (ignorable ,var))
	 ,result-form))))

ram's avatar
ram committed
463

wlott's avatar
wlott committed
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
;;;; WITH-PACKAGE-ITERATOR

(defmacro with-package-iterator ((mname package-list &rest symbol-types)
				 &body body)
  (let* ((packages (gensym))
	 (these-packages (gensym))
	 (ordered-types (let ((res nil))
			  (dolist (kind '(:inherited :external :internal)
					res)
			    (when (member kind symbol-types)
			      (push kind res)))))  ; Order symbol-types.
	 (counter (gensym))
	 (kind (gensym))
	 (hash-vector (gensym))
	 (vector (gensym))
	 (package-use-list (gensym))
	 (init-macro (gensym))
	 (end-test-macro (gensym))
	 (real-symbol-p (gensym))
	 (BLOCK (gensym)))
    `(let* ((,these-packages ,package-list)
	    (,packages `,(mapcar #'(lambda (package)
				     (if (packagep package)
					 package
					 (find-package package)))
				 (if (consp ,these-packages)
				     ,these-packages
				     (list ,these-packages))))
	    (,counter nil)
	    (,kind (car ,packages))
	    (,hash-vector nil)
	    (,vector nil)
	    (,package-use-list nil))
       ,(if (member :inherited ordered-types)
498
	    `(setf ,package-use-list (package-%use-list (car ,packages)))
wlott's avatar
wlott committed
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
	    `(declare (ignore ,package-use-list)))
       (macrolet ((,init-macro (next-kind)
 	 (let ((symbols (gensym)))
	   `(progn
	      (setf ,',kind ,next-kind)
	      (setf ,',counter nil)
	      ,(case next-kind
		 (:internal
		  `(let ((,symbols (package-internal-symbols
				    (car ,',packages))))
		     (setf ,',vector (package-hashtable-table ,symbols))
		     (setf ,',hash-vector (package-hashtable-hash ,symbols))))
		 (:external
		  `(let ((,symbols (package-external-symbols
				    (car ,',packages))))
		     (setf ,',vector (package-hashtable-table ,symbols))
		     (setf ,',hash-vector (package-hashtable-hash ,symbols))))
		 (:inherited
		  `(let ((,symbols (package-external-symbols
				    (car ,',package-use-list))))
		     (setf ,',vector (package-hashtable-table ,symbols))
		     (setf ,',hash-vector (package-hashtable-hash ,symbols))))))))
		  (,end-test-macro (this-kind)
		     `,(let ((next-kind (cadr (member this-kind
						      ',ordered-types))))
			 (if next-kind
			     `(,',init-macro ,next-kind)
			     `(if (endp (setf ,',packages (cdr ,',packages)))
				  (return-from ,',BLOCK)
				  (,',init-macro ,(car ',ordered-types)))))))
	 (when ,packages
	   ,(when (null symbol-types)
	      (error "Must supply at least one of :internal, :external, or ~
	      :inherited."))
	   ,(dolist (symbol symbol-types)
	      (unless (member symbol '(:internal :external :inherited))
		(error "~S is not one of :internal, :external, or :inherited."
		       symbol)))
	   (,init-macro ,(car ordered-types))
	   (flet ((,real-symbol-p (number)
		    (> number 1)))
	     (macrolet ((,mname ()
	      `(block ,',BLOCK
		 (loop
		   (case ,',kind
		     ,@(when (member :internal ',ordered-types)
			 `((:internal
			    (setf ,',counter
				  (position-if #',',real-symbol-p ,',hash-vector
					       :start (if ,',counter
							  (1+ ,',counter)
							  0)))
			    (if ,',counter
				(return-from ,',BLOCK
				 (values t (svref ,',vector ,',counter)
					 ,',kind (car ,',packages)))
				(,',end-test-macro :internal)))))
		     ,@(when (member :external ',ordered-types)
			 `((:external
			    (setf ,',counter
				  (position-if #',',real-symbol-p ,',hash-vector
					       :start (if ,',counter
							  (1+ ,',counter)
							  0)))
			    (if ,',counter
				(return-from ,',BLOCK
				 (values t (svref ,',vector ,',counter)
					 ,',kind (car ,',packages)))
				(,',end-test-macro :external)))))
		     ,@(when (member :inherited ',ordered-types)
			 `((:inherited
			    (setf ,',counter
				  (position-if #',',real-symbol-p ,',hash-vector
					       :start (if ,',counter
							  (1+ ,',counter)
							  0)))
			    (cond (,',counter
				   (return-from
				    ,',BLOCK
				    (values t (svref ,',vector ,',counter)
					    ,',kind (car ,',packages))))
				  (t
				   (setf ,',package-use-list
					 (cdr ,',package-use-list))
				   (cond ((endp ,',package-use-list)
					  (setf ,',packages (cdr ,',packages))
					  (when (endp ,',packages)
					    (return-from ,',BLOCK))
					  (setf ,',package-use-list
588
						(package-%use-list
wlott's avatar
wlott committed
589
590
591
592
593
594
						 (car ,',packages)))
					  (,',init-macro ,(car ',ordered-types)))
					 (t (,',init-macro :inherited)
					    (setf ,',counter nil)))))))))))))
	       ,@body)))))))

595
596
597

;;;; DEFPACKAGE:

598
599
600
601
602
603
604
605
606
607
608
609
610
611
(defmacro defpackage (package &rest options)
  "Defines a new package called PACKAGE.  Each of OPTIONS should be one of the
   following:
     (:NICKNAMES {package-name}*)
     (:SIZE <integer>)
     (:SHADOW {symbol-name}*)
     (:SHADOWING-IMPORT-FROM <package-name> {symbol-name}*)
     (:USE {package-name}*)
     (:IMPORT-FROM <package-name> {symbol-name}*)
     (:INTERN {symbol-name}*)
     (:EXPORT {symbol-name}*)
   All options except :SIZE can be used multiple times."
  (let ((nicknames nil)
	(size nil)
612
	(shadows nil)
613
614
615
	(shadowing-imports nil)
	(use nil)
	(use-p nil)
616
617
	(imports nil)
	(interns nil)
618
619
620
621
622
623
624
625
	(exports nil)
	(incomming nil)
	(outgoing nil))
    (dolist (option options)
      (unless (consp option)
	(error "Bogus DEFPACKAGE option: ~S" option))
      (case (car option)
	(:nicknames
wlott's avatar
wlott committed
626
	 (let ((new (stringify-names (cdr option) "package")))
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
	   (setf nicknames (append-unique new nicknames :nicknames))))
	(:size
	 (cond (size
		(error "Can't specify :SIZE twice."))
	       ((and (consp (cdr option))
		     (typep (second option) 'unsigned-byte))
		(setf size (second option)))
	       (t
		(error "Bogus :SIZE, must be a positive integer: ~S"
		       (second option)))))
	(:shadow
	 (let ((new (stringify-names (cdr option) "symbol")))
	   (setf incomming (append-unique new incomming :shadow))
	   (setf shadows (append shadows new))))
	(:shadowing-import-from
	 (let ((package-name (stringify-name (second option) "package"))
	       (names (stringify-names (cddr option) "symbol")))
	   (setf incomming (append-unique names incomming :shadowing-import))
	   (let ((assoc (assoc package-name shadowing-imports
			       :test #'string=)))
	     (if assoc
		 (setf (cdr assoc) (append (cdr assoc) names))
		 (setf shadowing-imports
		       (acons package-name names shadowing-imports))))))
	(:use
wlott's avatar
wlott committed
652
	 (let ((new (stringify-names (cdr option) "package")))
653
	   (setf use (append-unique new use :use))
654
655
656
657
658
659
660
661
662
663
664
665
666
	   (setf use-p t)))
	(:import-from
	 (let ((package-name (stringify-name (second option) "package"))
	       (names (stringify-names (cddr option) "symbol")))
	   (setf incomming (append-unique names incomming :import-from))
	   (let ((assoc (assoc package-name imports
			       :test #'string=)))
	     (if assoc
		 (setf (cdr assoc) (append (cdr assoc) names))
		 (setf imports (acons package-name names imports))))))
	(:intern
	 (let ((new (stringify-names (cdr option) "symbol")))
	   (setf incomming (append-unique new incomming :intern))
667
	   (setf outgoing (append-unique new outgoing :intern))
668
669
670
	   (setf interns (append interns new))))
	(:export
	 (let ((new (stringify-names (cdr option) "symbol")))
671
	   (setf outgoing (append-unique new outgoing :export))
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
	   (setf exports (append exports new))))
	(t
	 (error "Bogus DEFPACKAGE option: ~S" option))))
    `(eval-when (compile load eval)
       (%defpackage ,(stringify-name package "package") ',nicknames ',size
		    ',shadows ',shadowing-imports ',(if use-p use :default)
		    ',imports ',interns ',exports))))

(defun stringify-name (name kind)
  (typecase name
    (simple-string name)
    (string (coerce name 'simple-string))
    (symbol (symbol-name name))
    (t
     (error "Bogus ~A name: ~S" kind name))))

(defun stringify-names (names kind)
  (mapcar #'(lambda (name)
	      (stringify-name name kind))
	  names))

(defun append-unique (new old list)
  (dolist (name new)
    (if (member name old)
	(cerror "Ignore it."
		"Duplicate name in the ~S list: ~A" list name)
	(push name old)))
  old)

(defun %defpackage (name nicknames size shadows shadowing-imports
			 use imports interns exports)
  (declare (type simple-base-string name)
	   (type list nicknames shadows shadowing-imports
		 imports interns exports)
	   (type (or list (member :default)) use))
  (let ((package (or (find-package name)
		     (progn
		       (when (eq use :default)
			 (setf use *default-package-use-list*))
		       (make-package name
				     :use nil
				     :internal-symbols (or size 10)
				     :external-symbols (length exports))))))
715
    (unless (string= (the string (package-name package)) name)
716
717
718
719
720
      (error "~A is a nick-name for the package ~A"
	     name (package-name name)))
    (enter-new-nicknames package nicknames)
    ;; Shadows and Shadowing-imports.
    (let ((old-shadows (package-%shadowing-symbols package)))
721
      (shadow shadows package)
722
723
724
725
726
      (dolist (sym-name shadows)
	(setf old-shadows (remove (find-symbol sym-name package) old-shadows)))
      (dolist (simports-from shadowing-imports)
	(let ((other-package (package-or-lose (car simports-from))))
	  (dolist (sym-name (cdr simports-from))
wlott's avatar
wlott committed
727
	    (let ((sym (find-or-make-symbol sym-name other-package)))
728
729
730
731
732
733
734
735
736
	      (shadowing-import sym package)
	      (setf old-shadows (remove sym old-shadows))))))
      (when old-shadows
	(warn "~A also shadows the following symbols:~%  ~S"
	      name old-shadows)))
    ;; Use
    (unless (eq use :default)
      (let ((old-use-list (package-use-list package))
	    (new-use-list (mapcar #'package-or-lose use)))
737
738
	(use-package (set-difference new-use-list old-use-list) package)
	(let ((laterize (set-difference old-use-list new-use-list)))
739
740
741
	  (when laterize
	    (unuse-package laterize package)
	    (warn "~A used to use the following packages:~%  ~S" laterize)))))
742
743
744
745
746
747
    ;; Import and Intern.
    (dolist (sym-name interns)
      (intern sym-name package))
    (dolist (imports-from imports)
      (let ((other-package (package-or-lose (car imports-from))))
	(dolist (sym-name (cdr imports-from))
wlott's avatar
wlott committed
748
	  (import (find-or-make-symbol sym-name other-package) package))))
749
    ;; Exports.
750
751
752
    (let ((old-exports nil)
	  (exports (mapcar #'(lambda (sym-name) (intern sym-name package))
			   exports)))
753
      (do-external-symbols (sym package)
754
	(push sym old-exports))
755
756
757
758
759
      (export exports package)
      (let ((diff (set-difference old-exports exports)))
	(when diff
	  (warn "~A also exports the following symbols:~%  ~S"
		name diff))))
760
    package))
761

wlott's avatar
wlott committed
762
763
764
765
766
767
768
769
770
771
772
773
774
(defun find-or-make-symbol (name package)
  (multiple-value-bind
      (symbol how)
      (find-symbol name package)
    (cond (how
	   symbol)
	  (t
	   (cerror "INTERN it."
		   "~A does not contain a symbol ~A"
		   (package-name package)
		   name)
	   (intern name package)))))

wlott's avatar
wlott committed
775

ram's avatar
ram committed
776
777
778
779
780
781
782
783
784
;;; Enter-New-Nicknames  --  Internal
;;;
;;;    Enter any new Nicknames for Package into *package-names*.
;;; If there is a conflict then give the user a chance to do
;;; something about it.
;;;
(defun enter-new-nicknames (package nicknames)
  (check-type nicknames list)
  (dolist (n nicknames)
785
    (let* ((n (package-namify n))
ram's avatar
ram committed
786
787
788
	   (found (gethash n *package-names*)))
      (cond ((not found)
	     (setf (gethash n *package-names*) package)
789
	     (push n (package-%nicknames package)))
ram's avatar
ram committed
790
	    ((eq found package))
791
	    ((string= (the string (package-%name found)) n)
ram's avatar
ram committed
792
793
	     (cerror "Ignore this nickname."
		     "~S is a package name, so it cannot be a nickname for ~S."
794
		     n (package-%name package)))
ram's avatar
ram committed
795
796
797
	    (t
	     (cerror "Redefine this nickname."
		     "~S is already a nickname for ~S."
798
		     n (package-%name found))
ram's avatar
ram committed
799
	     (setf (gethash n *package-names*) package)
800
	     (push n (package-%nicknames package)))))))
ram's avatar
ram committed
801
802
803
804
805
806
807
808


;;; Make-Package  --  Public
;;;
;;;    Check for package name conflicts in name and nicknames, then
;;; make the package.  Do a use-package for each thing in the use list
;;; so that checking for conflicting exports among used packages is done.
;;;
809
(defun make-package (name &key (use *default-package-use-list*) nicknames
ram's avatar
ram committed
810
811
812
813
814
815
816
817
			  (internal-symbols 10) (external-symbols 10))
  "Makes a new package having the specified Name and Nicknames.  The
  package will inherit all external symbols from each package in
  the use list.  :Internal-Symbols and :External-Symbols are
  estimates for the number of internal and external symbols which
  will ultimately be present in the package."
  (when (find-package name)
    (error "A package named ~S already exists" name))
818
  (let* ((name (package-namify name))
ram's avatar
ram committed
819
	 (package (internal-make-package
820
		   :%name name
ram's avatar
ram committed
821
822
823
824
825
826
827
828
		   :internal-symbols (make-package-hashtable internal-symbols)
		   :external-symbols (make-package-hashtable external-symbols))))
    (if *in-package-init*
	(push (list use package) *deferred-use-packages*)
	(use-package use package))
    (enter-new-nicknames package nicknames)
    (setf (gethash name *package-names*) package)))

829
;;; Old-In-Package  --  Sorta Public.
ram's avatar
ram committed
830
;;;
831
;;;    Like Make-Package, only different.  Should go away someday.
ram's avatar
ram committed
832
;;;
833
(defun old-in-package (name &rest keys &key nicknames use)
ram's avatar
ram committed
834
  "Sets *package* to package with given name, creating the package if
835
836
837
838
839
   it does not exist.  If the package already exists then it is modified
   to agree with the :Use and :Nicknames arguments.  Any new nicknames
   are added without removing any old ones not specified.  If any package
   in the :Use list is not currently used, then it is added to the use
   list."
ram's avatar
ram committed
840
841
842
843
844
845
846
847
848
849
850
  (let ((package (find-package name)))
    (cond
     (package
      (if *in-package-init*
	  (push (list use package) *deferred-use-packages*)
	  (use-package use package))
      (enter-new-nicknames package nicknames)
      (setq *package* package))
     (t
      (setq *package* (apply #'make-package name keys))))))

851
852
853
854
855
856
857
858
;;; IN-PACKAGE -- public.
;;; 
(defmacro in-package (package &rest noise)
  (cond ((or noise
	     (not (or (stringp package) (symbolp package))))
	 (warn "Old-style IN-PACKAGE.")
	 `(old-in-package ,package ,@noise))
	(t
859
	 `(%in-package ',(stringify-name package "package")))))
860
861
862
863
;;;
(defun %in-package (name)
  (setf *package* (package-or-lose name)))

ram's avatar
ram committed
864
865
866
867
868
869
870
871
872
873
874
875
;;; Rename-Package  --  Public
;;;
;;;    Change the name if we can, blast any old nicknames and then
;;; add in any new ones.
;;;
(defun rename-package (package name &optional (nicknames ()))
  "Changes the name and nicknames for a package."
  (let* ((package (package-or-lose package))
	 (name (string name))
	 (found (find-package name)))
    (unless (or (not found) (eq found package))
      (error "A package named ~S already exists." name))
876
877
    (remhash (package-%name package) *package-names*)
    (dolist (n (package-%nicknames package))
ram's avatar
ram committed
878
      (remhash n *package-names*))
879
880
     (setf (package-%name package) name)
    (setf (gethash name *package-names*) package)
881
    (setf (package-%nicknames package) ())
ram's avatar
ram committed
882
883
884
    (enter-new-nicknames package nicknames)
    package))

885
886
;;; Delete-Package -- Public
;;;
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
(defun delete-package (package-or-name)
  "Delete the package-or-name from the package system data structures."
  (let ((package (if (packagep package-or-name)
		     package-or-name
		     (find-package package-or-name))))
    (cond ((not package)
	   (cerror "Return NIL" "No package of name ~S." package-or-name)
	   nil)
	  ((not (package-name package)) nil)
	  (t
	   (let ((use-list (package-used-by-list package)))
	     (when use-list
	       (cerror "Remove dependency in other packages."
		       "Package ~S is used by package(s):~%  ~S"
		       (package-name package) (mapcar #'package-name use-list))
	       (dolist (p use-list)
		 (unuse-package package p))))
	   (dolist (used (package-use-list package))
	     (unuse-package used package))
	   (do-symbols (sym package)
	     (unintern sym package))
	   (remhash (package-name package) *package-names*)
	   (dolist (nick (package-nicknames package))
	     (remhash nick *package-names*))
	   (setf (package-%name package) nil)
	   t))))
913

ram's avatar
ram committed
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
;;; List-All-Packages  --  Public
;;;
;;;
(defun list-all-packages ()
  "Returns a list of all existing packages."
  (let ((res ()))
    (maphash #'(lambda (k v)
		 (declare (ignore k))
		 (pushnew v res))
	     *package-names*)
    res))

;;; Intern  --  Public
;;;
;;;    Simple-stringify the name and call intern*.
;;;
(defun intern (name &optional package)
  "Returns a symbol having the specified name, creating it if necessary."
  (let ((name (if (simple-string-p name) name (coerce name 'simple-string))))
    (declare (simple-string name))
    (intern* name (length name)
	     (if package (package-or-lose package) *package*))))

;;; Find-Symbol  --  Public
;;;
;;;    Ditto.
;;;
(defun find-symbol (name &optional package)
  "Returns the symbol named String in Package.  If such a symbol is found
  then the second value is :internal, :external or :inherited to indicate
  how the symbol is accessible.  If no symbol is found then both values
  are NIL."
  (let ((name (if (simple-string-p name) name (coerce name 'simple-string))))
    (declare (simple-string name))
    (find-symbol* name (length name)
		  (if package (package-or-lose package) *package*))))

;;; Intern*  --  Internal
;;;
;;;    If the symbol doesn't exist then create it, special-casing
;;; the keyword package.
;;;
(defun intern* (name length package)
  (declare (simple-string name))
  (multiple-value-bind (symbol where) (find-symbol* name length package)
    (if where
	(values symbol where)
wlott's avatar
wlott committed
961
	(let ((symbol (make-symbol (subseq name 0 length))))
962
	  (%set-symbol-package symbol package)
ram's avatar
ram committed
963
964
	  (cond ((eq package *keyword-package*)
		 (add-symbol (package-external-symbols package) symbol)
965
		 (%set-symbol-value symbol symbol))
ram's avatar
ram committed
966
967
968
969
970
971
972
973
974
975
976
977
		(t
		 (add-symbol (package-internal-symbols package) symbol)))
	  (values symbol nil)))))

;;; Find-Symbol*  --  Internal
;;;
;;;    Check internal and external symbols, then scan down the list
;;; of hashtables for inherited symbols.  When an inherited symbol
;;; is found pull that table to the beginning of the list.
;;;
(defun find-symbol* (string length package)
  (declare (simple-string string)
978
	   (type index length))
979
  (let* ((hash (%sxhash-simple-substring string length))
ram's avatar
ram committed
980
	 (ehash (entry-hash length hash)))
981
    (declare (type index hash ehash))
ram's avatar
ram committed
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
    (with-symbol (found symbol (package-internal-symbols package)
			string length hash ehash)
      (when found
	(return-from find-symbol* (values symbol :internal))))
    (with-symbol (found symbol (package-external-symbols package)
			string length hash ehash)
      (when found
	(return-from find-symbol* (values symbol :external))))
    (let ((head (package-tables package)))
      (do ((prev head table)
	   (table (cdr head) (cdr table)))
	  ((null table) (values nil nil))
	(with-symbol (found symbol (car table) string length hash ehash)
	  (when found
	    (unless (eq prev head)
	      (shiftf (cdr prev) (cdr table) (cdr head) table))
	    (return-from find-symbol* (values symbol :inherited))))))))

;;; Find-External-Symbol  --  Internal
;;;
;;;    Similar to Find-Symbol, but only looks for an external symbol.
;;; This is used for fast name-conflict checking in this file and symbol
;;; printing in the printer.
;;;
(defun find-external-symbol (string package)
  (declare (simple-string string))
  (let* ((length (length string))
1009
	 (hash (%sxhash-simple-string string))
ram's avatar
ram committed
1010
	 (ehash (entry-hash length hash)))
1011
    (declare (type index length hash))
ram's avatar
ram committed
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
    (with-symbol (found symbol (package-external-symbols package)
			string length hash ehash)
      (values symbol found))))

;;; Unintern  --  Public
;;;
;;;    If we are uninterning a shadowing symbol, then a name conflict can
;;; result, otherwise just nuke the symbol.
;;;
(defun unintern (symbol &optional (package *package*))
  "Makes Symbol no longer present in Package.  If Symbol was present
  then T is returned, otherwise NIL.  If Package is Symbol's home
  package, then it is made uninterned."
  (let* ((package (package-or-lose package))
	 (name (symbol-name symbol))
1027
	 (shadowing-symbols (package-%shadowing-symbols package)))
ram's avatar
ram committed
1028
1029
1030
1031
1032
1033
    (declare (list shadowing-symbols) (simple-string name))
    ;;
    ;; If a name conflict is revealed, give use a chance to shadowing-import
    ;; one of the accessible symbols.
    (when (member symbol shadowing-symbols)
      (let ((cset ()))
1034
	(dolist (p (package-%use-list package))
ram's avatar
ram committed
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
	  (multiple-value-bind (s w) (find-external-symbol name p)
	    (when w (pushnew s cset))))
	(when (cdr cset)
	  (loop
	   (cerror
	    "prompt for a symbol to shadowing-import."
	    "Uninterning symbol ~S causes name conflict among these symbols:~%~S"
	    symbol cset)
	   (write-string "Symbol to shadowing-import: " *query-io*)
	   (let ((sym (read *query-io*)))
	     (cond
	      ((not (symbolp sym))
	       (format *query-io* "~S is not a symbol."))
	      ((not (member sym cset))
	       (format *query-io* "~S is not one of the conflicting symbols."))
	      (t
	       (shadowing-import sym package)
	       (return-from unintern t)))))))
1053
      (setf (package-%shadowing-symbols package)
1054
	    (remove symbol shadowing-symbols)))
ram's avatar
ram committed
1055
1056
1057
1058
1059
1060
1061
1062
1063

    (multiple-value-bind (s w) (find-symbol name package)
      (declare (ignore s))
      (cond ((or (eq w :internal) (eq w :external))
	     (nuke-symbol (if (eq w :internal)
			      (package-internal-symbols package)
			      (package-external-symbols package))
			  name)
	     (if (eq (symbol-package symbol) package)
1064
		 (%set-symbol-package symbol nil))
ram's avatar
ram committed
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
	     t)
	    (t nil)))))

;;; Symbol-Listify  --  Internal
;;;
;;;    Take a symbol-or-list-of-symbols and return a list, checking types.
;;;
(defun symbol-listify (thing)
  (cond ((listp thing)
	 (dolist (s thing)
	   (unless (symbolp s) (error "~S is not a symbol." s)))
	 thing)
	((symbolp thing) (list thing))
	(t
	 (error "~S is neither a symbol nor a list of symbols." thing))))

;;; Moby-Unintern  --  Internal
;;;
;;;    Like Unintern, but if symbol is inherited chases down the
;;; package it is inherited from and uninterns it there.  Used
;;; for name-conflict resolution.  Shadowing symbols are not
;;; uninterned since they do not cause conflicts.
;;;
(defun moby-unintern (symbol package)
1089
  (unless (member symbol (package-%shadowing-symbols package))
ram's avatar
ram committed
1090
1091
1092
1093
1094
    (or (unintern symbol package)
	(let ((name (symbol-name symbol)))
	  (multiple-value-bind (s w) (find-symbol name package)
	    (declare (ignore s))
	    (when (eq w :inherited)
1095
	      (dolist (q (package-%use-list package))
ram's avatar
ram committed
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
		(multiple-value-bind (u x) (find-external-symbol name q)
		  (declare (ignore u))
		  (when x
		    (unintern symbol q)
		    (return t))))))))))

;;; Export  --  Public
;;;
;;;    Do more stuff.
;;;
(defun export (symbols &optional (package *package*))
  "Exports Symbols from Package, checking that no name conflicts result."
  (let ((package (package-or-lose package))
	(syms ()))
    ;;
    ;; Punt any symbols that are already external.
    (dolist (sym (symbol-listify symbols))
      (multiple-value-bind (s w)
			   (find-external-symbol (symbol-name sym) package)
	(declare (ignore s))
	(unless (or w (member sym syms)) (push sym syms))))
    ;;
    ;; Find symbols and packages with conflicts.
1119
    (let ((used-by (package-%used-by-list package))
ram's avatar
ram committed
1120
1121
1122
1123
1124
1125
1126
	  (cpackages ())
	  (cset ()))
      (dolist (sym syms)
	(let ((name (symbol-name sym)))
	  (dolist (p used-by)
	    (multiple-value-bind (s w) (find-symbol name p)
	      (when (and w (not (eq s sym))
1127
			 (not (member s (package-%shadowing-symbols p))))
ram's avatar
ram committed
1128
1129
1130
1131
1132
1133
		(pushnew sym cset)
		(pushnew p cpackages))))))
      (when cset
	(restart-case
	    (error "Exporting these symbols from the ~A package:~%~S~%~
		    results in name conflicts with these packages:~%~{~A ~}"
1134
		   (package-%name package) cset (mapcar #'package-%name cpackages))
ram's avatar
ram committed
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
	  (unintern-conflicting-symbols ()
	   :report "Unintern conflicting symbols."
	   (dolist (p cpackages)
	     (dolist (sym cset)
	       (moby-unintern sym p))))
	  (skip-exporting-these-symbols ()
	   :report "Skip exporting conflicting symbols."
	   (setq syms (nset-difference syms cset))))))
    ;;
    ;; Check that all symbols are accessible.  If not, ask to import them.
    (let ((missing ())
	  (imports ()))
      (dolist (sym syms)
	(multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
	  (cond ((not (and w (eq s sym))) (push sym missing))
		((eq w :inherited) (push sym imports)))))
      (when missing
	(cerror "Import these symbols into the ~A package."
		"These symbols are not accessible in the ~A package:~%~S"
1154
		(package-%name package) missing)
ram's avatar
ram committed
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
	(import missing package))
      (import imports package))
    ;;
    ;; And now, three pages later, we export the suckers.
    (let ((internal (package-internal-symbols package))
	  (external (package-external-symbols package)))
      (dolist (sym syms)
	(nuke-symbol internal (symbol-name sym))
	(add-symbol external sym)))
    t))

;;; Unexport  --  Public
;;;
;;;    Check that all symbols are accessible, then move from external to
;;; internal.
;;;
(defun unexport (symbols &optional (package *package*))
  "Makes Symbols no longer exported from Package."
  (let ((package (package-or-lose package))
	(syms ()))
    (dolist (sym (symbol-listify symbols))
      (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
	(cond ((or (not w) (not (eq s sym)))
	       (error "~S is not accessible in the ~A package."
1179
		      sym (package-%name package)))
ram's avatar
ram committed
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
	      ((eq w :external) (pushnew sym syms)))))

    (let ((internal (package-internal-symbols package))
	  (external (package-external-symbols package)))
      (dolist (sym syms)
	(add-symbol internal sym)
	(nuke-symbol external (symbol-name sym))))
    t))

;;; Import  --  Public
;;;
;;;    Check for name conflic caused by the import and let the user 
;;; shadowing-import if there is.
;;;
(defun import (symbols &optional (package *package*))
  "Make Symbols accessible as internal symbols in Package.  If a symbol
  is already accessible then it has no effect.  If a name conflict
  would result from the importation, then a correctable error is signalled."
  (let ((package (package-or-lose package))
	(symbols (symbol-listify symbols))
	(syms ())
	(cset ()))
    (dolist (sym symbols)
      (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
	(cond ((not w)
	       (let ((found (member sym syms :test #'string=)))
		 (if found
		     (when (not (eq (car found) sym))
		       (push sym cset))
		     (push sym syms))))
	      ((not (eq s sym)) (push sym cset))
	      ((eq w :inherited) (push sym syms)))))
    (when cset
      (cerror
       "Import these symbols with Shadowing-Import."
       "Importing these symbols into the ~A package causes a name conflict:~%~S"
1216
       (package-%name package) cset))
ram's avatar
ram committed
1217
1218
1219
1220
1221
1222
1223
1224
    ;;
    ;; Add the new symbols to the internal hashtable.
    (let ((internal (package-internal-symbols package)))
      (dolist (sym syms)
	(add-symbol internal sym)))
    ;;
    ;; If any of the symbols are uninterned, make them be owned by Package.
    (dolist (sym symbols)
1225
      (unless (symbol-package sym) (%set-symbol-package sym package)))
ram's avatar
ram committed
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
    (shadowing-import cset package)))

;;; Shadowing-Import  --  Public
;;;
;;;    If a conflicting symbol is present, unintern it, otherwise just
;;; stick the symbol in.
;;;
(defun shadowing-import (symbols &optional (package *package*))
  "Import Symbols into package, disregarding any name conflict.  If
  a symbol of the same name is present, then it is uninterned.
  The symbols are added to the Package-Shadowing-Symbols."
  (let* ((package (package-or-lose package))
	 (internal (package-internal-symbols package)))
    (dolist (sym (symbol-listify symbols))
      (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
	(unless (and w (not (eq w :inherited)) (eq s sym))
	  (when (or (eq w :internal) (eq w :external))
	    ;;
	    ;; If it was shadowed, we don't want Unintern to flame out...
1245
	    (setf (package-%shadowing-symbols package)
1246
		  (remove s (the list (package-%shadowing-symbols package))))
ram's avatar
ram committed
1247
1248
	    (unintern s package))
	  (add-symbol internal sym))
1249
	(pushnew sym (package-%shadowing-symbols package)))))
ram's avatar
ram committed
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
  t)


;;; Shadow  --  Public
;;;
;;;
(defun shadow (symbols &optional (package *package*))
  "Make an internal symbol in Package with the same name as each of the
  specified symbols, adding the new symbols to the Package-Shadowing-Symbols.
  If a symbol with the given name is already present in Package, then
  the existing symbol is placed in the shadowing symbols list if it is
  not already present."
  (let* ((package (package-or-lose package))
	 (internal (package-internal-symbols package)))
1264
    (dolist (name (mapcar #'string
1265
			  (if (listp symbols) symbols (list symbols))))
1266
1267
1268
      (multiple-value-bind (s w) (find-symbol name package)
	(when (or (not w) (eq w :inherited))
	  (setq s (make-symbol name))
1269
	  (%set-symbol-package s package)
1270
	  (add-symbol internal s))
wlott's avatar
wlott committed
1271
	(pushnew s (package-%shadowing-symbols package)))))
ram's avatar
ram committed
1272
  t)
wlott's avatar
wlott committed
1273
1274


ram's avatar
ram committed
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289

;;; Use-Package  --  Public
;;;
;;;    Do stuff to use a package, with all kinds of fun name-conflict
;;; checking.
;;;
(defun use-package (packages-to-use &optional (package *package*))
  "Add all the Package-To-Use to the use list for Package so that
  the external symbols of the used packages are accessible as internal
  symbols in Package."
  (let ((packages (package-listify packages-to-use))
	(package (package-or-lose package)))
    ;;
    ;; Loop over each package, use'ing one at a time...
    (dolist (pkg packages)
1290
      (unless (member pkg (package-%use-list package))
ram's avatar
ram committed
1291
	(let ((cset ())
1292
1293
	      (shadowing-symbols (package-%shadowing-symbols package))
	      (use-list (package-%use-list package)))
ram's avatar
ram committed
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
	  ;;
	  ;;   If the number of symbols already accessible is less than the
	  ;; number to be inherited then it is faster to run the test the
	  ;; other way.  This is particularly valuable in the case of
	  ;; a new package use'ing Lisp.
	  (cond
	   ((< (+ (internal-symbol-count package)
		  (external-symbol-count package)
		  (let ((res 0))
		    (dolist (p use-list res)
		      (incf res (external-symbol-count p)))))
	       (external-symbol-count pkg))
	    (do-symbols (sym package)
	      (multiple-value-bind (s w)
				   (find-external-symbol (symbol-name sym) pkg)
		(when (and w (not (eq s sym))
			   (not (member sym shadowing-symbols)))
		  (push sym cset))))
	    (dolist (p use-list)
	      (do-external-symbols (sym p)
		(multiple-value-bind (s w)
				     (find-external-symbol (symbol-name sym)
							   pkg)
		  (when (and w (not (eq s sym))
			     (not (member (find-symbol (symbol-name sym)
						       package)
					  shadowing-symbols)))
		    (push sym cset))))))
	   (t
	    (do-external-symbols (sym pkg)
	      (multiple-value-bind (s w)
				   (find-symbol (symbol-name sym) package)
		(when (and w (not (eq s sym))
			   (not (member s shadowing-symbols)))
		  (push s cset))))))
	  
	  (when cset
	    (cerror
	     "unintern the conflicting symbols in the ~2*~A package."
	     "Use'ing package ~A results in name conflicts for these symbols:~%~S"
1334
	     (package-%name pkg) cset (package-%name package))
ram's avatar
ram committed
1335
1336
	    (dolist (s cset) (moby-unintern s package))))

1337
	(push pkg (package-%use-list package))
ram's avatar
ram committed
1338
	(push (package-external-symbols pkg) (cdr (package-tables package)))
1339
	(push package (package-%used-by-list pkg)))))
ram's avatar
ram committed
1340
1341
1342
1343
1344
1345
1346
1347
1348
  t)

;;; Unuse-Package  --  Public
;;;
;;;
(defun unuse-package (packages-to-unuse &optional (package *package*))
  "Remove Packages-To-Unuse from the use list for Package."
  (let ((package (package-or-lose package)))
    (dolist (p (package-listify packages-to-unuse))
1349
      (setf (package-%use-list package)
1350
	    (remove p (the list (package-%use-list package))))
ram's avatar
ram committed
1351
1352
1353
      (setf (package-tables package)
	    (delete (package-external-symbols p)
		    (the list (package-tables package))))
1354
      (setf (package-%used-by-list p)
1355
	    (remove package (the list (package-%used-by-list p)))))
ram's avatar
ram committed
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
    t))

;;; Find-All-Symbols --  Public
;;;
;;;
(defun find-all-symbols (string-or-symbol)
  "Return a list of all symbols in the system having the specified name."
  (let ((string (string string-or-symbol))
	(res ()))
    (maphash #'(lambda (k v)
		 (declare (ignore k))
		 (multiple-value-bind (s w) (find-symbol string v)
		   (when w (pushnew s res))))
	     *package-names*)
    res))


;;; Apropos and Apropos-List.

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

(defun apropos-search (symbol string)
  (declare (simple-string string))
  (do* ((index 0 (1+ index))
	(name (symbol-name symbol))
	(length (length string))
	(terminus (- (length name) length)))
       ((> index terminus)
	nil)
    (declare (simple-string name)
1393
	     (type index index terminus length))
ram's avatar
ram committed
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
    (if (do ((jndex 0 (1+ jndex))
	     (kndex index (1+ kndex)))
	    ((= jndex length)
	     t)
	  (declare (fixnum jndex kndex))
	  (let ((char (schar name kndex)))
	    (unless (char= (schar string jndex) (char-upcase char))
	      (return nil))))
	(return t))))

1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
;;; MAP-APROPOS -- public (extension).
;;;
(defun map-apropos (fun string &optional package external-only)
  "Call FUN with each symbol that contains STRING.
  If PACKAGE is supplied then only use symbols present in
  that package.  If EXTERNAL-ONLY is true then only use
  symbols exported from the specified package."
  (let ((string (string-upcase string)))
    (declare (simple-string string))
    (flet ((apropos-in-package (package)
             (if external-only
                 (do-external-symbols (symbol package)
                   (if (and (eq (symbol-package symbol) package)
                            (apropos-search symbol string))
                       (funcall fun symbol)))
                 (do-symbols (symbol package)
                   (if (and (eq (symbol-package symbol) package)
                            (apropos-search symbol string))
                       (funcall fun symbol))))))
      (if (null package)
          (mapc #'apropos-in-package (list-all-packages))
          (apropos-in-package (package-or-lose package))))
    nil))

;;; APROPOS -- public.
;;; 
ram's avatar
ram committed
1430
1431
1432
1433
1434
(defun apropos (string &optional package external-only)
  "Briefly describe all symbols which contain the specified String.
  If Package is supplied then only describe symbols present in
  that package.  If External-Only is true then only describe
  external symbols in the specified package."
1435
1436
  (map-apropos #'briefly-describe-symbol string package external-only)
  (values))
ram's avatar
ram committed
1437

1438
1439
;;; APROPOS-LIST -- public.
;;; 
ram's avatar
ram committed
1440
1441
1442
(defun apropos-list (string &optional package external-only)
  "Identical to Apropos, except that it returns a list of the symbols
  found instead of describing them."
1443
1444
1445
1446
1447
1448
1449
  (collect ((result))
    (map-apropos #'(lambda (symbol)
		     (result symbol))
		 string package external-only)
    (result)))


ram's avatar
ram committed
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469

;;; Initialization.

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

(defvar *initial-symbols*)

(defun package-init ()
  (let ((*in-package-init* t))
    (dolist (spec *initial-symbols*)
      (let* ((pkg (apply #'make-package (first spec)))
	     (internal (package-internal-symbols pkg))
	     (external (package-external-symbols pkg)))
	;;
	;; Put internal symbols in the internal hashtable and set package.
	(dolist (symbol (second spec))
	  (add-symbol internal symbol)
1470
	  (%set-symbol-package symbol pkg))
ram's avatar
ram committed
1471
1472
1473
1474
	;;
	;; External symbols same, only go in external table.
	(dolist (symbol (third spec))
	  (add-symbol external symbol)
1475
	  (%set-symbol-package symbol pkg))
ram's avatar
ram committed
1476
1477
1478
1479
1480
1481
1482
1483
	;;
	;; Don't set package for Imported symbols.
	(dolist (symbol (fourth spec))
	  (add-symbol internal symbol))
	(dolist (symbol (fifth spec))
	  (add-symbol external symbol))
	;;
	;; Put shadowing symbols in the shadowing symbols list.
1484
	(setf (package-%shadowing-symbols pkg) (sixth spec))))
ram's avatar
ram committed
1485
1486
1487
1488

    (makunbound '*initial-symbols*) ; So it gets GC'ed.
    
    ;; Make some other packages that should be around in the cold load:
1489
    (make-package "COMMON-LISP-USER" :nicknames '("CL-USER" "USER"))
ram's avatar
ram committed
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500

    ;; Now do the *deferred-use-packages*:
    (dolist (args *deferred-use-packages*)
      (apply #'use-package args))
    (makunbound '*deferred-use-packages*)

    (setq *lisp-package* (find-package "LISP"))
    (setq *keyword-package* (find-package "KEYWORD"))

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